program6.pas

07497编译设计与开发技术-斯传根（原代码）

program PL0(input,output);
(* PL/0 compile with code generation *)
const norw = 11;        (* no. of reserved words *)
  txmax = 100;          (* length of identifier table *)
  nmax = 14;            (* max. no of digits in numbers *)
  al = 10;              (* length of identifiers *)
  chsetsize = 128;      (* for ASCII character set *)
  maxerr = 30;          (* max. no. of errors *)
  amax = 2048;          (* maximaum address *)
  levmax = 3;           (* maximium depth of block nesting *)
  cxmax = 200;          (* size of code array *)

type symbol =
  (nul,ident,number,plus,minus,times,slash,oddsym,
   eql,neq,lss,leq,gtr,geq,lparen,rparen,comma,semicolon,
   period,becomes,beginsym,endsym,ifsym,thensym,
   whilesym,dosym,callsym,constsym,varsym,procsym);
  alfa = packed array [1..al] of char;
  objekt = (constant,variable,prozedure);
  symset = set of symbol;
  fct = (lit,opr,lod,sto,cal,int,jmp,jpc);
  instruction = packed record
                f: fct;         (* function code *)
                l: 0..levmax;   (* level *)
                a: 0..amax;     (* displacement adress *)
                end;
(*      LIT 0,a         : load constant a
        OPR 0,a         : exec operation a
        LOD l,a         : load variable l,a
        STO l,a         : store variable l,a
        CAL l,a         : call procedure a at level l
        INT 0,a         : increment t-register by a
        JMP 0,a         : jump to a
        JPC 0,a         : jump conditional to a *)
var ch:char;            (* last character read *)
  sym: symbol;          (* last symbol read *)
  id: alfa;             (* last identifier read *)
  num: integer;         (* last number read *)
  cc: integer;          (* character count *)
  ll: integer;          (* line length *)
  kk,err: integer;
  cx: integer;          (* code allocation index *)
  line: array[1..81] of char;
  a: alfa;
  code: array[0..cxmax] of instruction;
  word: array[1..norw] of alfa;
  wsym: array[1..norw] of symbol;
  ssym: array [char] of symbol;
  mnemonic: array[fct] of packed array [1..5] of char;
  declbegsys,statbegsys,facbegsys: symset;
  table: array [0..txmax] of
                record name: alfa;
                  case kind: objekt of
                  constant: (val: integer);
                  variable,prozedure:(level,adr,size:integer);
                end;
  inf,outf: text;

procedure error(n: integer);
begin writeln(' ':cc-1,'^',n:2);
  writeln(outf,' ':cc-1,'^',n:2);
  err := err + 1; if err > maxerr then halt
end(* error *);

procedure listall;
var i:integer;
begin(* list all the code generated for the program *)
  writeln('All the PL/0 object code:');
  writeln(outf,'All the PL/0 object code:');
  for i:=0 to cx-1 do
    with code[i] do
     begin
      writeln(i,mnemonic[f]:5,l:3,a:5);
      writeln(outf,i,mnemonic[f]:5,l:3,a:5)
     end;
end (*listall*);

procedure getsym;
  var i,j,k:integer;
  procedure getch;
  begin if cc = ll then
    begin if eof(inf) then
        begin write('program incomplete'); halt
        end;
      ll:= 0; cc:= 0;
      while not eoln(inf) do
        begin ll:=ll+1; read(inf,ch); write(ch); 
write(outf,ch); line[ll]:= ch
        end;
      writeln; writeln(outf); ll:=ll+1; readln(inf); line[ll]:=' '
    end;
    cc:=cc+1; ch:=line[cc]
  end(* getch *);

