pascals.txt

pascals编译程序源代码及说明

    x: integer;

procedure skip(fsys: symset; n: integer);
begin error(n);
   while not (sy in fsys) do insymbol
end (* skip *);

procedure test(s1, s2: symset; n: integer);
begin if not (sy in s1) then
      skip(s1+s2, n)
end (* test *);

procedure testsemicolon;
begin
   if sy = semicolon then insymbol else
   begin error(14);
      if sy in [comma, colon] then insymbol
   end;
   test([ident]+blockbegsys, fsys, 6)
end (* testsemicolon *);

procedure enter(id: alfa; k: object);
   var j, l: integer;
begin if t = tmax then fatal(1) else
      begin tab[0].name := id;
         j := btab[display[level]].last; l := j;
         while tab[j].name <> id do j := tab[j].link;
         if j <> 0 then error(1) else
         begin t := t+1;
            with tab[t] do
            begin name := id; link := l;
             obj := k; typ := notyp; ref := 0; lev := level;
             adr := 0
            end;
            btab[display[level]].last := t
          end
       end
end (* enter *);

function loc(id: alfa): integer;
   var i, j: integer;  (* locate id in table *)
begin i := level; tab[0].name := id; (* sentinel *)
   repeat j := btab[display[i]].last;
      while tab[j].name <> id do j := tab[j].link;
      i := i-1;
   until (i<0) or (j<>0);
   if j = 0 then error(0); loc := j
end (* loc *);

procedure entervariable;
begin if sy = ident then
        begin enter(id, variable); insymbol
        end
      else error(2)
end (* entervariable *);

procedure constant(fsys: symset; var c: conrec);
  var x, sign: integer;
begin c.tp := notyp; c.i := 0;
  test(constbegsys, fsys, 50);
  if sy in constbegsys then
  begin
    if sy = charcon then
      begin c.tp := chars; c.i := inum; insymbol
      end
    else
      begin sign := 1;
        if sy in [plus, minus] then
          begin if sy = minus then sign := -1;
            insymbol
          end;
        if sy = ident then
          begin x := loc(id);
            if x <> 0 then
              if tab[x].obj <> konstant then error(25) else
              begin c.tp := tab[x].typ;
                if c.tp = reals
                     then c.r := sign*rconst[tab[x].adr]
                     else c.i := sign*tab[x].adr
              end;
            insymbol
          end
        else
        if sy = intcon then
           begin c.tp := ints; c.i := sign*inum; insymbol
           end else
        if sy = realcon then
           begin c.tp := reals; c.r := sign*rnum; insymbol
           end else skip(fsys, 50)
      end;
    test(fsys, [], 6)
  end
end (* constant *);

procedure typ(fsys: symset; var tp: types; var rf, sz: integer);
  var x: integer;
      eltp: types; elrf: integer;
      elsz, offset, t0, t1: integer;

procedure arraytyp(var aref, arsz: integer);
  var eltp: types;
     low, high: conrec;
     elrf, elsz: integer;
begin constant([colon, rbrack, rparent, ofsy]+fsys, low);
   if low.tp = reals then
      begin error(27); low.tp := ints; low.i := 0
      end;
   if sy = colon then insymbol else error(13);
   constant([rbrack, comma, rparent, ofsy]+fsys, high);
   if high.tp <> low.tp then
      begin error(27); high.i := low.i
      end;
   enterarray(low.tp, low.i, high.i); aref := a;
   if sy = comma then
      begin insymbol; eltp := arrays; arraytyp(elrf, elsz)
      end else
   begin
      if sy = rbrack then insymbol else
         begin error(12);
            if sy = rparent then insymbol
         end;
      if sy = ofsy then insymbol else error(8);
      typ(fsys, eltp, elrf, elsz)
   end;
   with atab[aref] do
   begin arsz := (high-low+1)*elsz; size := arsz;
      eltyp := eltp; elref := elrf; elsize := elsz
   end;
end (* arraytyp *);

