main.pas

编译原理实验 完整的

    begin FileFullName[i]:=FileName[i];i:=succ(i) end;
    FileFullName[i]:='.';
    for j:=1 to 3 do FileFullName[i+j]:=ExtName[j];
  end;
begin
  ReadFileName(SourceName);
  LinkExtName(FileFullName,SourceName,'PAS');
  assign(PAS,FileFullName);
  LinkExtName(FileFullName,SourceName,'IL1');
  assign(IL1,FileFullName);
  LinkExtName(FileFullName,SourceName,'IL2');
  assign(IL2,FileFullName);
  LinkExtName(FileFullName,SourceName,'IL3');
  assign(IL3,FileFullName);
  LinkExtName(FileFullName,SourceName,'PTC');
  assign(PTCode,FileFullName);
  LinkExtName(FileFullName,SourceName,'ASN');
  assign(ASN,FileFullName);
  LinkExtName(FileFullName,SourceName,'STR');
  assign(SFile,FileFullName);
  LinkExtName(FileFullName,SourceName,'DSP');
  assign(DSP,FileFullName);
end;

procedure WriteSTabToSFile;
  var tt:cardinal;
begin
  rewrite(SFile);
  for tt:=1 to ts do write(SFile,STab[tt]);
  close(SFile);
end;

procedure WriteTabToDsp(var DSP:text; p:pass);
  var t0,tt:cardinal;tp:StPtr;
       i,num:CodeLable;Cd:integer;OpCd:OperatingCode;
  function InsArgNum(OpCode:OperatingCode):cardinal;
  begin
    if OpCode in ZeroArgument
    then InsArgNum:=0
    else if OpCode in OneArgument
             then InsArgNum:=1
             else if OpCode in TwoArgument
                     then InsArgNum:=2
                     else InsArgNum:=3
  end;
begin
  if p=pass1
  then begin
         if p=pass1
         then begin
                writeln(DSP);
                writeln(DSP,'NTab','':5,'tn=',tn:1);
                for tt:=1 to tn do
                begin
                  if tt mod 5=1 then write(DSP,tt:7);
                  write(DSP,NTab[tt]:IdLength+2);
                  if tt mod 5=0 then writeln(DSP)
                end;
                writeln(DSP);writeln(DSP);
                writeln(DSP,'STab','':5,'ts=',ts:1);
                for tt:=1 to ts do
                begin
                  write(DSP,STab[tt]);if tt mod 80=0 then writeln(DSP)
                end;
                writeln(DSP)
              end;
         if p=pass3
         then begin
                writeln(DSP);
                writeln(DSP,'         Block Table');
                writeln(DSP,'         * * * * * * * * * * *');
                writeln(DSP);
                writeln(DSP,'order LastPar LasrId pSize VSize');
                for tt:=0 to tb do
                     with BTab[tt] do
                     writeln(DSP,tt:4,LastPar:8,LastId:8,ParSize:8,VarSize:8);
                writeln(DSP);
                writeln(DSP);
                writeln(DSP,'         Structural Table');
                writeln(DSP,'         * * * * * * * * * * *');
                writeln(DSP);
                writeln(DSP,'order size form');
                tp:=invptr;
                repeat
                  with tp^do
                  begin
                    write(DSP,order:4,size:7,StFormSp[form]:9);
                    case form of
  inv,ints,chars,bools
               :{no output};
  subranges:write(DSP,RangeType^.order:7,'(RangeTp)',
                       min:7,'(min)',max:7,'(max)');
  arrays:write(DSP,IndexType^.order:7,'(IndexTp)',
                       ElementType^.order:7,'(ElemtTp)');
  records:write(DSP,LastField:7,'(LastFld)')
            end{of case}
          end{of with};
          writeln(DSP);
          tp:=tp^.next
        until tp=nil;
      end;
  if p in [pass3,pass4]
  then begin
         writeln(DSP);
         writeln(DSP,'         Identifier Table');
         writeln(DSP,'         * * * * * * * * * * *');
         writeln(DSP);
         writeln(DSP,'order name type prevous class');
         if p=pass4 then write(DSP,'order name typ previous class');
         writeln(DSP);
         if p=pass3 then t0:=1 else t0:=18;
         for tt:=t0 to ti do
         with ITab[tt] do
         if(p=pass3)or((p=pass4)and(class in[procss,funcss]))then
         begin
           write(DSP,tt:4,name:4,'(',NTab[name],')',typ^.order:4,'(',
                     StFormSp[typ^.form],')',previous:4,IdClassSp[class]:9);
           case class of
             constss:write(DSP,val:7);
             typess:write(DSP);
             varss:write(DSP,address.StaticLevel:7,address.RelativeAddress:7,
                                  KindSp[kind]:7,IsControlvar:7);
             fieldss:write(DSP,IsStandp:7);
             procss:begin
                      write(DSP,IsStandp:7);
                      case IsStandf of
                        true:write(DSP,StandpSp[standp]:7);
                        false:write(DSP,plev:7,pEntry:7,pindex:7)
                      end
                    end;
             funcss:begin
                      write(DSP,IsStandf:7);
                      case IsStandf of
                        true:write(DSP,StandpSp[standp]:7);
                        false:write(DSP,plev:7,pEntry:7,pindex:7)
                      end
                    end;
           end{case};
           writeln(DSP)
         end{with};
         writeln(DSP)
       end;
  if p=pass4
  then begin
         writeln(DSP);
         writeln(DSP,'         Code Table');
         writeln(DSP,'         * * * * * * * * * * *');
         writeln(DSP);
         reset(PTCode);
         i:=0;
         while not eof(PTCode)do
         begin
           read(PTCode,Cd);OpCd:=OperatCd[Cd];
           write(DSP,i:5, OpCdSp[OpCd]:8);  i:=succ(i);
           for num:=1 to InsArgNum(OpCd) do
           if not eof(PTCode)
           then begin
                  read(PTCode,Cd);  write(DSP,Cd:6);   i:=succ(i)
                end;
           writeln(DSP);
         end;
         writeln(DSP);
         writeln(DSP);
         writeln(DSP,'         Lable Table');
         writeln(DSP,'         * * * * * * * * * * *');
         writeln(DSP);
         for tt:=1 to tl do
         begin
           write(DSP,LTab[tt]:5);  if tt mod 10=0 then writeln(DSP)
         end;
         writeln(DSP);
       end{Write Code Table and Lable Table}
  end;
