yufa.pas

编译原理实验 完整的

{{{******************************************************}
{{{*****************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);
             TypeDenoter(typebegsys,follows+[semicolon]);
             CheckFollow(follows,ord(semicolon))
           end
    end;
  begin
  if sy in firsts
  then begin
         ChePutGet(typesy);
         repeat
           TypeDefinition([ident],follows+[semicolon]);
           ChePutGet(semicolon)
         until sy<>ident;
         CheckFollow(follows,84)
       end
  end;

  procedure VarDefPart(firsts,follows:symset);
    procedure VarDefinition(firsts,follows:symset);
    begin
      CheckFirst(firsts,follows,ord(ident));
      if sy in firsts
      then begin
             NameList([ident],follows+[colon]);
             ChePutGet(colon);
             TypeDenoter(typebegsys,follows+[semicolon]);
             CheckFollow(follows,ord(semicolon))
           end
    end;
  begin
  if sy in firsts
  then begin
         ChePutGet(typesy);
         repeat
           VarDefinition([ident],follows+[semicolon]);
           ChePutGet(semicolon)
         until sy<>ident;
         CheckFollow(follows,85)
       end
  end{VarDefPart};

  procedure ProcFuncDefPart(firats,follows:symset);
    procedure ProcDefinition(firsts,follows:symset);
    begin
      CheckFirst(firsts,follows,ord(procsy));
      if sy in firsts
      then begin
             ChePutGet(procsy);
             ChePutGet(ident);
             block([lparent,semicolon],follows,procsy);
             CheckFollow(follows,ord(semicolon))
           end
    end;
    procedure FuncDefinition(firsts,follows:symset);
    begin
      CheckFirst(firsts,follows,ord(funcsy));
      if sy in firsts
      then begin
             ChePutGet(funcsy);
             ChePutGet(ident);
             block([lparent,colon],follows,funcsy);
             CheckFollow(follows,ord(semicolon))
           end
    end;