pl0_02.pas

一个词法分析器还有实验的说明

    expression(fsys);
    gen(opr,0,6);
  end
  else
  begin
    expression([eql,neq,lss,leq,gtr,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*);


begin(*statement*)                    {======statement processing=====2222}
  if sym=ident then
  begin
    i:=position(id);
    if i=0 then error(11)
    else
      if table[i].kind<>variable then
      begin
	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=readsym then
    begin
      getsym;
      if sym<>lparen then error(34)
      else
      repeat
	getsym;
	if sym=ident then i:=position(id)
        else i:=0;
        if i=0 then error(35)
        else
	with table[i] do
	begin
	  gen(opr,0,16);
	  gen(sto,lev-level,adr);
        end;
	getsym;
      until sym<>comma;
      if sym<>rparen then
      begin
        error(33);
	while not(sym in fsys)do getsym;
      end
      else getsym;
    end
    else

    if sym=writesym then
    begin
      getsym;
      if sym=lparen then
      begin
      repeat
	getsym;
        expression([rparen,comma]+fsys);
	gen(opr,0,14)
      until sym<>comma;
      if sym<>rparen then error(33)
      else getsym;
    end;
    gen(opr,0,15);
    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=procedur 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:=code_index;
	gen(jpc,0,0);
	statement(fsys);
	code[cx1].a:=code_index;
      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:=code_index;
	getsym;
	condition([dosym]+fsys);
	cx2:=code_index;
	gen(jpc,0,0);
        if sym=dosym then getsym
        else error(18);
        statement(fsys);
        gen(jmp,0,cx1);
        code[cx2].a:=code_index
      end;
    test(fsys,[],19)
end(*statement*);

begin(*block*)            {***************block begin here*******************11111}
 dx:=3;
 tx0:=tx;
 table[tx].adr:=code_index;
 gen(jmp,0,0);
 if lev>levelmax
   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;{end do with constance }
  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;{end to do with variable declaration}
   While sym=procsym do
    begin
      getsym;
        if sym=ident then
          begin
            enter(procedur);
            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;{end while sym=procsym}

   test(statbegsys+[ident],declbegsys,7)
 until not(sym in declbegsys);{end the declaration process}

 code[table[tx0].adr].a:=code_index;
 with table[tx0] do
   begin
     adr:=code_index;
     size:=dx;
   end;
 cx0:=code_index;
 gen(int,0,dx);
 statement([semicolon,endsym]+fsys);
 gen(opr,0,0);
 test(fsys,[],8);
 listcode
end(*block*);

procedure interpret;  {*******interpret:对目标代码的解释执行程序**********1111}
 const stacksize=500;
 var p,b,t:integer;(*program base topstack registers*)
     i:instruction;
     s:array[1..stacksize]of integer;(*datastore*)

 Function base(l:integer):integer; {====base:通过静态链求数据区的基地址==2222}
  Var b1:integer;
  Begin
    B1:=b;(*find base 1 level down*)
    While l>0 do
      Begin
        B1:=s[b1];
        L:=l-1
      End;
    Base:=b1
  End(*base*);

 begin                                {======begin interpret========1111}
   writeln('start pl0');
   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   (* opreator*)
               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;
               14:begin
	           write(s[t]);
	           write(fa2,s[t]);
	           t:=t-1;
	           end;
               15:begin
	           writeln;
	           writeln(fa2);
	           end;
               16:begin
	           t:=t+1;
	           write('?');
	           write(fa2,'?');
	           readln(s[t]);
	           end;
          end;{end opr}
        lod:begin
	    t:=t+1;
	    s[t]:=s[base(1)+a]
	    end;
        sto:begin
	    s[base(1)+a]:=s[t];         (*writeln(s[t])*)
	    t:=t-1;
	    end;
        cal:begin(*generat new block mark*)
	    s[t+1]:=base(1);
	    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 i case f *)
   until p=0;
   close(fa2)
 end(* interpret *);



{****************************main program begin here************************************0000}
begin(*main*)
 for ch:=' 'to'!'do ssym[ch]:=nul;
	(* changed because of different character set note
          the typos below in the original where the alfas
          were not given correct space *)
  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]:='read      ';
  word[10]:='then      ';
  word[11]:='var       ';
  word[12]:='while     ';
  word[13]:='write     ';


  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]:=readsym;      wsym[10]:=thensym;
  wsym[11]:=varsym;      wsym[12]:=whilesym;
  wsym[13]:=writesym;


  ssym['+']:=plus;       ssym['-']:=minus;
  ssym['*']:=times;      ssym['/']:=slash;
  ssym['(']:=lparen;     ssym[')']:=rparen;
  ssym['=']:=eql;        ssym[',']:=comma;
  ssym['.']:=period;     ssym['#']:=neq;
  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];

  assign(fa1,'');    {fa1: list running time information }
  rewrite(fa1);
  write(fa1,'source file?');
  readln(fname);
  writeln(fa1,fname);

  assign(fin,fname); {fin:source file will be complied}
  reset(fin);
  {read(fin,fname);}

  write('list object code ?');
  readln(fname);
  write(fa1,'list object code ?');
  listswitch:=(fname='y');

  err:=0;   {error number}
  char_count:=0;    {}
  code_index:=0;
  line_length:=0;
  ch:=' ';
  kk:=idLength;   {}
  getsym;

  assign(fa,'fa');rewrite(fa);
  assign(fa2,'fa2');rewrite(fa2);
  block(0,0,[period]+declbegsys+statbegsys);
  close(fa);
  close(fa1);

  if sym<>period then
     error(9);
  if err=0 then
     interpret
  else
     write('errors in pl/0 program');
99:
  close(fin);
  writeln
end.