pascals.txt

pascals编译程序源代码及说明

   msg[16] := '=         '; msg[17] := 'boolean   ';
   msg[18] := 'convar typ'; msg[19] := 'type      ';
   msg[20] := 'prog.param'; msg[21] := 'too big   ';
   msg[22] := '.         '; msg[23] := 'typ (case)';
   msg[24] := 'character '; msg[25] := 'const id  ';
   msg[26] := 'index type'; msg[27] := 'indexbound';
   msg[28] := 'no array  '; msg[29] := 'type id   ';
   msg[30] := 'undef type'; msg[31] := 'no record ';
   msg[32] := 'boole type'; msg[33] := 'arith type';
   msg[34] := 'integer   '; msg[35] := 'types     ';
   msg[36] := 'param type'; msg[37] := 'variab id ';
   msg[38] := 'string    '; msg[39] := 'no.of pars';
   msg[40] := 'type      '; msg[41] := 'type      ';
   msg[42] := 'real type '; msg[43] := 'integer   ';
   msg[44] := 'var, const'; msg[45] := 'var, proc ';
   msg[46] := 'types (:=)'; msg[47] := 'typ (case)';
   msg[48] := 'type      '; msg[49] := 'store ovfl';
   msg[50] := 'constant  '; msg[51] := ':=        ';
   msg[52] := 'then      '; msg[53] := 'until     ';
   msg[54] := 'do        '; msg[55] := 'to downto ';
   msg[56] := 'begin     '; msg[57] := 'end       ';
   msg[58] := 'factor    ';
   k := 0; writeln; writeln(' key words');
   while errs <> [] do
   begin while not (k in errs) do k := k+1;
         writeln(k,'  ',msg[k]); errs := errs - [k]
   end
end (* errormsg *);

procedure nextch; (* read next character; process line end *)
begin if cc = ll then
      begin if eos(input) then         
            begin writeln;
               writeln(' program incomplete');
               errormsg; goto 99
            end;
         if errpos <> 0 then
            begin writeln; errpos := 0
            end;
         write(lc:5, '  ');
         ll := 0; cc := 0;
         while not eoln(input) do
            begin ll := ll+1; read(ch); write(ch); line[ll] := ch
            end;
         writeln; ll := ll+1; read(line[ll]);
      end;
   cc := cc+1; ch := line[cc];
end (* nextch *);

procedure error(n: integer);
begin if errpos = 0 then write(' ****');
   if cc > errpos then
      begin write(' ': cc-errpos, '^', n:2);
         errpos := cc+3; errs := errs + [n]
      end
end (* error *);

procedure fatal(n: integer);
   var msg: array [1..7] of alfa;
begin writeln; errormsg;
   msg[ 1] := 'identifier'; msg[ 2] := 'procedures';
   msg[ 3] := 'reals     '; msg[ 4] := 'arrays    ';
   msg[ 5] := 'levels    '; msg[ 6] := 'code      ';
   msg[ 7] := 'strings   ';
   writeln(' compiler table for ', msg[n], ' is too small');
   goto 99  (* terminate compilation *)
end (* fatal *);

procedure insymbol;   (* reads next symbol *)
   label 1, 2, 3;
   var i, j, k, e: integer;

   procedure readscale;
      var s, sign: integer;
   begin nextch; sign := 1; s := 0;
      if ch = '+' then nextch else
      if ch = '-' then begin nextch; sign := -1 end;
      while ch in ['0'..'9'] do
         begin s := 10*s + ord(ch) - ord('0'); nextch
         end;
      e := s*sign + e
   end (* readscale *);

procedure adjustscale;
   var s: integer; d, t: real;
begin if k+e > emax then error(21) else
      if k+e < emin then rnum := 0 else
  begin s := abs(e); t := 1.0; d := 10.0;
    repeat
       while not odd(s) do
          begin s := s div 2; d := sqr(d)
          end;
       s := s-1; t := d*t
    until s = 0;
    if e >= 0 then rnum := rnum*t else rnum := rnum/t
  end
end (* adjustscale *);

begin (* insymbol *)
1: while ch = ' ' do nextch;
   if ch in ['a'..'z'] then
   begin (* word *) k := 0; id := '          ';
      repeat if k < alng then
             begin k := k+1; id[k] := ch
             end;
         nextch
      until not (ch in ['a'..'z', '0'..'9']);
      i := 1; j := nkw; (* binary search *)
      repeat k := (i+j) div 2;
         if id <= key[k] then j := k-1;
         if id >= key[k] then i := k+1
      until i > j;
      if i-1 > j then sy := ksy[k] else sy := ident
   end else
   if ch in ['0'..'9'] then
   begin (* number *) k := 0; inum := 0; sy := intcon;
      repeat inum := inum*10 + ord(ch) - ord('0');
         k := k+1; nextch
      until not (ch in ['0'..'9']);
      if (k > kmax) or (inum > nmax) then
         begin error(21); inum := 0; k := 0
         end;
      if ch = '.' then
      begin nextch;
         if ch = '.' then ch := ':' else
            begin sy := realcon; rnum := inum; e := 0;
               while ch in ['0'..'9'] do
               begin e := e-1;
                  rnum := 10.0*rnum + (ord(ch)-ord('0')); nextch
               end;
               if ch = 'e' then readscale;
               if e <> 0 then adjustscale
            end
      end else
      if ch = 'e' then
      begin sy := realcon; rnum := inum; e := 0;
         readscale; if e <> 0 then adjustscale
      end;
   end else
   case ch of
