program6.pas

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

      begin(* term *) factor(fsys+[times,slash]);
        while sym in [times,slash] do
          begin mulop:=sym; getsym; factor(fsys+[times,slash]);
            if mulop=times then gen(opr,0,4) else gen(opr,0,5)
          end
      end(* term *);

(* expression *)
    begin (* expression *)
      if sym in [plus,minus] then
        begin addop:=sym; getsym; term(fsys+[plus,minus]);
          if addop=minus then gen(opr,0,1)
        end else term(fsys+[plus,minus]);
      while sym in [plus,minus] do
        begin addop:=sym; getsym; term(fsys+[plus,minus]);
          if addop=plus then gen(opr,0,2) else gen(opr,0,3)
        end
    end(*expression*);

    procedure condition(fsys:symset);
      var relop:symbol;
    begin
      if sym=oddsym then
      begin getsym; expression(fsys); gen(opr,0,6)
      end else
      begin expression([eql,neq,lss,gtr,leq,geq]+fsys);
        if not(sym in [eql,neq,lss,leq,gtr,geq]) then
          error(20) else
        begin relop:=sym; getsym; expression(fsys);
          case relop of
            eql:gen(opr,0,8);
            neq:gen(opr,0,9);
            lss:gen(opr,0,10);
            geq:gen(opr,0,11);
            gtr:gen(opr,0,12);
            leq:gen(opr,0,13);
          end
        end
      end
    end(*condition*);

(*statement*)
  begin(*statement*)
    if not(sym in fsys+[ident]) then
    begin error(10);
      repeat getsym until sym in fsys
    end;
    if sym=ident then
    begin i:=position(id);
      if i=0 then error(11) else
      if table[i].kind<>variable then
        begin (*assignment to non-variable*) error(12); i:=0
        end;
      getsym; if sym=becomes then getsym else error(13);
      expression(fsys);
      if i<>0 then
        with table[i] do gen(sto,lev-level,adr)
    end else
    if sym=callsym then
    begin getsym;
      if sym<>ident then error(14) else
        begin i:=position(id);
          if i=0 then error(11) else
          with table[i] do
            if kind=prozedure then gen(cal,lev-level,adr)
            else error(15);
          getsym
        end
    end else
    if sym=ifsym then
    begin getsym; condition([thensym,dosym]+fsys);
      if sym=thensym then getsym else error(16);
      cx1:=cx; gen(jpc,0,0);
      statement(fsys); code[cx1].a:=cx
    end else
    if sym=beginsym then
    begin getsym; statement([semicolon,endsym]+fsys);
      while sym in [semicolon]+statbegsys do
      begin
        if sym=semicolon then getsym else error(10);
        statement([semicolon,endsym]+fsys)
      end;
      if sym=endsym then getsym else error(17)
    end else
    if sym=whilesym then
    begin cx1:=cx; getsym; condition([dosym]+fsys);
      cx2:=cx; gen(jpc,0,0);
      if sym=dosym then getsym else error(18);
      statement(fsys); gen(jmp,0,cx1); code[cx2].a:=cx
    end;
    test(fsys,[],19)
  end(*statement*);

(*block*)
begin(*block*) dx:=3; tx0:=tx; table[tx].adr:=cx; gen(jmp,0,0);
  if lev>levmax then error(32);
  repeat
    if sym=constsym then
    begin getsym;
      repeat constdeclaration;
        while sym=comma do
          begin getsym; constdeclaration
          end;
        if sym=semicolon then getsym else error(5)
      until sym<>ident
    end;
    if sym=varsym then
    begin getsym;
      repeat vardeclaration;
        while sym=comma do
          begin getsym; vardeclaration
          end;
        if sym=semicolon then getsym else error(5)
      until sym<>ident;
    end;
    while sym=procsym do
    begin getsym;
      if sym=ident then
        begin enter(prozedure); getsym
        end
      else error(4);
      if sym=semicolon then getsym else error(5);
      block(lev+1,tx,[semicolon]+fsys);
      if sym=semicolon then
        begin getsym; test(statbegsys+[ident,procsym],fsys,6)
        end
      else error(5)
    end;
    test(statbegsys+[ident],declbegsys,7)
  until not(sym in declbegsys);
  code[table[tx0].adr].a:=cx;
  with table[tx0] do
    begin adr:=cx; (* start adr of code*)
        size:=dx; (*size of data segment*)
    end;
  cx0:=cx; gen(int,0,dx);
  statement([semicolon,endsym]+fsys);
  gen(opr,0,0); (*return*)
  test(fsys,[],8);
  listcode;
end(*block*);

