el.pas

编译原理实验 完整的

program EL(input,output,fin);


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

procedure error(n: integer);
begin  writeln('****',' ': cc-1,'^',n:2);  err:=err+1
end;{error}

procedure getsym;
   var i,j,k:integer;

   procedure getch;
   begin if cc=ll then
     begin if eof(fin) then
              begin writeln('program incomplete');
                 close(fin);
                 exit;
              end;
           ll:=0;cc:=0;write(cx:4,' ');
           while not eoln(fin) do
              begin ll:=ll+1;  read(fin,ch); write(ch);
                line[ll]:=ch
              end;
           writeln;readln(fin);
           ll:=ll+1;line[ll]:=' '
     end;
     cc:=cc+1;ch:=line[cc]
   end;{getch}

begin
   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 if ch='>' then
      begin sym:=neq; 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 writeln('program too long');
             close(fin);
             exit;
         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:object0);
begin
   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;
         prosedure: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);  getsym
         end else error(4)
end;{vardeclaration}

procedure listcode;
var i:integer;
begin
   for i:=cx0 to cx-1 do
      with code[i] do
         writeln(i:4 ,mnemonic[f]:7, l:3, a:5)
end;{listcode}

procedure statement(fsys:symset);
var i,cx1,cx2:integer;
  procedure expression(fsys:symset);
  var addop:symbol;
    procedure term(fsys:symset);
    var mulop:symbol;
      procedure factor(fsys:symset);
         var i:integer;
      begin 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);
                  prosedure:error(21)
               end;
               getsym
            end else
            if sym=number then
            begin if num>amax then
                     begin error(30);  num:=0
                     end;
               gen(lit, 0,num); getsym
            end else
            if sym=lparen then
            begin getsym;
               expression([rparen]+fsys);
               if sym=rparen then getsym
               else error(22)
            end;
            test(fsys,[lparen],23)
         end
      end;{factor}
    begin{term} factor(fsys+[times,slash]);
       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}
     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}