begin (* typ *) tp := notyp; rf := 0; sz := 0;
   test(typebegsys, fsys, 10);
   if sy in typebegsys then
      begin
        if sy = ident then
        begin x := loc(id);
          if x <> 0 then
          with tab[x] do
            if obj <> typel then error(29) else
            begin tp := typ; rf := ref; sz := adr;
              if tp = notyp then error(30)
            end;
          insymbol
        end else
        if sy = arraysy then
        begin insymbol;
            if sy = lbrack then insymbol else
               begin error(11);
                  if sy = lparent then insymbol
               end;
            tp := arrays; arraytyp(rf, sz)
        end else
        begin (* records *) insymbol;
          enterblock; tp := records; rf := b;
          if level = lmax then fatal(5);
          level := level+1; display[level] := b; offset := 0;
          while sy <> endsy do
          begin (* field section *)
            if sy = ident then
            begin t0 := t; entervariable;
              while sy = comma do
                 begin insymbol; entervariable
                 end;
              if sy = colon then insymbol else error(5);
              t1 := t;
              typ(fsys+[semicolon, endsy, comma, ident],
                  eltp, elrf, elsz);
              while t0 < t1 do
              begin t0 := t0+1;
                with tab[t0] do
                begin typ := eltp; ref := elrf; normal := true;
                  adr := offset; offset := offset + elsz
                end
              end
            end;
            if sy <> endsy then
            begin if sy = semicolon then insymbol else
                  begin error(14);
                    if sy = comma then insymbol
                  end;
              test([ident, endsy, semicolon], fsys, 6)
            end
          end;
          btab[rf].vsize := offset; sz := offset;
          btab[rf].psize := 0; insymbol; level := level-1
        end;
        test(fsys, [], 6)
      end
end (* typ *);

procedure parameterlist; (* formal parameter list *)
   var tp: types;
       rf, sz, x, t0: integer;
       valpar: boolean;
begin insymbol; tp := notyp; rf := 0; sz := 0;
  test([ident, varsy], fsys+[rparent], 7);
  while sy in [ident, varsy] do
    begin if sy <> varsy then valpar := true else
            begin insymbol; valpar := false
            end;
      t0 := t; entervariable;
      while sy = comma do
         begin insymbol; entervariable;
         end;
      if sy = colon then
        begin insymbol;
          if sy <> ident then error(2) else
          begin x := loc(id); insymbol;
            if x <> 0 then
            with tab[x] do
              if obj <> typel then error(29) else
                begin tp := typ; rf := ref;
                   if valpar then sz := adr else sz := 1
                end;
          end;
          test([semicolon, rparent], [comma, ident]+fsys, 14)
        end
      else error(5);
      while t0 < t do
      begin t0 := t0+1;
        with tab[t0] do
        begin typ := tp; ref := rf;
           normal := valpar; adr := dx; lev := level;
           dx := dx + sz
        end
      end;
      if sy <> rparent then
      begin if sy = semicolon then insymbol else
            begin error(14);
              if sy = comma then insymbol
            end;
         test([ident, varsy], [rparent]+fsys, 6)
      end
    end (* while *);
  if sy = rparent then
    begin insymbol;
      test([semicolon, colon], fsys, 6)
    end
  else error(4)
end (* parameter list *);

procedure constantdeclaration;
   var c: conrec;
begin insymbol;
  test([ident], blockbegsys, 2);
  while sy = ident do
    begin enter(id, konstant); insymbol;
      if sy = egl then insymbol else
         begin error(16);
            if sy = becomes then insymbol
         end;
      constant([semicolon, comma, ident]+fsys, c);
      tab[t].typ := c.tp; tab[t].ref := 0;
      if c.tp = reals then
        begin enterreal(c.r); tab[t].adr := c1 end
      else tab[t].adr := c.i;
      testsemicolon
    end
end (* constantdeclaration *);

procedure typedeclaration;
   var tp: types; rf, sz, t1: integer;
begin insymbol;
  test([ident], blockbegsys, 2);
  while sy = ident do
    begin enter(id, typel); t1 := t; insymbol;
      if sy = egl then insymbol else
         begin error(16);
            if sy = becomes then insymbol
         end;
      typ([semicolon, comma, ident]+fsys, tp, rf, sz);
      with tab[t1] do
        begin typ := tp; ref := rf; adr := sz
        end;
      testsemicolon
    end
end (* typedeclaration *);

procedure variabledeclaration;
  var t0, t1, rf, sz: integer;
      tp: types;
begin insymbol;
  while sy = ident do
  begin t0 := t; entervariable;
    while sy = comma do
      begin insymbol; entervariable;
      end;
    if sy = colon then insymbol else error(5);
    t1 := t;
    typ([semicolon, comma, ident]+fsys, tp, rf, sz);
    while t0 < t1 do