':': begin nextch;
         if ch = '=' then
           begin sy := becomes; nextch
           end else sy := colon
     end;
'<': begin nextch;
        if ch = '=' then begin sy := leg; nextch end else
        if ch = '>' then begin sy := neg; nextch end else sy := lss
     end;
'>': begin nextch;
         if ch = '=' then begin sy := geg; nextch end else sy := gtr
     end;
'.': begin nextch;
        if ch = '.' then
           begin sy := colon; nextch
           end else sy := period
     end;
'''': begin k := 0;
    2: nextch;
       if ch = '''' then
         begin nextch; if ch <> '''' then goto 3
         end;
       if sx+k = smax then fatal(7);
       stab[sx+k] := ch; k := k+1;
       if cc = 1 then
          begin (* end of line *) k := 0;
          end
       else goto 2;
    3: if k = 1 then
          begin sy := charcon; inum := ord(stab[sx])
          end else
       if k = 0 then
          begin error(38); sy := charcon; inum := 0
          end else
          begin sy := stringt; inum := sx; sleng := k; sx := sx+k
          end
      end;
'(': begin nextch;
        if ch <> '*' then sy := lparent else
        begin (* comment *) nextch;
           repeat
              while ch <> '*' do nextch;
              nextch
           until ch = ')';
           nextch; goto 1
        end
     end;
'+', '-',  '*', '/', ')', '=', ',', '[', ']', '#', '&', ';':
     begin sy := sps[ch]; nextch
     end;
'$', '%', '@', '\', '~', '{', '}', '^':
     begin error(24); nextch; goto 1
     end
  end
end (* insymbol *);

procedure enter(x0: alfa; x1: object;
                x2: types; x3: integer);
begin t := t+1; (* enter standard identifier *)
   with tab[t] do
   begin name := x0; link := t-1; obj := x1;
      typ := x2; ref := 0; normal := true;
      lev := 0; adr := x3
   end
end (* enter *);

procedure enterarray(tp: types; l, h: integer);
begin if l > h then error(27);
   if (abs(l)>xmax) or (abs(h)>xmax) then
      begin error(27); l := 0; h := 0;
      end;
   if a = amax then fatal(4) else
     begin a:= a+1;
       with atab[a] do
           begin inxtyp := tp; low := l; high := h
           end
     end
end (* enterarray *);

procedure enterblock;
begin if b = bmax then fatal(2) else
      begin b := b+1; btab[b].last := 0; btab[b].lastpar := 0
      end
end (* enterblock *);

procedure enterreal(x: real);
begin if c2 = c2max-1 then fatal(3) else
      begin rconst[c2+1] := x; c1 := 1;
         while rconst[c1] <> x do c1 := c1+1;
         if c1 > c2 then c2 := c1
      end
end (* enterreal *);

procedure emit(fct: integer);
begin if lc = cmax then fatal(6);
   code[lc].f := fct; lc := lc+1
end (* emit *);

procedure emit1(fct, b: integer);
begin if lc = cmax then fatal(6);
   with code[lc] do
      begin f := fct; y := b end;
   lc := lc+1
end (* emit1 *);

procedure emit2(fct, a, b: integer);
begin if lc = cmax then fatal(6);
   with code[lc] do
     begin f := fct; x := a; y := b end;
   lc := lc+1
end (* emit2 *);

procedure printtables;
   var i: integer; o: order;
begin
   writeln('0identifiers     link  obj  typ  ref  nrm  lev  adr');
   for i := btab[1].last +1 to t do
      with tab[i] do
      writeln(i, ' ', name, link:5, ord(obj):5, ord(typ):5, ref:5,
              ord(normal):5, lev:5, adr:5);
   writeln('0blocks    last lpar psze vsze');
   for i := 1 to b do
      with btab[i] do
      writeln(i, last:5, lastpar:5, psize:5, vsize:5);
   writeln('0arrays    xtyp etyp eref  low high elsz size');
   for i := 1 to a do
      with atab[i] do
      writeln(i, ord(inxtyp):5, ord(eltyp):5,
              elref:5, low:5, high:5, elsize:5, size:5);
   writeln('0code:');
   for i := 0 to lc-1 do
   begin if i mod 5 = 0 then
         begin writeln; write(i: 5)
         end;
      o := code[i]; write(o.f:5);
      if o.f < 31 then
        if o.f < 4 then write(o.x:2, o.y:5)
                    else write(o.y:7)
      else write('       ');
      write(',')
   end;
   writeln
end (* printtables *);

procedure block(fsys: symset; isfun: boolean; level: integer);
type conrec =
   record case tp: types of
      ints, chars, bools: (i: integer);
      reals: (r: real);
      notyp, arrays, records: ();
   end;

var dx: integer;    (* data allocation index *)
    prt: integer;   (* t-index of this procedure *)
    prb: integer;   (* b-index of this procedure *)