end{WriteTabToDsp};


procedure PassHead(p:pass);
begin
    writeln;writeln(DSP);
    case p of
      pass1:begin
              writeln(    '* * * * * pass 1:Lexical Analysis * * * * *');
              writeln(DSP,'* * * * * pass 1:Lexical Analysis * * * * *')
            end;
      pass2:begin
              writeln(    '* * * * * pass 2:Syntax Analysis * * * * *');
              writeln(DSP,'* * * * * pass 2:Syntax Analysis * * * * *')
            end;
      pass3:begin
              writeln(    '* * * * * pass 3:Semantic Analysis * * * * *');
              writeln(DSP,'* * * * * pass 3:Semantic Analysis * * * * *')
            end;
      pass4:begin
              writeln(    '* * * * * pass 4:Code Generation * * * * *');
              writeln(    '          (Ideal Computer)');
              writeln(DSP,'* * * * * pass 4:Code Generation * * * * *');
              writeln(DSP,'          (Ideal Computer)')
            end;
      pass5:begin
              writeln(    '* * * * * pass 5:Assembly Code Generation * * * * *');
              writeln(    '                (Intel 8088)');
              writeln(DSP,'* * * * * pass 5:Assembly Code Generation * * * * *');
              writeln(DSP,'                (Intel 8088)')
            end;
    end{of case};
    writeln;writeln(DSP)
end{PassHead};


procedure PassFinal;
  var InOrBlank:packed array[1..2]of char;
begin
  if(ErrCount=0)and(overflow=[])
  then InOrBlank:='  '
  else InOrBlank:='IN';
  writeln(    InOrBlank:16,'CORRECT');
  writeln(DSP,InOrBlank:10,'CORRECT');
end{PassFinal};



{{{*******************************************************************}
{{{                        SECOND GROUP                               }
{{{*******************************************************************}
procedure GetSymbol(var f:ILFileType;var sy:symbol;p:pass);
  var c:cardinal;
begin
  read(f,SyPos.CharNumber,c);sy:=sym[c];
  if sy in [ident..strconst,boolconst]
  then case sy of
         ident     :read(f,IdIndex);
         intconst  :read(f,IValue);
         charconst :read(f,CValue);
         boolconst :read(f,BValue);
         strconst  :read(f,SEntry,SLength)
       end;{case}
  if(p=pass4)and(sy in [notop..eqop,becomes,unaryminus])
  then begin read(f,c); operandfm:=OpFm[c]  end
end{GetSymbol};

procedure PutSymbol(var f:ILFileType;var DSP:text;sy:symbol;p:pass);
  var ordd:cardinal;ordfm:cardinal;
begin
  ordd:=ord(sy);
  write(f,SyPos.CharNumber,ordd);
  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
         ordfm:=Ord(operandfm);
         write(f   ,ordfm);
         write(DSP ,Ord(operandfm):4,'(',OpFmSp[operandfm],')')
       end;
  writeln(DSP);
end;{PutSymbol}

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 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{TabOverflow};

procedure LexicalAnalysis(var PAS:text;var IL1:ILFileType;var DSP:text);
begin
end;
procedure SyntaxAnalysis(var IL1,IL2:ILFileType;var DSP:text);
begin
end;
procedure SemanticAnalysis(var IL2,IL3:ILFileType;var DSP:text);
begin
end;
procedure CodeGeneration(var IL3:ILFileType; var PTCode:PTCFileType;
                             var DSP:text);
begin
end;
procedure AsmCodeGeneration(var PTCode:PTCFileType;var ASN:text);
begin
end;


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