word.pas

来自「编译原理实验 完整的」· PAS 代码 · 共 483 行

program PaxCompoiler(input,output);

  const
    IdLength=10;
    maxint=16383;
    illeng=81;
    tnmax=70;
    tsmax=200;
    timax=80;
    tbmax=10;
    tcmax=1023;
    tlmax=255;

  type
    symbol=({ 0}ident,intconst,charconst,strconst,programsy,
            { 5}constsy,typesy,varsy,procsy,funcsy,beginsy,ifsy,
            {12}whilesy,forsy,endsy,thensy,elsesy,ofsy,dosy,
            {19}tosy,downtosy,arraysy,recordsy,notop,times,divop,
            {26}modop,andop,plus,minus,orop,lsop,leop,gtop,
            {34}geop,neop,eqop,lparent,rparent,lbracket,rbracket,
            {41}comma,semicolon,period,colon,becomes,range,
            {47}eoline,eofile,other,call,empty,boolconst,
            {53}unaryminus);
    symset=set of symbol;
    cardinal=0..maxint;
    ILFileType=file of cardinal;
    pass=(pass1,pass2,pass3,pass4,pass5);
    CharPos=0..illeng;
    TextPos=record
              LineNumber:0..9999;
              CharNumber:CharPos
            end;
    alfa=packed array[1..IdLength] of char;
    alfa10=packed array[1..10] of char;
    alfa6=packed array[1..6] of char;
    OperandForm=(invalid,invinv,strstr,invint,intinv,intint,
                 invbool,boolinv,boolbool,invchar,charinv,charchar,
                 invarr,arrinv,arrarr,invrec,recinv,recrec);
    table=(nametab,stringtab,identtab,blocktab,codetab,labletab);
  var
    SyPos:TextPos;
    ErrCount:cardinal;
    NTab:array[0..tnmax]of alfa;
    STab:array[0..tsmax]of char;
    {ITab:array[0..timax]of identifier;
    BTab:array[0..tbmax]of BTabTerm;
    CTab:array[0..tcmax]of integer;
    LTab:array[0..tlmax]of cardinal;}
    NIndex:cardinal;
    IdIndex:cardinal;
    sy:symbol;
    sp:array[symbol] of alfa10;
    IValue:cardinal;
    BValue:cardinal;
    CValue:cardinal;
    SEntry:cardinal;
    SLength:cardinal;
    operandfm:OperandForm;
    OpFmSp:array[OperandForm]of alfa6;
    tn:cardinal;
    ts:cardinal;
    overflow:set of table;

procedure error(var DSP:text;SyPos:TextPos;n:cardinal;
                        var ErrCount:cardinal;p:pass);
begin
  ErrCount:=succ(ErrCount);
  with SyPos do
  begin
    if p<>pass1
    then writeln(    '   ERROR',n:3,'(',LineNumber:4,',',CharNumber:4,')');
         writeln(DSP,'   ERROR',n:3,'(',LineNumber:4,',',CharNumber:4,')');
  end
end;

procedure PutSymbol(var f:ILFileType;var DSP:text;sy:symbol;p:pass);
begin
  {write(f,SyPos.CharNumber,ord(sy));}
  with SyPos do
  write(DSP,LineNumber:4,CharNumber:3,ord(sy):4,'(',sp[sy],')');
  if sy in[ident..strconst,boolconst]
  then case sy of
ident     :   begin write(f,IdIndex); write(DSP,IdIndex:4)  end;
intconst  :   begin write(f,IValue);  write(DSP,IValue :4)  end;
charconst :   begin write(f,CValue);  write(DSP,CValue :4)  end;
boolconst :   begin write(f,BValue);  write(DSP,BValue :4)  end;
strconst  :   begin write(f,SEntry,SLength);
                          write(DSP,SEntry:4,SLength:4)     end;
       end;{case}
  if(p=pass3)and(sy in [notop..eqop,becomes,unaryminus])
  then begin
         {write(f   ,Ord(operandfm));}
         write(DSP ,Ord(operandfm):4,'(',OpFmSp[operandfm],')')
       end;
  writeln(DSP);
end;{PutSymbol}

procedure TabOverflow(tab:table;pos:TextPos);
begin
  if not(tab in overflow)
  then begin
         write('* * * * ');
         case tab of
nametab  :write('Name table NTab');
stringtab:write('String table STab');
identtab :write('Identifier table ITab');
blocktab :write('Block table BTab');
codetab  :write('Code table');
labletab :write('Lable table')
         end;
         writeln('overflow in line',pos.LineNumber:1);
         overflow:=overflow+[tab]
       end
