(*pl0 compiler with code generation*)
{*****************************主程序*********************************0000}
program pl0(fa,fa1,fa2);

label 99;

const wordmax=13;     {of reserved words}
      idTbmax=100;    {length of identifier table}
      numbmax=14;     {max number of digits in numbers}
      idLength=10;    {length of identifiers}
      addrmax=2047;   {maximun address}
      levelmax=3;     {max depth of block nesting}
      codemax=200;    {size of code array}

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..idLength] of char;
      obj = (constant,variable,procedur);
      symset = set of symbol;
      fct = (lit,opr,lod,sto,cal,int,jmp,jpc);
      instruction = packed record
                      f : fct;
                      l : 0..levelmax;
                      a : 0..addrmax;
                    end;

var  fa,fa1,fa2 : text;
     listswitch : boolean;
  ch : char;
  sym : symbol;
  id : alfa;

  last_read_num : integer;   (* last number read*)
  char_count : integer;     (* character count *)
  line_length : integer;     (* line length *)
  kk: integer;
  code_index: integer;      (*code allocation index *)
  line: array[1..81] of char;
  a : alfa;
  code : array[0..codemax] of instruction;
  word : array[1..wordmax] of alfa;
  wsym : array[1..wordmax] of symbol;
  ssym : array[' '..'^'] of symbol;
  (* wirth uses "arry[char]" here*)
  mnemonic: array[fct] of packed array[1..5] of char;
  declbegsys , statbegsys , facbegsys: symset ;
  table: array[0..idTbmax] of record
                              name: alfa;
                              case kind : obj of
                              constant : (val:integer);
                              variable, procedur : (level,adr,size:integer)
                    (*"size" lacking in original. I think it belongs here*)
                            end;
  fin,fout:text;
  {fname:alfa;}
  fname:string;
  err:integer;

{出錯處理，打印出錯位置和錯誤編碼}
procedure error(n:integer);        {************************************1111}
 begin
  case n of
   1: writeln(fa,'Declare constant error,must be =,not := ', ' ' : char_count-1,'!',n:2);
   2: writeln(fa,'constant declaration ''='' must be followed by = ', ' ' : char_count-1,'!',n:2);
   3: writeln(fa,'constant identify must be followed by = ', ' ' : char_count-1,'!',n:2);
   4: writeln(fa,'must be identify followed by const,var,procedure',' ' : char_count-1,'!',n:2);
   5: writeln(fa,'maybe lost , or ;',' ',char_count-1,'!',n:2);
   6: writeln(fa,'lost begin string of statement or procedur define;',' ',char_count-1,'!',n:2);
   7: writeln(fa,'must be begin string of statement',' ',char_count-1,'!',n:2);
   8: writeln(fa,'statement''s following char is incorrect',' ',char_count-1,'!',n:2);
   9: writeln(fa,'must use . to end the program ',' ',char_count-1,'!',n:2);
   10:writeln(fa,'lost ; ',' ',char_count-1,'!',n:2);
   11:writeln(fa,'id maybe not defined ',' ',char_count-1,'!',n:2);
   12:writeln(fa,'Becomes''s left id must be var',' ',char_count-1,'!',n:2);
   13:writeln(fa,'var must followed by := in becomes statement ',' ',char_count-1,'!',n:2);
   14:writeln(fa,'call must be followed by id',' ',char_count-1,'!',n:2);
   15:writeln(fa,'call must be followed by proc id ',' ',char_count-1,'!',n:2);
   16:writeln(fa,'lost then ',' ',char_count-1,'!',n:2);
   17:writeln(fa,'lost end or ;',' ',char_count-1,'!',n:2);
   18:writeln(fa,'lost do in the while statement',' ',char_count-1,'!',n:2);
   19:writeln(fa,'statement followed by incorrect char',' ',char_count-1,'!',n:2);
   20:writeln(fa,'must be relation opr ',' ',char_count-1,'!',n:2);
   21:writeln(fa,'must not be var,not proc in the expression statement',' ',char_count-1,'!',n:2);
   22:writeln(fa,'lost ) ',' ',char_count-1,'!',n:2);
   23:writeln(fa,'factor followed by incorrect char ',' ',char_count-1,'!',n:2);
   24:writeln(fa,'expression begin char error',' ',char_count-1,'!',n:2);
   31:writeln(fa,'number out of ranger',' ',char_count-1,'!',n:2);
   32:writeln(fa,'read statement must be var in ()',' ',char_count-1,'!',n:2);
  end;
  err:=err+1   {?}
 end  (*error*);

