pl0.pas

pl0的几个小程序 老师给的 很简单 共享下

program pl0(fa,fa1,fa2);

label 99;

const norw=13;
      txmax=100;
      nmax=14;
      al=10;
      amax=2047;
      levmax=3;
      cxmax=200;

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, writesym, readsym,
              dosym, callsym,constsym, varsym,procsym);
      alfa=packed array[1..al] of char;
      oobject=(constant,variable,procedur);
      symset=set of symbol;
      fct=(lit,opr,lod, sto, cal,int, jmp,jpc);
      instruction=packed record
                           f:fct;
                           l:0..levmax;
                           a:0..amax
                         end;
var fa:text;
    fa1,fa2:text;
    listswitch:boolean;
    ch:char;
    sym:symbol;
    id:alfa;
    num:integer;
    cc:integer;
    ll:integer;
    kk:integer;
    cx:integer;
    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[' '..'^'] 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: oobject of
                                   constant:(val:integer);
                                   variable,procedur:(level,adr,size:integer)
                                 end;
    fin,fout:text;
    fname,fnamefa1:string;
    err:integer;

procedure error(n:integer);
  begin
    writeln('****',' ':cc-1,'!',n:2);
    writeln(fa1,'****',' ':cc-1,'!',n:2);
    err:=err+1
  end; (* of error*)

procedure getsym;
  var i,j,k: integer;
  procedure getch;
    begin
      if cc=ll
         then
           begin
             if eof(fin)
               then
                 begin
                   write('program incomplete');
 (*                  goto 99                     *)
                 end;
               ll:=0;
               cc:=0;
               write(cx:4,' ');    { generate instruction address}
               write(fa1,cx:4,' ');
               while not eoln(fin) do
                 begin
                   ll:=ll+1;
                   read(fin,ch);
                   write (ch);
                   write(fa1,ch);
                   line[ll]:=ch
                 end;
               writeln;
               ll:=ll+1;
               readln(fin);line[ll]:=' ';
               writeln(fa1);
             end;
           cc:=cc+1;
           ch:=line[cc]
         end; (*getch*)

         begin (*getsym*)
           while ch=' ' do getch;
           if ch in ['a'..'z']
             then
               begin
                 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');
                      (*                 goto 99                      *)
                                      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;
                   tx0:integer;
                   cx0:integer;
               procedure enter(k:oobject);
                 begin
                   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;
                        procedur:level:=lev
                      end
                    end
                   end;(*enter*)
              function position(id:alfa):integer;
                var i:integer;
                  begin
                    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);