procedure interpret;
  const stacksize=500;
  var p,b,t:integer; (*program-,base-,topstack-registers*)
      i:instruction; (*instruction register*)
      s:array[1..stacksize] of integer; (*datastore*)

  function base(l:integer):integer;
    var b1:integer;
  begin b1:=b;  (*find base l levels down*)
    while l>0 do
      begin b1:=s[b1]; l:=l-1
      end;
    base:=b1
  end(*base*);

(* interpret *)
begin writeln('Start PL/0');
  writeln(outf,'Start PL/0');
  t:=0; b:=1; p:=0;
  s[1]:=0; s[2]:=0; s[3]:=0;
  repeat i:=code[p]; p:=p+1;
    with i do
    case f of
  lit: begin t:=t+1; s[t]:=a
        end;
  opr: case a of        (*operator*)
        0:begin(*return*)
            t:=b-1; p:=s[t+3]; b:=s[t+2];
          end;
        1:s[t]:=-s[t];
        2:begin t:=t-1; s[t]:=s[t]+s[t+1]
          end;
        3:begin t:=t-1; s[t]:=s[t]-s[t+1]
          end;
        4:begin t:=t-1; s[t]:=s[t]*s[t+1]
          end;
        5:begin t:=t-1; s[t]:=s[t] div s[t+1]
          end;
        6:s[t]:=ord(odd(s[t]));
        8:begin t:=t-1; s[t]:=ord(s[t]=s[t+1])
          end;
        9:begin t:=t-1; s[t]:=ord(s[t]<>s[t+1])
          end;
        10:begin t:=t-1; s[t]:=ord(s[t]<s[t+1])
          end;
        11:begin t:=t-1; s[t]:=ord(s[t]>=s[t+1])
          end;
        12:begin t:=t-1; s[t]:=ord(s[t]>s[t+1])
          end;
        13:begin t:=t-1; s[t]:=ord(s[t]<=s[t+1])
          end;
        end;
  lod:begin t:=t+1; s[t]:=s[base(l)+a]
      end;
  sto:begin s[base(l)+a]:=s[t]; writeln(s[t]); writeln(outf,s[t]); t:=t-1
      end;
  cal:begin(*generate new block mark*)
        s[t+1]:=base(l); s[t+2]:=b; s[t+3]:=p;
        b:=t+1; p:=a;
      end;
  int:t:=t+a;
  jmp:p:=a;
  jpc:begin if s[t]=0 then p:=a; t:=t-1;
      end
    end(*with,case*);
  until p=0;
  write('End PL/0');
  write(outf,'End PL/0');
end(*interpret*);

(* main program *)
begin(* main program *)
  assign(inf,'testin.pl0');
  assign(outf,'testout.txt');
  reset(inf);
  rewrite(outf);
  for ch:=chr(0) to chr(chsetsize-1) do ssym[ch]:=nul;
  word[ 1]:='begin     '; word[ 2]:='call      ';
  word[ 3]:='const     '; word[ 4]:='do        ';
  word[ 5]:='end       '; word[ 6]:='if        ';
  word[ 7]:='odd       '; word[ 8]:='procedure ';
  word[ 9]:='then      '; word[10]:='var       ';
  word[11]:='while     ';
  wsym[ 1]:=beginsym; wsym[ 2]:=callsym;
  wsym[ 3]:=constsym; wsym[ 4]:=dosym;
  wsym[ 5]:=endsym;   wsym[ 6]:=ifsym;
  wsym[ 7]:=oddsym;   wsym[ 8]:=procsym;
  wsym[ 9]:=thensym;  wsym[10]:=varsym;
  wsym[11]:=whilesym;
  ssym['+']:=plus;   ssym['-']:=minus;
  ssym['*']:=times;  ssym['/']:=slash;
  ssym['(']:=lparen; ssym[')']:=rparen;
  ssym['=']:=eql;    ssym[',']:=comma;
  ssym['.']:=period; ssym['#']:=neq;
  ssym['<']:=lss;    ssym['>']:=gtr;
  ssym[';']:=semicolon;
  mnemonic[lit]:=' LIT '; mnemonic[opr]:=' OPR ';
  mnemonic[lod]:=' LOD '; mnemonic[sto]:=' STO ';
  mnemonic[cal]:=' CAL '; mnemonic[int]:=' INT ';
  mnemonic[jmp]:=' JMP '; mnemonic[jpc]:=' JPC ';
  declbegsys:=[constsym,varsym,procsym];
  statbegsys:=[beginsym,callsym,ifsym,whilesym];
  facbegsys:=[ident,number,lparen];
  err:=0;
  cc:=0; cx:=0; ll:=0; ch:=' ';kk:=al; getsym;
  block(0,0,[period]+declbegsys+statbegsys);
  if sym<>period then error(9);
  if err=0 then
    begin
      listall;
      interpret;
    end  else write('Errors in PL/0 program');
  writeln;
  writeln(outf);
  close(outf);
end.