编译程序源代码(pascal代码).txt.txt

这个是Pascal编的。教为简单。 包含词法分析在内。

                getsym; 
                factor(fsys+[times,slash]); 
                if mulop=times then gen(opr,0,4) else gen(opr,0,5) 
              end; 
            end; (* term *) 
  
        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,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 *) 
      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:=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 *) 
  
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(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; 
    test(statbegsys+[ident],declbegsys,7); 
  until not(sym in declbegsys); 
  code[table[tx0].adr].a:=cx; 
  with table[tx0] do begin 
       adr:=cx; 
       size:=dx; 
  end; 
  cx0:=cx; 
  gen(int,0,dx); 
  statement([semicolon,endsym]+fsys); 
  gen(opr,0,0); 
  test(fsys,[],8); 
  listcode; 
end; (* block *) 
  
procedure interpret; 
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; 
    var bl:integer; 
    begin 
      bl:=b; (* find base 1 level down *) 
      while l>0 do begin 
        bl:=s[bl]; 
        l:=l-1; 
      end; 
      base:=bl; 
    end; (* base *) 
  
begin 
  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 (* 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; 
             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]); 
                writeln(fa2,s[t]); 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]) *) t:=t-1; end; 
      cal: begin (* generat 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; 
  close(fa2); 
end; (* interpret *) 
  
begin (* main *) 
  for ch:=' ' to '!' do ssym[ch]:=nul; 
  (* changed bacause of different character set 
     note the typos below in the original where 
     the alfas were not given the 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]; 
  
  (* page(output) *) 
  endf:=false; 
  assign(fa1,'PL0.txt'); 
  rewrite(fa1); 
  write('input file? '); 
  write(fa1,'input file?'); 
  readln(fname); 
  writeln(fa1,fname); 
  (* openf(fin,fname,'r'); ==> *) 
  assign(fin,fname); reset(fin); 
  write('list object code ?'); 
  readln(fname); 
  write(fa1,'list object code ?'); 
  listswitch:=(fname[1]='y'); 
  err:=0; 
  cc:=0; cx:=0; ll:=0; 
  ch:=' '; kk:=al; 
  getsym; 
  assign(fa,'PL0-1.txt'); 
  assign(fa2,'PL0-2.txt'); 
  rewrite(fa); 
  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('error in pl/0 program'); 
99: (* this line is not work in turbo pascal so replace by 
       procedure exitp: see the memo at the top *) 
  close(fin); 
  writeln; 
end.