PL0程序设计语言

PL0语言可看成是Pascal[1]语言的子集，它的编译程序是一个编译解释执行系统。

PL/0的目标程序为假象栈试计算机的汇编语言，与具体计算机无关。

编译原理的课程作业，就是实现一个PL0的编译程序，分两个任务。第一个任务是生成中间代码以及输出运行过程的栈中数据，第二个任务在第一个任务的基础上实现PL0的read和write函数。

program pl0(input, output);
    {任务一的代码实现}
     
    label 99;
    const norw=11;       {保留字个数}
          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,dosym,callsym,
                 constsym,varsym,procsym);
         alfa=packed array[1..al] of char;
         objects=(constant,variable,procedur);
         {procedure和object在pascal中是关键字，所以分别使用procedur和object替代}
         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;			   {文本文件fa用于列出中间程序}
        srccode,data:text;	   {文本文件srccode用于列出源代码、data用于记录运行数据}
        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[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:objects of
                  constant:(val:integer);
                  variable,procedur:(level,adr,size:integer)
              end;
        fin,fout:text;
        fname:string;
        err:integer;
        endf:boolean;
     
    procedure error(n:integer);
    begin
      writeln('****',' ':cc-1,'!',n:2);
      writeln(srccode,'****','':cc-1,'!',n:2);
      err:=err+1;
    end; {error}
     
    procedure exitp;
    begin
      endf:=true;
      close(fin);
      writeln;
      exit;
    end;
     
    procedure getsym;
    var i,j,k:integer;
     
      procedure getch;
      begin
        if cc=ll then begin
          if eof(fin) then begin
             write('program incomplete');
             close(fin);
             writeln;
             exitp;
           (*  goto 99;*)
          end;
          ll:=0;
          cc:=0;
          write(cx:5,' ');
          write(srccode,cx:5,' ');
          while not eoln(fin) do begin
            ll:=ll+1;
            read(fin,ch);
            write(ch);
            write(srccode,ch);
            line[ll]:=ch;
          end;
          writeln;
          ll:=ll+1;
          line[ll]:=' ';
          readln(fin);
          writeln(srccode);
        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 
        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:objects);
        begin {把objects填入标识符表中}
          tx:=tx+1;
          with table[tx] do begin
            name:=id;
            kind:=k;
            case k of
              constant: begin
                          if num>amax then begin error(30); 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 {在标识符表中查标识符id}
          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
          for i:=cx0 to cx-1 do
            with code[i] do begin
                writeln(i,mnemonic[f]:5,l:3,a:5);
                writeln(fa,i:4,mnemonic[f]:5,l:3,a:5);
            end;
        end; {listcode}
     
        procedure statement(fsys:symset);
        var i,cx1,cx2:integer;
            procedure expression(fsys