(* getsym *)
begin (* getsym *)
  while ch=' ' do getch;
  if ch in ['a'..'z'] then
  begin (* identifier or reserved word *) k:=0;
    repeat if k < al then
      begin k:=k+1; a[k]:=ch
      end;
      getch
    until not (ch in ['a'..'z','0'..'9']);
    if k>=kk then kk:=k else
      repeat a[kk]:=' '; kk:=kk-1
      until kk=k;
    id:=a; i:=1; j:=norw;
    repeat k:=(i+j)div 2;
      if id<=word[k] then j:=k-1;
      if id>=word[k] then i:=k+1
    until i>j;
    if i-1>j then sym:=wsym[k] else sym:=ident
  end else
  if ch in ['0'..'9'] then
  begin (* number *) k:=0; num:=0; sym:=number;
    repeat num:=10*num+(ord(ch)-ord('0'));
      k:=k+1; getch
    until not (ch in ['0'..'9']);
    if k> nmax then error(30)
  end else
  if ch=':' then
  begin getch;
    if ch='=' then
    begin sym:=becomes; getch
    end else sym:=nul;
  end else
  if ch='<' then
  begin getch;
    if ch='=' then
    begin sym:=leq; getch
    end else sym:=lss
  end else
  if ch='>' then
  begin getch;
    if ch='=' then
    begin sym:=geq; getch
    end else sym:=gtr
  end else
  begin sym:=ssym[ch]; getch
  end
end(* getsym *);

procedure gen(x:fct;y,z:integer);
begin if cx>cxmax then
        begin write(' program too long'); halt
        end;
  with code[cx] do
    begin f:=x; l:=y; a:=z
    end;
  cx:=cx+1
end(* gen *);

procedure test(s1,s2:symset; n:integer);
begin if not(sym in s1) then
        begin error(n); s1:=s1+s2;
          while not(sym in s1) do getsym
        end
end(*test*);

procedure block(lev,tx:integer;fsys:symset);
  var dx:integer;       (*data allocation index*)
     tx0:integer;       (*initial table index*)
     cx0:integer;       (*initial code index*)

  procedure enter(k:objekt);
  begin (*enter object into table*)
    tx:=tx+1;
    with table[tx] do
    begin name:=id; kind:=k;
      case k of
      constant:begin if num>amax then
                begin error(31); num:=0 end;
                val:=num
              end;
      variable:begin level:=lev; adr:=dx; dx:=dx+1;
               end;
      prozedure: level:=lev
      end
    end
  end(*enter*);

  function position(id:alfa):integer;
    var i:integer;
  begin(* find identifier id in table *)
    table[0].name:=id; i:=tx;
    while table[i].name<>id do i:=i-1;
    position:=i
  end(* position *);

  procedure constdeclaration;
  begin if sym=ident then
    begin getsym;
        if sym in [eql,becomes] then
          begin if sym=becomes then error(1);
            getsym;
            if sym=number then
                begin enter(constant); getsym
          end
        else error(2)
      end else error(3)
    end else error(4)
  end (* constdeclaration *);

  procedure vardeclaration;
  begin if sym=ident then
        begin enter(variable); getsym
        end else error(4)
  end(* vardeclaration *);

  procedure listcode;
  var i:integer;
  begin(*list code generated for this block*)
    for i:=cx0 to cx-1 do
      with code[i] do
        begin
          writeln(i,mnemonic[f]:5,l:3,a:5);
          writeln(outf,i,mnemonic[f]:5,l:3,a:5)
        end;
  end (*listcode*);

  procedure statement(fsys:symset);
    var i,cx1,cx2:integer;

    procedure expression(fsys:symset);
    var addop:symbol;

      procedure term(fsys:symset);
        var mulop:symbol;

        procedure factor(fsys:symset);
          var i:integer;
        begin test(facbegsys,fsys,24);
          while sym in facbegsys do
          begin
          if sym=ident then
          begin i:=position(id);
            if i=0 then error(11) else
            with table[i] do
            case kind of
              constant: gen(lit,0,val);
              variable: gen(lod,lev-level,adr);
              prozedure: error(21)
            end;
            getsym
          end else
          if sym=number then
          begin if num>amax then
            begin error(31); num:=0
            end;
            gen(lit,0,num); getsym
          end else
          if sym=lparen then
          begin getsym; expression([rparen]+fsys);
            if sym=rparen then getsym else error(22)
          end;
          test(fsys,[lparen],23)
        end
      end(*factor*);

(* term *)