{詞法分析，讀取一個單詞}
 procedure getsym;                   {************************************1111}
 var i,j,k:integer;


   procedure getch;                        {getch:過濾空格，讀取一個字符}
   begin
     if char_count=line_length then
       begin
         if eof(fin) then
           begin
             write('program incomplete');
             (********************************goto 99;*)
           end;
         line_length := 0;
         char_count := 0;
         write(code_index:4,' ');
         write(fa1,code_index:4,'');
         while not eoln(fin) do
           begin
	   line_length:=line_length+1;
	   read(fin,ch);
	   write(ch);
	   write(fa1,ch);
	   line[line_length]:=ch
           end;
         writeln;
         line_length:=line_length+1;
         read(fin,line[line_length]);
         writeln(fa1);
       end;
       char_count:=char_count+1;
       ch:=line[char_count]
   end(*getch*);

 begin(*getsym*)
   while ch in [' ',#13,#10] do getch;
   if ch in ['a'..'z'] then
     begin               (*id or reserved word*)

       k:=0;
       repeat
         if k<idLength then  {idLength=10}
           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;{get identify and store it into id }

       i:=1;
       j:=wordmax;{wordmax=13}
       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]   {reserved word}
       else sym:=ident              {identifier }

     end  {ch in a..z}

   else if ch in['0'..'9'] then
     begin(*number*)
       k := 0;
       last_read_num := 0;
       sym := number;
       repeat
         last_read_num := 10 * last_read_num + (ord(ch) - ord('0'));
         k := k+1;
         getch;
       until not(ch in['0'..'9']);

       if k > numbmax then error(30);
     end {ch in 0..9}

   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 *);


{生成目標代碼，并送入目標程序區(qū)}
procedure gen(x:fct;y,z:integer);      {*********************************1111}
  begin
    if code_index > codemax then
      begin
        write('program too long');
        {goto 99}exit
      end;
      with code[code_index] do
        begin
          f:=x;
          l:=y;
          a:=z
        end;
        code_index:=code_index+1
      end(* gen *);

{測試當前單詞符號是否合法}
procedure test(s1,s2:symset;n:integer);  {*******************************1111}
 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);  {**************************1111}
var dx:integer;   (* data allocation index *)
   tx0:integer;   (* initial table index *)
   cx0:integer;   (* initial code  index*)


procedure enter(k:obj);                {enter:登錄名字表============2222}
begin (* enter object into table *)
  tx:=tx+1;
  with table[tx] do
  begin
     name:=id;
     kind:=k;
     case k of
      constant:begin
	  if last_read_num>addrmax
           then
	    begin
             error(31);
             last_read_num:=0;
	    end;
          val:=last_read_num
           end;
variable:begin
           level:=lev;
           adr:=dx;
           dx:=dx+1;
           end;
      procedur:level:=lev
        end
    end
end(* enter *);



function  position(id:alfa):integer;
                             {position:查找標識符在名字表中的位置==2222}
var i:integer;
begin (*find identifier in table *)
  table[0].name:=id;
  i:=tx;
  while table[i].name<>id do i:=i-1;
  position:=i;
end;(* position *)

procedure constdeclaration;  {constdeclaration:常量定義處理========2222}
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;    {vardeclaration:變量說明處理===========2222}
 begin
   if sym=ident then
    begin
     enter(variable);
     getsym
    end
   else error(4)
 end(*vardeclaration*);

procedure listcode;          {listcode:列目標代碼清單==============2222}
var i:integer;
begin  (*list code generated for this block*)
  if listswitch then
  begin
    for i:=cx0 to code_index-1 do
      with code[i] do
      begin
        writeln(fa,i:4,' ',mnemonic[f]:5,l:3,a:5)
      end;
  end;
end(*listcode*);

procedure statement(fsys:symset);
                             {=========statement:語句部分處理=====2222}
var i,cx1,cx2:integer;

procedure expression(fsys:symset);     {-----expression declare--}
var addop:symbol;

procedure term(fsys:symset);           {****term declare****}
var mulop:symbol;

procedure factor(fsys:symset);         {****factor declare*****}
var i:integer;
begin                              {****factor proceesing*****5555}
  test(facbegsys,fsys,24);
  while sym in facbegsys do
  begin
    if sym = ident then
    begin
      i := position(id);
      if i = 0 then
         error(11)
      else
        with table[i] do
        case kind of
          constant:gen(lit,0,val);
          variable:gen(lod,lev-level,adr);
          procedur:error(21);
        end;
      getsym;
    end
    else
    if sym=number then
    begin
      if last_read_num>addrmax then
      begin
        error(31);
        last_read_num:=0;
      end;
      gen(lit,0,last_read_num);
      getsym;
    end
    else
      if sym=lparen then
      begin
        getsym;
        expression([rparen]+fsys);
        if sym=rparen then getsym
        else error(22);
      end;
      test(fsys,facbegsys,23)
    end;
end(*factor*);

begin(*term*)                            {****term proceesing*****4444}
  factor([times,slash]+fsys);
  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*);

begin                                  {----expression proceesing--3333}
  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);      {---condition processing------3333}
var relop:symbol;
begin
  if sym=oddsym then
  begin
    getsym;