end;

{{{******************************************************}
{{{*****************LexicalAnalysis**********************}
{{{******************************************************}

procedure LexicalAnalysis(var PAS:text;var IL1:ILFileType;var DSP:text);

  const
    IdLengPlus1=11;
    rwnum=25;
  type
    charset=set of char;
  var
    ch         :char;
    ChPos      :TextPos;
    LastInLine :CharPos;
    EndScan    :Boolean;
    OnString   :Boolean;
    digits     :charset;
    letters    :charset;
    CharTotal  :cardinal;
    SymTotal   :cardinal;
    line       :array[CharPos]of char;
    ResWords   :array[1..rwnum]of
                  record
                    sp:alfa;
                    sy:symbol
                  end;
    frw        :array[1..IdLengPlus1]of cardinal;

procedure ScanError(n:cardinal);
begin
  write('* * * *');
  with SyPos do
  if CharNumber>=1
  then writeln('':CharNumber-8,'Error',n:1,'^')
  else writeln('':CharNumber,'^','Error',n:1);
  error(DSP,SyPos,n,ErrCount,Pass1);
end{scanError};

procedure InitResWords{and array frw};
begin
  frw[1]:=1;
  frw[2]:=1;
  with ResWords[1] do begin sp:='IF        '; sy:=ifsy         end;
  with ResWords[2] do begin sp:='OF        '; sy:=ofsy         end;
  with ResWords[3] do begin sp:='DO        '; sy:=dosy         end;
  with ResWords[4] do begin sp:='TO        '; sy:=tosy         end;
  with ResWords[5] do begin sp:='OR        '; sy:=orop         end;
  frw[3]:=6;
  with ResWords[6] do begin sp:='VAR       '; sy:=varsy        end;
  with ResWords[7] do begin sp:='FOR       '; sy:=forsy        end;
  with ResWords[8] do begin sp:='END       '; sy:=endsy        end;
  with ResWords[9] do begin sp:='NOT       '; sy:=notop        end;
  with ResWords[10]do begin sp:='AND       '; sy:=andop        end;
  with ResWords[11]do begin sp:='DIV       '; sy:=divop        end;
  with ResWords[12]do begin sp:='MOD       '; sy:=modop        end;
  frw[4]:=13;
  with ResWords[13]do begin sp:='TYPE      '; sy:=typesy       end;
  with ResWords[14]do begin sp:='THEN      '; sy:=thensy       end;
  with ResWords[15]do begin sp:='ELSE      '; sy:=elsesy       end;
  frw[5]:=16;
  with ResWords[16]do begin sp:='CONST     '; sy:=constsy      end;
  with ResWords[17]do begin sp:='BEGIN     '; sy:=beginsy      end;
  with ResWords[18]do begin sp:='WHILE     '; sy:=whilesy      end;
  with ResWords[19]do begin sp:='ARRAY     '; sy:=arraysy      end;
  frw[6]:=20;
  with ResWords[20]do begin sp:='DOWNTO    '; sy:=downtosy     end;
  with ResWords[21]do begin sp:='RECORD    '; sy:=recordsy     end;
  frw[7]:=22;
  with ResWords[22]do begin sp:='PROGRAM   '; sy:=programsy    end;
  frw[8]:=23;
  with ResWords[23]do begin sp:='FUNCTION  '; sy:=funcsy       end;
  frw[9]:=24;
  with ResWords[24]do begin sp:='PROCEDURE '; sy:=procsy       end;
  frw[10]:=25;
  frw[11]:=25
end{InitResWords};

procedure InitSets;
begin
  letters:=['A'..'Z'];  digits :=['0'..'9']
end{InitSets};

procedure InitNTab;
begin
  NTab[1] :='FALSE     ';NTab[2]   :='TRUE      ';NTab[3]   :='MAXINT    ';
  NTab[4] :='INTEGER   ';NTab[5]   :='CHAR      ';NTab[6]   :='BOOLEAN   ';
  NTab[7] :='ABS       ';NTab[8]   :='SQR       ';NTab[9]   :='ORD       ';
  NTab[10]:='CHR       ';NTab[11]  :='SUCC      ';NTab[12]  :='PRED      ';
  NTab[13]:='ODD       ';NTab[14]  :='READ      ';NTab[15]  :='READLN    ';
  NTab[16]:='WRITE     ';NTab[17]  :='WRITELN   ';
end{InitNTab};

procedure PutSy(sy:symbol);
begin
  SymTotal:=succ(SymTotal);
  if sy = ident then IdIndex :=NIndex;
  PutSymbol(IL1,DSP,sy,pass1)
end{PutSy};

procedure GetCh;
  procedure ReadNextLine;
    var i:cardinal;
  begin
    i:=1;
    while not eoln(PAS) and (i<illeng) do
    begin read(PAS,line[i]);  i:=succ(i)end;
    readln(PAS);
    line[i]:=' ';
    LastInLine:=i
  end{ReadNextLine};

  procedure ListThisLine;
    var i:cardinal;
  begin{ListThisLine}
    write(    ChPos.LineNumber:4,'');
    write(DSP,ChPos.LineNumber:4,'');
    for i:=1 to LastInLine do
    begin write(line[i]);   write(DSP,line[i])  end;
    writeln;  writeln(DSP)
  end{ListThisLine};

begin{GetCh}
  with ChPos do
  begin
    if CharNumber =LastInLine
    then begin
            PutSy(eoline);
            LineNumber:=succ(LineNumber);
            ReadNextLine;
            ListThisLine;
            CharNumber:=1;
            CharTotal :=CharTotal+LastInLine;
         end
    else CharNumber:=succ(CharNumber);
    ch:=line[CharNumber];
    if not OnString and (ch in['a'..'z'])
    then ch:=chr(ord('A')+ord(ch)-ord('a'));
    if eof(PAS) and (CharNumber=lastInLine) then EndScan :=true;
  end{with}
end{GetCh};



procedure identifier{or reserued word};
  var i,j,k :cardinal; spelling :alfa;
  procedure EnterNTab(name : alfa);
    function PosInNTab(name: alfa):cardinal;
      var i:cardinal;
    begin
      NTab[0]:=name;
      i:=tn;
      while name<>NTab[i] do i:=pred(i);
      PosInNTab:=i
    end{PosInNTab};
  begin{EnterNTab}
    NIndex :=PosInNTab(name);
    if NIndex =0
    then if tn = tnmax
         then TabOverflow(nametab,SyPos)
         else begin
                tn:=succ(tn); NTab[tn]:=name; NIndex:=tn
              end
  end{EnterNTab};

begin{identifier}
  spelling:='          ';
  k:=0;
  repeat
    if k<IdLength then begin k:=succ(k); spelling[k]:=ch end;
    GetCh
  until not (ch in (letters+digits));
  i:=frw[k]; j:=frw[k+1]-1;
  while(spelling<>ResWords[i].sp) and(i<=j) do i:=succ(i);
  if i<=j
  then sy:=ResWords[i].sy
  else begin sy:=ident;  EnterNTab(spelling) end;
  PutSy(sy)
end{identifier};

procedure number;
  var digit:integer;
begin{number}
  IValue:=0;
  repeat
    digit:=ord(ch)-ord('0');
    if IValue<=(MaxInt-digit) div 10
    then begin
           IValue:=IValue * 10 + digit;  GetCh
         end
    else begin
           ScanError(2);
           IValue:=maxint;
           repeat GetCh until not (ch in digits)
         end
    until not (ch in digits);
    if ch in letters then ScanError(3);
    PutSy(intconst);
  end{number};

  procedure string0;
    var ch1,ch2 :char;  MissRight:Boolean;
    procedure EnterSTab;
      var tsPlusSLength:cardinal;
    begin{EnterSTab};
      tsPlusSLength:=ts+SLength;
      if tsPlusSLength>tsmax
      then TabOverflow(stringtab,SyPos)
      else
        STab[tsPlusSLength]:=ch1
    end{EnterSTab};
  begin{string}
    OnString:=true;
    SLength:=0;
    GetCh;  ch2:=ch;
    repeat
      ch1:=ch2;
      MissRight:=ChPos.CharNumber=LastInLine;
      if not MissRight
      then begin
             GetCh; ch2:=ch;
             if(ch1<>'"')or(ch1='"')and(ch2='"')
             then begin
                    SLength:=succ(SLength);
                    EnterSTab;
                    if(ch1='"')and(ch2='"')
                  then begin ch1:=' ';  GetCh; ch2:=ch end
                  end
           end
    until (ch1='"')or MissRight;
    if MissRight
    then begin  ScanError(4);  GetCh  end
    else if SLength<=1
         then begin
                if SLength=0 then ScanError(4);
                CValue:=ord(STab[succ(ts)]);
                PutSy(charconst)
              end
         else begin
                sEntry:=succ(ts);
                PutSy(strconst);
                if not (stringtab in overflow)then ts:=ts+SLength
              end;
    OnString:=false
  end{string};


procedure comment1;
  var ch1,ch2  :char;  MissRight:Boolean;
begin{comment1}
  GetCh;  ch2:=ch;
  repeat
    ch1:=ch2;
    MissRight:=ChPos.CharNumber=LastInLine;
    if MissRight
    then ScanError(5)
    else begin  GetCh;  ch2:=ch  end;
  until(ch1='*') and (ch2=')') or MissRight;
  if not(eof(PAS)and MissRight) then Getch
end{comment1};

procedure comment2;
  var MissRight: Boolean;
begin{comment2}
  repeat
    GetCh;
    MissRight:=ChPos.CharNumber=LastInLine;
    if MissRight then ScanError(5);
  until(ch='}')or MissRight;
  if not(eof(PAS)and MissRight)then GetCh
end{comment2};

procedure scan;
  var LegalFirstChar:set of char;
begin
  LegalFirstChar:=letters+digits+[' ','"','+','-','*',
       '<','=','>','{','(',')','[',']','.',':',',',';'];
  while not EndScan do
  begin
    SyPos:=ChPos;
    if ch in LegalFirstChar
    then case ch of
  ' '   :GetCh;
  'A','B','C','D','E','F','G','H','I','J','K','L','M',
  'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'
        :identifier{or reserved word};
  '1','2','3','4','5','6','7','8','9'
        :number;
  '"'   :string0;
             {2-xharacter special symbols}
  '<'   :begin
           GetCh;
           if ch='='
           then begin PutSy(leop); GetCh end
           else if ch='>'
                then begin PutSy(neop); GetCh end
                else PutSy(lsop)
         end;
  '>'   :begin
           GetCh;
           if ch='='
           then begin PutSy(geop); GetCh end
           else PutSy(gtop)
         end;
  ':'   :begin
           GetCh;
           if ch='='
           then begin PutSy(becomes); GetCh end
           else PutSy(colon)
         end;
  '.'   :begin
           GetCh;
           if ch='='
           then begin PutSy(range); GetCh end
           else PutSy(period)
         end;
  '('   :begin
           GetCh;
           if ch='*' then comment1 else PutSy(lparent)
         end;
  '{'   :comment2;
  '+'   :begin PutSy(plus);         GetCh end;
  '-'   :begin PutSy(minus);        GetCh end;
  '*'   :begin PutSy(times);        GetCh end;
  '='   :begin PutSy(eqop);         GetCh end;
  ')'   :begin PutSy(rparent);      GetCh end;
  '['   :begin PutSy(lbracket);     GetCh end;
  ']'   :begin PutSy(rbracket);     GetCh end;
  ','   :begin PutSy(comma);        GetCh end;
  ';'   :begin PutSy(semicolon);    GetCh end;
         end{case}
      else begin PutSy(other);  ScanError(1);  GetCh end
    end{while}
  end{scan};
begin{LexicalAnalysis}
  InitResWords;
  InitSets;
  InitNTab;
  ts  :=0;
  tn  :=17;
  Chartotal:=0;   SymTotal:=0;
  EndScan:=false; OnString:=false;
  with ChPos do begin LineNumber:=0;  CharNumber :=0 end;
  with SyPos do begin LineNumber:=0;  CharNumber :=0 end;
  LastInLine:=0;
  GetCh;
  scan;
   PutSy(eofile);
  writeln(DSP);
  writeln(DSP,'    line total     =',ChPos.LineNumber : 1);
  writeln(DSP,'    character total=',CharTotal: 1);
  writeln(DSP,'    symbol total   =',SymTotal : 1);
end{LexicalAnalysis};



begin{PaxCompoiler}
  {Initialization;
  OpenFiles;}
  writeln;writeln;
  writeln('PASCAL-D Multi-Pass Teaching Compiler');
  writeln('       Developed By ZhouWei          ');
  writeln('          Jan 1, 2003                ');
  {reset(PAS);rewrite(IL1);rewrite(DSP);
  PassHead(pass1); LexicalAnalysis(PAS,IL1,DSP);PassFinal;
  close(PAS);
  WriteTabToDsp(DSP,pass1);WriteSTabToSFile;}
end.