main.pas

编译原理实验 完整的

    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;



{{{******************************************************}
{{{*****************SyntaxAnalysis***********************}
{{{******************************************************}

procedure SyntaxAnalysis(var IL1,IL2:ILFileType;var DSP:text);
  procedure SyntaxError(n:cardinal);
  begin{SyntaxError}
    error(DSP,SyPos,n,ErrCount,pass2);
  end{SyntaxError};

  procedure GetSy;
  begin{GetSy};
    GetSymbol(IL1,sy,pass2);
    while sy=eoline do
    begin
      PutSymbol(IL2,DSP,sy,pass2);
      SyPos.LineNumber:=SyPos.LineNumber+1;
      GetSymbol(IL1,    sy,pass2)
    end
  end{GetSy};

  procedure PutSy(sy:symbol);
  begin
    PutSymbol(IL2,DSP,sy,pass2);
  end;

  procedure PutGet(sy:symbol);
  begin
    PutSy(sy);  GetSy
  end;

  procedure CheGet(CheckedSy:symbol);
  begin
    if sy=CheckedSy
    then GetSy
    else SyntaxError(ord(CheckedSy))
  end;

  procedure ChePut(CheckedSy:symbol);
  begin
    if sy=CheckedSy
    then PutSy(sy)
    else SyntaxError(ord(CheckedSy))
  end;

  procedure ChePutGet(CheckedSy:symbol);
  begin
    if sy=checkedSy
    then begin PutSy(sy);  GetSy end
    else SyntaxError(ord(CheckedSy))
  end;

  procedure SkipTo(RelevantSy:symset);
  begin
    while not(sy in RelevantSy) do GetSy
  end;

  procedure CheckFirst(var firsts,follows : symset; n : cardinal);
  begin
    if not(sy in firsts)
    then begin SyntaxError(n);  SkipTo(firsts+follows) end;
  end;

  procedure CheckFollow(var follows:symset;n:cardinal);
  begin
    if not (sy in follows) then begin SyntaxError(n);  SkipTo(follows) end
  end;

  procedure block(firsts,follows:symset;BlockClass:symbol);
    var IdIndex1:cardinal;  Sy1Pos:TextPos;
    procedure save;
    begin{save}
      IdIndex1:=IdIndex;  Sy1Pos:=SyPos
    end{save};

    procedure PutSave;
      procedure swap;
        var i:cardinal;  p:TextPos;
      begin
        i:=IdIndex;  IdIndex:=IdIndex1;  IdIndex1:=i;
        p:=SyPos;    SyPos  :=Sy1Pos;    Sy1Pos:=p
      end;
    begin
      swap;  PutSy(ident);  swap
    end;

    procedure NameList(firsts,follows:symset);
    begin
      CheckFirst(firsts,follows,ord(ident));
      if sy in firsts
      then begin
             ChePutGet(ident);
             while sy=comma do begin GetSy;  ChePutGet(ident) end;
             CheckFollow(follows,80)
           end
    end;

    procedure FormalParamList(firsts,follows:symset);
      procedure FormalParamDef(firsts,follows:symset);
      begin
        CheckFirst(firsts,follows,67);
        if sy in firsts
        then begin
               if sy=varsy then PutGet(varsy);
               NameList([ident],follows+[colon]);
               ChePutGet(colon);
               ChePutGet(ident);
               CheckFollow(follows,86)
             end
     end;
   begin
     CheckFirst(firsts,follows,ord(lparent));
     if sy in firsts
     then begin
            FormalParamDef([varsy,ident],follows+[semicolon,rparent]);
            while sy=semicolon do
            begin
              PutGet(semicolon);
              FormalParamDef([varsy,ident],follows+[semicolon,rparent])
            end;
            CheckFollow(follows,ord(rparent))
          end
   end;

   procedure constant(firsts,follows:symset);
   begin
     CheckFirst(firsts,follows,60);
     if sy in firsts
     then begin
            if sy in signs
            then begin
                   PutGet(sy);
                   if sy in [intconst,ident]
                   then PutGet(sy)
                   else SyntaxError(69)
                 end
            else PutGet(sy);
            CheckFollow(follows,81)
          end
   end;

   procedure TypeDenoter(firsts,follows:symset);
     procedure NewArrayType;
     begin
       PutGet(arraysy);
       CheGet(lbracket);
       TypeDenoter(typebegsys,follows+[comma,rbracket]);
       while sy=comma do
       begin
         PutGet(arraysy);
         TypeDenoter(typebegsys,follows+[comma,rbracket])
       end;
       CheGet(rbracket);
       ChePutGet(ofsy);
       TypeDenoter(typebegsys,follows)
     end;
     procedure NewRecordType;
     begin
       PutGet(recordsy);
       while sy=ident do
       begin
         NameList([ident],follows+[colon]);
         ChePutGet(colon);
         TypeDenoter(typebegsys,follows+[semicolon,endsy]);
         if sy=semicolon
         then GetSy
         else if sy<>endsy then SyntaxError(ord(semicolon));
       end;
       ChePutGet(endsy)
     end;
   begin{TypeDenoter}
     CheckFirst(firsts,follows,61);
     if sy in firsts
     then begin
            case sy of
   ident    :{type Name or subrange type}
             begin
               save;
               GetSy;
               if sy=range
               then begin
                      PutGet(sy);  PutSave;
                      constant(constbegsys,follows)
                    end
               else PutSave
             end;
   intconst,charconst,plus,minus
            :{subrange type}
             begin
               PutSy(range);
               if sy in signs
               then begin
                      PutGet(sy);
                      if sy in [intconst,ident]
                      then PutGet(sy)
                      else SyntaxError(69)
                    end
               else PutGet(range);
               constant(constbegsys,follows)
             end;
   arraysy  :{New array Type}
             NewArrayType;
   recordsy :
             NewRecordType
            end{case};
            CheckFollow(follows,82)
          end{if}
   end{TypeDenoter};
  Procedure ConstDefPart(firsts,follows:symset);
    procedure ConstDefinition(firsts,follows:symset);
    begin
      CheckFirst(firsts,follows,ord(ident));
      if sy in firsts
      then begin
             ChePutget(ident);
             CheGet(eqop);
             constant(constbegsys,follows+[semicolon]);
             CheckFollow(follows,ord(semicolon))
           end
    end;
  begin
    if sy in firsts
    then begin
           ChePutGet(constsy);
           repeat
             ConstDefinition([ident],follows+[semicolon]);
             ChePutGet(semicolon)
           until sy<>ident;
           CheckFollow(follows,83)
         end
  end;

  procedure TypeDefPart(firsts,follows:symset);
    procedure TypeDefinition(firsts,follows:symset);
    begin
      CheckFirst(firsts,follows,ord(ident));
      if sy in firsts
      then begin
             ChePutGet(ident);
             CheGet(eqop);