Ignore:
Timestamp:
Oct 19, 2010, 11:22:55 AM (14 years ago)
Author:
george
Message:
  • Modified: Pascal parser code moved to separate unit.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/Transpascal/Compiler/Analyze/UParser.pas

    r69 r70  
    2525  private
    2626    FFileName: string;
    27     ProgramCode: TProgram;
    2827    FOnErrorMessage: TOnErrorMessage;
    2928    FNextToken: string;
    … …  
    3231    PreviousChar: char;
    3332    CurrentChar: char;
    34     procedure ErrorMessage(const Text: string; const Arguments: array of const);
    3533  public
     34    ProgramCode: TProgram;
    3635    CodeStreamPosition: integer;
    3736    CodePosition: TPoint;
     37    LastTokenPosition: TPoint;
    3838    SourceCodeText: TStringList;
    3939    function IsAlphanumeric(Character: char): boolean;
    … …  
    4949    function IsOperator(Text: string): boolean;
    5050    procedure Log(Text: string);
     51    procedure ErrorMessage(const Text: string; const Arguments: array of const);
    5152    property OnErrorMessage: TOnErrorMessage read FOnErrorMessage write FOnErrorMessage;
    5253    procedure Init;
    5354    property FileName: string read FFileName write FFileName;
    5455  end;
    55 
    56   TGetSourceEvent = function (Name: string; Source: TStringList): Boolean of object;
    57 
    58   { TPascalParser }
    59 
    60   TPascalParser = class(TBaseParser)
    61   private
    62     FOnGetSource: TGetSourceEvent;
    63   public
    64     function ParseFile(Name: string): Boolean;
    65     procedure ParseWhileDo(SourceCode: TWhileDo);
    66     procedure ParseExpression(SourceCode: TExpression);
    67     procedure ParseUses(SourceCode: TUsedModuleList; AExported: Boolean);
    68     function ParseModule(ProgramCode: TProgram): TModule;
    69     procedure ParseUnit(SourceCode: TModuleUnit);
    70     procedure ParseUnitInterface(SourceCode: TModuleUnit);
    71     procedure ParseUnitImplementation(SourceCode: TModuleUnit);
    72     procedure ParseProgram(SourceCode: TModuleProgram);
    73     procedure ParseCommonBlock(SourceCode: TCommonBlock; EndSymbol: char = ';');
    74     procedure ParseCommonBlockInterface(SourceCode: TCommonBlock);
    75     function ParseCommand(SourceCode: TCommonBlock): TCommand;
    76     procedure ParseBeginEnd(SourceCode: TBeginEnd);
    77     procedure ParseFunctionList(SourceCode: TFunctionList; Exported: Boolean = False);
    78     procedure ParseIfThenElse(SourceCode: TIfThenElse);
    79     procedure ParseForToDo(SourceCode: TForToDo);
    80     procedure ParseVariableList(SourceCode: TVariableList; Exported: Boolean = False);
    81     procedure ParseVariable(SourceCode: TVariable; Exported: Boolean = False);
    82     procedure ParseConstantList(SourceCode: TConstantList; Exported: Boolean = False);
    83     procedure ParseTypeList(SourceCode: TTypeList; Exported: Boolean = False);
    84     function ParseType(TypeList: TTypeList; ExpectName: Boolean = True; AssignSymbol: string = '='): TType;
    85     function ParseTypeEnumeration(TypeList: TTypeList; Name: string): TType;
    86     function ParseTypeRecord(TypeList: TTypeList; Name: string): TType;
    87     property OnGetSource: TGetSourceEvent read FOnGetSource
    88       write FOnGetSource;
    89     constructor Create;
    90     destructor Destroy; override;
    91   end;
    92 
    93 
    94 implementation
    9556
    9657resourcestring
    … …  
    10667  SUnitNotFound = 'Unit "%s" not found.';
    10768
     69implementation
     70
    10871{ TBaseParser }
    10972
    … …  
    11174begin
    11275  if Assigned(FOnErrorMessage) then
    113     FOnErrorMessage(Format(Text, Arguments), CodePosition, FileName);
     76    FOnErrorMessage(Format(Text, Arguments), LastTokenPosition, FileName);
    11477end;
    11578
    … …  
    222185  DoubleSpecChar: array[0..6] of string = (':=', '..', '<=', '>=', '<>', '+=', '-=');
    223186begin
     187  LastTokenPosition := CodePosition;
    224188  FNextToken := '';
    225189  FNextTokenType := ttNone;
    … …  
    354318end;
    355319
    356 { TPascalParser }
    357 
    358 function TPascalParser.ParseFile(Name: string): Boolean;
    359 var
    360   Parser: TPascalParser;
    361   NewModule: TModule;
    362 begin
    363   try
    364     Parser := TPascalParser.Create;
    365     Parser.SourceCodeText := TStringList.Create;
    366     Parser.ProgramCode := ProgramCode;
    367     Parser.OnGetSource := OnGetSource;
    368     if Assigned(FOnGetSource) then begin
    369       if FOnGetSource(Name, Parser.SourceCodeText) then begin
    370         Parser.Init;
    371         Parser.FileName := Name;
    372         Parser.OnErrorMessage := OnErrorMessage;
    373         NewModule := Parser.ParseModule(ProgramCode);
    374         ProgramCode.Modules.Add(NewModule);
    375         Result := True;
    376       end else Result := False;
    377     end else Result := False;
    378   finally
    379     Parser.SourceCodeText.Free;
    380     Parser.Free;
    381   end;
    382 end;
    383 
    384 procedure TPascalParser.ParseWhileDo(SourceCode: TWhileDo);
    385 begin
    386   with SourceCode do
    387   begin
    388     Expect('while');
    389     Condition.CommonBlock := CommonBlock;
    390     ParseExpression(Condition);
    391     Expect('do');
    392     Command := ParseCommand(CommonBlock);
    393   end;
    394 end;
    395 
    396 { TExpression }
    397 
    398 procedure TPascalParser.ParseExpression(SourceCode: TExpression);
    399 var
    400   Identifier: string;
    401   IdentifierType: TTokenType;
    402   NewVariable: TVariable;
    403   NewExpression: TExpression;
    404   Method: TFunction;
    405   Constant: TConstant;
    406   //  Brackets: Integer;
    407   Expressions: TExpressionList;
    408   I: integer;
    409   II: integer;
    410 begin
    411   Expressions := TExpressionList.Create;
    412   Expressions.Add(TExpression.Create);
    413   with SourceCode do begin
    414     while ((NextToken <> ';') and (NextToken <> ',') and (not IsKeyWord(NextToken))) and not
    415       (((NextToken = ')') or (NextToken = ']'))) and not (NextTokenType = ttEndOfFile) do begin
    416       IdentifierType := NextTokenType;
    417       Identifier := ReadCode;
    418       if Identifier = '(' then begin
    419         // Subexpression
    420         with TExpression(Expressions.Last) do begin
    421           SubItems[1] := TExpression.Create;
    422           ParseExpression(TExpression(SubItems[1]));
    423         end;
    424         with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do
    425         begin
    426           CommonBlock := SourceCode.CommonBlock;
    427           SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
    428         end;
    429         Expect(')');
    430       end else
    431       if IsOperator(Identifier) then begin
    432         // Operator
    433         TExpression(Expressions.Last).OperatorName := Identifier;
    434         TExpression(Expressions.Last).NodeType := ntOperator;
    435       end else
    436       if IsIdentificator(Identifier) then begin
    437         // Reference to identificator
    438         NewVariable := CommonBlock.Variables.Search(Identifier);
    439         if Assigned(NewVariable) then begin
    440           // Referenced variable
    441           with TExpression(Expressions.Last) do begin
    442             SubItems[1] := TExpression.Create;
    443             TExpression(SubItems[1]).NodeType := ntVariable;
    444             TExpression(SubItems[1]).Variable := NewVariable;
    445           end;
    446           with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do
    447           begin
    448             CommonBlock := SourceCode.CommonBlock;
    449             SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
    450           end;
    451         end else begin
    452           Method := CommonBlock.Functions.Search(Identifier);
    453           if Assigned(Method) then
    454           begin
    455             // Referenced method
    456             with TExpression(Expressions.Last) do begin
    457               SubItems[1] := TExpression.Create;
    458               if FNextToken = '(' then               // Method with parameters
    459                 with TExpression(SubItems[1]) do begin
    460                   Expect('(');
    461                   NewExpression := TExpression.Create;
    462                   NewExpression.CommonBlock := CommonBlock;
    463                   ParseExpression(NewExpression);
    464                   SubItems.Add(NewExpression);
    465                   while FNextToken = ',' do begin
    466                     Expect(',');
    467                     NewExpression := TExpression.Create;
    468                     NewExpression.CommonBlock := CommonBlock;
    469                     ParseExpression(NewExpression);
    470                     SubItems.Add(NewExpression);
    471                   end;
    472                   Expect(')');
    473                 end;
    474               TExpression(SubItems[1]).NodeType := ntFunction;
    475               TExpression(SubItems[1]).Method := Method;
    476             end;
    477             with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do
    478             begin
    479               CommonBlock := SourceCode.CommonBlock;
    480               SubItems[0] :=
    481                 TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
    482             end;
    483           end else begin
    484             Constant := CommonBlock.Constants.Search(Identifier);
    485             if Assigned(Constant) then begin
    486               // Referenced constant
    487               with TExpression(Expressions.Last) do begin
    488                 SubItems[1] := TExpression.Create;
    489                 TExpression(SubItems[1]).NodeType := ntConstant;
    490                 TExpression(SubItems[1]).Value := Constant.Value;
    491               end;
    492               with TExpression(Expressions.Items[Expressions.Add(
    493                   TExpression.Create)]) do begin
    494                 CommonBlock := SourceCode.CommonBlock;
    495                 SubItems[0] :=
    496                   TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
    497               end;
    498             end else begin
    499               ErrorMessage(SUnknownIdentifier, [Identifier]);
    500             end;
    501           end;
    502         end;
    503       end else begin
    504         // Constant value
    505         with TExpression(Expressions.Last) do
    506         begin
    507           SubItems[1] := TExpression.Create;
    508           TExpression(SubItems[1]).CommonBlock := SourceCode.CommonBlock;
    509           TExpression(SubItems[1]).NodeType := ntConstant;
    510 
    511           if IdentifierType = ttConstantString then begin
    512             TExpression(SubItems[1]).Value := Identifier;
    513             //SetLength(TExpression(SubItems[1]).Value, Length(Identifier));
    514             //for I := 1 to Length(Identifier) do
    515             //  TExpression(SubItems[1]).Value[I - 1] := Byte(Identifier[I]);
    516           end else begin
    517             TExpression(SubItems[1]).Value := StrToInt(Identifier);
    518           end;
    519         end;
    520         //ShowMessage(IntToStr(Expressions.Count));
    521         with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do
    522         begin
    523           CommonBlock := SourceCode.CommonBlock;
    524           SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
    525         end;
    526       end;
    527     end;
    528 
    529     // Build expression tree
    530     for II := 0 to High(Operators) do begin
    531       I := 1;
    532       while (I < Expressions.Count - 1) do begin
    533         if not TExpression(Expressions[I]).Associated and
    534           (TExpression(Expressions[I]).OperatorName = Operators[II]) then
    535         begin
    536           TExpression(Expressions[I]).Associated := True;
    537           TExpression(Expressions[I - 1]).SubItems[1] := Expressions[I];
    538           TExpression(Expressions[I + 1]).SubItems[0] := Expressions[I];
    539           //Expressions.Delete(I);
    540         end else Inc(I);
    541       end;
    542     end;
    543     if Assigned(TExpression(Expressions.First).SubItems[1]) then
    544       Assign(TExpression(TExpression(Expressions.First).SubItems[1]));
    545     TExpression(Expressions.First).SubItems[1] := nil;
    546     //ShowMessage(IntToStr(Expressions.Count));
    547     if Expressions.Count > 1 then
    548       TExpression(Expressions[1]).SubItems[0] := nil;
    549     Expressions.Free;
    550   end;
    551 end;
    552 
    553 function TPascalParser.ParseCommand(SourceCode: TCommonBlock): TCommand;
    554 var
    555   Identifier: string;
    556   Variable: TVariable;
    557   Method: TFunction;
    558   First: TOperation;
    559   Second: TOperation;
    560   StartIndex: integer;
    561   LoopVariable: TVariable;
    562   IdentName: string;
    563   FunctionName: string;
    564 begin
    565   begin
    566     if FNextToken = 'begin' then
    567     begin
    568       Result := TBeginEnd.Create;
    569       TBeginEnd(Result).CommonBlock := SourceCode;
    570       //ShowMessage(IntToStr(Integer(SourceCode))
    571       // + ' ' + IntToStr(Integer(Result)));
    572       ParseBeginEnd(TBeginEnd(Result));
    573     end
    574     else
    575     if FNextToken = 'if' then
    576     begin
    577       Result := TIfThenElse.Create;
    578       TIfThenElse(Result).CommonBlock := SourceCode;
    579       ParseIfThenElse(TIfThenElse(Result));
    580     end
    581     else
    582     if FNextToken = 'while' then
    583     begin
    584       Result := TWhileDo.Create;
    585       TWhileDo(Result).CommonBlock := SourceCode;
    586       ParseWhileDo(TWhileDo(Result));
    587     end
    588     else
    589     if FNextToken = 'for' then
    590     begin
    591       Result := TForToDo.Create;
    592       TForToDo(Result).CommonBlock := SourceCode;
    593       ParseForToDo(TForToDo(Result));
    594     end
    595     else
    596     if IsIdentificator(FNextToken) then
    597     begin
    598       if Assigned(SourceCode.Variables.Search(FNextToken)) then
    599       begin
    600         // Variable assignment
    601         Result := TAssignment.Create;
    602         TAssignment(Result).CommonBlock := SourceCode;
    603         IdentName := ReadCode;
    604         TAssignment(Result).Target := SourceCode.Variables.Search(IdentName);
    605         Expect(':=');
    606         TAssignment(Result).Source := TExpression.Create;
    607         TAssignment(Result).Source.CommonBlock := SourceCode;
    608         ParseExpression(TAssignment(Result).Source);
    609       end
    610       else
    611       if Assigned(SourceCode.Functions.Search(FNextToken)) then
    612       begin
    613         // Function call
    614         FunctionName := ReadCode;
    615         Result := TFunctionCall.Create;
    616         TFunctionCall(Result).CommonBlock := SourceCode;
    617         TFunctionCall(Result).FunctionRef := SourceCode.Functions.Search(FunctionName);
    618         if FNextToken = '(' then
    619         begin
    620           Expect('(');
    621           with TFunctionCall(Result) do
    622           begin
    623             ParameterExpression.Add(TExpression.Create);
    624             TExpression(ParameterExpression.Last).CommonBlock := SourceCode;
    625             ParseExpression(TExpression(ParameterExpression.Last));
    626           end;
    627           Expect(')');
    628         end;
    629       end
    630       else
    631       begin
    632         Result := nil;
    633         ErrorMessage(SUnknownIdentifier, [ReadCode]);
    634       end;
    635     end
    636     else
    637     if FNextToken = ';' then
    638     else
    639     begin
    640       Result := nil;
    641       ErrorMessage(SIllegalExpression, [ReadCode]);
    642     end;
    643   end;
    644 end;
    645 
    646 { TParserModule }
    647 
    648 function TPascalParser.ParseModule(ProgramCode: TProgram): TModule;
    649 begin
    650   Self.ProgramCode := ProgramCode;
    651   if FNextToken = 'unit' then begin
    652     Result := TModuleUnit.Create;
    653     Result.ParentProgram := ProgramCode;
    654     ParseUnit(TModuleUnit(Result));
    655   end else begin //if FNextToken = 'program' then begin
    656     Result := TModuleProgram.Create;
    657     Result.ParentProgram := ProgramCode;
    658     ParseProgram(TModuleProgram(Result));
    659   end;
    660 end;
    661 
    662 procedure TPascalParser.ParseProgram(SourceCode: TModuleProgram);
    663 var
    664   Identifier: string;
    665 begin
    666   with SourceCode do begin
    667     if FNextToken = 'program' then begin
    668       Expect('program');
    669       Name := ReadCode;
    670       Expect(';');
    671     end else Name := '';
    672 
    673     // Uses section
    674     if FNextToken = 'uses' then
    675       ParseUses(UsedModules, False);
    676 
    677     ParseCommonBlock(Body, '.');
    678   end;
    679 end;
    680 
    681 procedure TPascalParser.ParseUnit(SourceCode: TModuleUnit);
    682 var
    683   NewModule: TModule;
    684 begin
    685   Expect('unit');
    686   with Sourcecode do begin
    687     Name := ReadCode;
    688   end;
    689   Expect(';');
    690 
    691   ParseUnitInterface(SourceCode);
    692   if FNextToken = 'implementation' then
    693     ParseUnitImplementation(SourceCode);
    694 end;
    695 
    696 procedure TPascalParser.ParseUnitInterface(SourceCode: TModuleUnit);
    697 begin
    698   Expect('interface');
    699   // Uses section
    700   if FNextToken = 'uses' then
    701     ParseUses(SourceCode.UsedModules, True);
    702 
    703   ParseCommonBlockInterface(SourceCode.Body);
    704 end;
    705 
    706 procedure TPascalParser.ParseUnitImplementation(SourceCode: TModuleUnit);
    707 begin
    708   Expect('implementation');
    709 
    710   // Uses section
    711   if FNextToken = 'uses' then
    712     ParseUses(SourceCode.UsedModules, False);
    713 
    714   ParseCommonBlock(SourceCode.Body, '.');
    715 end;
    716 
    717 { TParserCommonBlock }
    718 
    719 procedure TPascalParser.ParseCommonBlock(SourceCode: TCommonBlock;
    720   EndSymbol: char = ';');
    721 begin
    722   with SourceCode do
    723   begin
    724     while FNextToken <> EndSymbol do
    725     begin
    726       if FNextToken = 'var' then
    727         ParseVariableList(Variables)
    728       else if FNextToken = 'const' then
    729         ParseConstantList(Constants)
    730       else if FNextToken = 'type' then
    731         ParseTypeList(Types)
    732       else if FNextToken = 'procedure' then
    733         ParseFunctionList(Functions)
    734       else if FNextToken = 'function' then
    735         ParseFunctionList(Functions)
    736       else
    737       begin
    738         ParseBeginEnd(Code);
    739         Break;
    740       end;
    741     end;
    742     Expect(EndSymbol);
    743   end;
    744 end;
    745 
    746 procedure TPascalParser.ParseCommonBlockInterface(SourceCode: TCommonBlock);
    747 begin
    748   with SourceCode do begin
    749     while (FNextToken <> 'implementation') and (FNextTokenType <> ttEndOfFile) do begin
    750       if FNextToken = 'var' then
    751         ParseVariableList(Variables)
    752       else if FNextToken = 'const' then
    753         ParseConstantList(Constants, True)
    754       else if FNextToken = 'type' then
    755         ParseTypeList(Types, True)
    756       else if FNextToken = 'procedure' then
    757         ParseFunctionList(Functions, True)
    758       else if FNextToken = 'function' then
    759         ParseFunctionList(Functions, True)
    760       else begin
    761         ErrorMessage(SUnknownIdentifier, [FNextToken]);
    762         ReadCode;
    763       end;
    764     end;
    765   end;
    766 end;
    767 
    768 { TParserBeginEnd }
    769 
    770 procedure TPascalParser.ParseBeginEnd(SourceCode: TBeginEnd);
    771 var
    772   NewCommand: TCommand;
    773 begin
    774   //ShowMessage(IntToStr(Integer(SourceCode)) + ' ' + IntToStr(Integer(SourceCode.CommonBlock)));
    775   with SourceCode do
    776   begin
    777     Expect('begin');
    778     while (FNextToken <> 'end') and (FNextTokenType <> ttEndOfFile) do
    779     begin
    780       NewCommand := ParseCommand(CommonBlock);
    781       if Assigned(NewCommand) then
    782         Commands.Add(NewCommand);
    783       //ShowMessage(NextCode);
    784       if FNextToken = ';' then
    785         ReadCode;
    786     end;
    787     Expect('end');
    788   end;
    789 end;
    790 
    791 { TParserParseFunctionList }
    792 
    793 procedure TPascalParser.ParseFunctionList(SourceCode: TFunctionList; Exported: Boolean = False);
    794 var
    795   Identifiers: TStringList;
    796   NewValueType: TType;
    797   TypeName: string;
    798   VariableName: string;
    799   Variable: TParameter;
    800   I: integer;
    801 begin
    802   Identifiers := TStringList.Create;
    803   with SourceCode do begin
    804     with TFunction(Items[Add(TFunction.Create)]) do begin
    805       Parent := SourceCode.Parent;
    806       if FNextToken = 'procedure' then
    807       begin
    808         Expect('procedure');
    809         HaveResult := False;
    810       end
    811       else
    812       begin
    813         Expect('function');
    814         HaveResult := True;
    815       end;
    816       Name := ReadCode;
    817 
    818       if FNextToken = '(' then
    819       begin
    820         Expect('(');
    821         while FNextToken <> ')' do
    822         begin
    823           //    while IsIdentificator(NextCode) do begin
    824           with TParameterList(Parameters) do
    825           begin
    826             VariableName := ReadCode;
    827             Variable := Search(VariableName);
    828             if not Assigned(Variable) then
    829             begin
    830               Identifiers.Add(VariableName);
    831               while FNextToken = ',' do
    832               begin
    833                 Expect(',');
    834                 Identifiers.Add(ReadCode);
    835               end;
    836             end
    837             else
    838               ErrorMessage(SRedefineIdentifier, [VariableName]);
    839             Expect(':');
    840             TypeName := ReadCode;
    841             NewValueType := Parent.Types.Search(TypeName);
    842             if not Assigned(NewValueType) then
    843               ErrorMessage(STypeNotDefined, [TypeName])
    844             else
    845               for I := 0 to Identifiers.Count - 1 do
    846                 with TParameter(Items[Add(TParameter.Create)]) do
    847                 begin
    848                   Name := Identifiers[I];
    849                   ValueType := NewValueType;
    850                 end;
    851           end;
    852         end;
    853         Expect(')');
    854 
    855         // Parse function result type
    856         if HaveResult then
    857         begin
    858           Expect(':');
    859           TypeName := ReadCode;
    860           NewValueType := Parent.Types.Search(TypeName);
    861           if not Assigned(NewValueType) then
    862             ErrorMessage(STypeNotDefined, [TypeName])
    863           else
    864           begin
    865             ResultType := NewValueType;
    866             with TVariable(Parent.Variables.Items[Parent.Variables.Add(
    867                 TVariable.Create)]) do
    868             begin
    869               Name := 'Result';
    870               ValueType := NewValueType;
    871             end;
    872           end;
    873         end;
    874       end;
    875       Expect(';');
    876 
    877       // Check directives
    878       if FNextToken = 'internal' then begin
    879         Expect('internal');
    880         Expect(';');
    881         System := True;
    882       end;
    883     end;
    884 
    885     if not Exported then ParseCommonBlock(TFunction(Last));
    886   end;
    887   Identifiers.Destroy;
    888 end;
    889 
    890 { TParserIfThenElse }
    891 
    892 procedure TPascalParser.ParseIfThenElse(SourceCode: TIfThenElse);
    893 begin
    894   with Sourcecode do
    895   begin
    896     Expect('if');
    897     Condition.CommonBlock := CommonBlock;
    898     ParseExpression(Condition);
    899     Expect('then');
    900     Command := ParseCommand(CommonBlock);
    901     if FNextToken = 'else' then
    902     begin
    903       Expect('else');
    904       ElseCommand := ParseCommand(CommonBlock);
    905     end;
    906   end;
    907 end;
    908 
    909 procedure TPascalParser.ParseForToDo(SourceCode: TForToDo);
    910 var
    911   VariableName: string;
    912 begin
    913   with SourceCode do
    914   begin
    915     Expect('for');
    916     VariableName := ReadCode;
    917     ControlVariable := SourceCode.CommonBlock.Variables.Search(VariableName);
    918     if not Assigned(ControlVariable) then
    919       ErrorMessage(SUndefinedVariable, [VariableName]);
    920     Expect(':=');
    921     Start.CommonBlock := CommonBlock;
    922     ParseExpression(Start);
    923     Expect('to');
    924     Stop.CommonBlock := CommonBlock;
    925     ParseExpression(Stop);
    926     Expect('do');
    927     Command := ParseCommand(CommonBlock);
    928   end;
    929 end;
    930 
    931 { TParserVariableList }
    932 
    933 procedure TPascalParser.ParseVariableList(SourceCode: TVariableList; Exported: Boolean = False);
    934 var
    935   Identifiers: TStringList;
    936   NewValueType: TType;
    937   TypeName: string;
    938   VariableName: string;
    939   Variable: TVariable;
    940   I: integer;
    941 begin
    942   Identifiers := TStringList.Create;
    943   with SourceCode do
    944   begin
    945     Expect('var');
    946     while IsIdentificator(FNextToken) and (FNextTokenType <> ttEndOfFile) do
    947     begin
    948       Identifiers.Clear;
    949       VariableName := ReadCode;
    950       Variable := Search(VariableName);
    951       if not Assigned(Variable) then
    952       begin
    953         Identifiers.Add(VariableName);
    954         while FNextToken = ',' do
    955         begin
    956           Expect(',');
    957           Identifiers.Add(ReadCode);
    958         end;
    959       end
    960       else
    961         ErrorMessage(SRedefineIdentifier, [VariableName]);
    962       Expect(':');
    963       TypeName := ReadCode;
    964       NewValueType := Parent.Types.Search(TypeName);
    965       if NewValueType = nil then
    966         ErrorMessage(STypeNotDefined, [TypeName])
    967       else
    968         for I := 0 to Identifiers.Count - 1 do
    969           with TVariable(Items[Add(TVariable.Create)]) do
    970           begin
    971             Name := Identifiers[I];
    972             ValueType := NewValueType;
    973           end;
    974       Expect(';');
    975     end;
    976   end;
    977   Identifiers.Destroy;
    978 end;
    979 
    980 { TParserVariable }
    981 
    982 procedure TPascalParser.ParseVariable(SourceCode: TVariable; Exported: Boolean = False);
    983 begin
    984   with SourceCode do
    985   begin
    986     Name := FNextToken;
    987     Expect(':=');
    988 
    989   end;
    990 end;
    991 
    992 { TParserConstantList }
    993 
    994 procedure TPascalParser.ParseConstantList(SourceCode: TConstantList; Exported: Boolean = False);
    995 var
    996   Identifiers: TStringList;
    997   NewValueType: TType;
    998   TypeName: string;
    999   ConstantName: string;
    1000   Constant: TConstant;
    1001   I: integer;
    1002   ConstantValue: string;
    1003 begin
    1004   Identifiers := TStringList.Create;
    1005   with SourceCode do
    1006   begin
    1007     Expect('const');
    1008     while IsIdentificator(FNextToken) do
    1009     begin
    1010       ConstantName := ReadCode;
    1011       Constant := Search(ConstantName);
    1012       if not Assigned(Constant) then
    1013       begin
    1014         Identifiers.Add(ConstantName);
    1015         while FNextToken = ',' do
    1016         begin
    1017           Expect(',');
    1018           Identifiers.Add(ReadCode);
    1019         end;
    1020       end
    1021       else
    1022         ErrorMessage(SRedefineIdentifier, [ConstantName]);
    1023       Expect(':');
    1024       TypeName := ReadCode;
    1025       NewValueType := Parent.Types.Search(TypeName);
    1026       Expect('=');
    1027       ConstantValue := ReadCode;
    1028       Expect(';');
    1029 
    1030       if NewValueType = nil then
    1031         ErrorMessage(STypeNotDefined, [TypeName])
    1032       else
    1033         for I := 0 to Identifiers.Count - 1 do
    1034           with TConstant(Items[Add(TConstant.Create)]) do
    1035           begin
    1036             Name := Identifiers[I];
    1037             ValueType := NewValueType;
    1038             Value := ConstantValue;
    1039           end;
    1040     end;
    1041   end;
    1042   Identifiers.Destroy;
    1043 end;
    1044 
    1045 { TParserTypeList }
    1046 
    1047 procedure TPascalParser.ParseTypeList(SourceCode: TTypeList; Exported: Boolean = False);
    1048 var
    1049   NewType: TType;
    1050 begin
    1051   with SourceCode do
    1052   begin
    1053     Expect('type');
    1054     while IsIdentificator(FNextToken) do begin
    1055       NewType := ParseType(SourceCode);
    1056       if Assigned(NewType) then begin
    1057         NewType.Parent := SourceCode;
    1058         Add(NewType);
    1059       end;
    1060       Expect(';');
    1061     end;
    1062   end;
    1063 end;
    1064 
    1065 { TParserType }
    1066 
    1067 function TPascalParser.ParseType(TypeList: TTypeList; ExpectName: Boolean = True; AssignSymbol: string = '='): TType;
    1068 var
    1069   Name: string;
    1070   TypeName: string;
    1071 begin
    1072   //with SourceCode do
    1073   begin
    1074     if ExpectName then begin
    1075       Name := ReadCode;
    1076       Expect(AssignSymbol);
    1077     end;
    1078     if NextToken = '(' then begin
    1079       Result := ParseTypeEnumeration(TypeList, Name);
    1080     end else
    1081     if NextToken = 'record' then begin
    1082       Result := ParseTypeRecord(TypeList, Name);
    1083     end else
    1084     if NextToken = 'class' then begin
    1085       Expect('class');
    1086       Result := TTypeClass.Create;
    1087       TTypeClass(Result).Parent := TypeList;
    1088       TTypeClass(Result).Name := Name;
    1089       if NextToken <> ';' then begin
    1090         while (NextToken <> 'end') and (FNextTokenType <> ttEndOfFile) do
    1091         begin
    1092           TTypeClass(Result).Items.Add(ParseType(TypeList, True, ':'));
    1093           Expect(';');
    1094         end;
    1095         Expect('end');
    1096       end;
    1097     end else
    1098     if NextToken = 'array' then begin
    1099       Expect('array');
    1100       Result := TTypeArray.Create;
    1101       TTypeArray(Result).Parent := TypeList;
    1102       TType(Result).Name := Name;
    1103       if NextToken = '[' then begin
    1104         Expect('[');
    1105         TypeName := FNextToken;
    1106         TTypeArray(Result).IndexType := ParseType(TypeList, False);
    1107         if not Assigned(TTypeArray(Result).IndexType) then
    1108           ErrorMessage(SUndefinedType, [TypeName]);
    1109         Expect(']');
    1110       end;
    1111       Expect('of');
    1112       TypeName := FNextToken;
    1113       TTypeArray(Result).ItemType := ParseType(TypeList, False);
    1114       if not Assigned(TTypeArray(Result).ItemType) then
    1115         ErrorMessage(SUndefinedType, [TypeName]);
    1116     end else
    1117     if NextToken = '^' then begin
    1118       Expect('^');
    1119       Result := TTypePointer.Create;
    1120       TTypePointer(Result).Parent := TypeList;
    1121       TTypePointer(Result).Name := Name;
    1122       TTypePointer(Result).UsedType := ParseType(TypeList, False);
    1123     end else
    1124     if NextToken = 'type' then begin
    1125       Expect('type');
    1126       Result := TTypeInherited.Create;
    1127       TTypeInherited(Result).Parent := TypeList;
    1128       TTypeInherited(Result).Name := Name;
    1129       if NextToken = '(' then begin
    1130         Expect('(');
    1131         TTypeInherited(Result).UsedType := ParseType(TypeList, False);
    1132         Expect(')');
    1133       end else TTypeInherited(Result).UsedType := nil;
    1134     end else begin
    1135       TypeName := ReadCode;
    1136       if ExpectName then begin
    1137         Result := TType.Create;
    1138         TType(Result).Parent := TypeList;
    1139         TType(Result).Name := Name;
    1140         TType(Result).UsedType := TypeList.Search(TypeName);
    1141         if not Assigned(TType(Result).UsedType) then
    1142           ErrorMessage(SUndefinedType, [TypeName]);
    1143       end else begin
    1144         TType(Result) := TypeList.Search(TypeName);
    1145         if not Assigned(TType(Result)) then
    1146           ErrorMessage(SUndefinedType, [TypeName]);
    1147       end;
    1148     end;
    1149   end;
    1150 end;
    1151 
    1152 function TPascalParser.ParseTypeEnumeration(TypeList: TTypeList; Name: string): TType;
    1153 begin
    1154       Expect('(');
    1155       Result := TTypeEnumeration.Create;
    1156       TTypeEnumeration(Result).Parent := TypeList;
    1157       TTypeEnumeration(Result).Name := Name;
    1158       with TTypeEnumeration(Result) do
    1159       with TEnumItem(Items[Items.Add(TEnumItem.Create)]) do begin
    1160         Name := ReadCode;
    1161         if (NextToken = '=') and (FNextTokenType = ttConstantNumber) then begin
    1162           Expect('=');
    1163           Index := StrToInt(ReadCode);
    1164         end;
    1165       end;
    1166       while (NextToken = ',') and (FNextTokenType <> ttEndOfFile) do
    1167       begin
    1168         Expect(',');
    1169         with TTypeEnumeration(Result) do
    1170         with TEnumItem(Items[Items.Add(TEnumItem.Create)]) do begin
    1171           Name := ReadCode;
    1172           if (NextToken = '=') and (FNextTokenType = ttConstantNumber) then begin
    1173             Expect('=');
    1174             Index := StrToInt(ReadCode);
    1175           end;
    1176         end;
    1177       end;
    1178       Expect(')');
    1179 end;
    1180 
    1181 function TPascalParser.ParseTypeRecord(TypeList: TTypeList; Name: string
    1182   ): TType;
    1183 var
    1184   Visibility: TTypeVisibility;
    1185 begin
    1186   Visibility := tvPublic;
    1187       Expect('record');
    1188       Result := TTypeRecord.Create;
    1189       TTypeRecord(Result).Parent := TypeList;
    1190       TType(Result).Name := Name;
    1191       while (NextToken <> 'end') and (FNextTokenType <> ttEndOfFile) do
    1192       begin
    1193         if NextToken = 'public' then begin
    1194           Expect('public');
    1195           Visibility := tvPublic;
    1196         end else
    1197         if NextToken = 'private' then begin
    1198           Expect('private');
    1199           Visibility := tvPrivate;
    1200         end else
    1201         if NextToken = 'published' then begin
    1202           Expect('published');
    1203           Visibility := tvPublished;
    1204         end else
    1205         if NextToken = 'protected' then begin
    1206           Expect('protected');
    1207           Visibility := tvProtected;
    1208         end else
    1209         if NextToken = 'var' then
    1210           ParseVariableList(TTypeRecord(Result).CommonBlock.Variables)
    1211         else if FNextToken = 'const' then
    1212           ParseConstantList(TTypeRecord(Result).CommonBlock.Constants, True)
    1213         else if FNextToken = 'type' then
    1214           ParseTypeList(TTypeRecord(Result).CommonBlock.Types, True)
    1215         else if FNextToken = 'procedure' then
    1216           ParseFunctionList(TTypeRecord(Result).CommonBlock.Functions, True)
    1217         else if FNextToken = 'function' then
    1218           ParseFunctionList(TTypeRecord(Result).CommonBlock.Functions, True)
    1219         else begin
    1220           TTypeRecord(Result).CommonBlock.Types.Add(ParseType(TypeList, True, ':'));
    1221           TType(TTypeRecord(Result).CommonBlock.Types.Last).Visibility := Visibility;
    1222         end;
    1223         Expect(';');
    1224       end;
    1225       Expect('end');
    1226 end;
    1227 
    1228 constructor TPascalParser.Create;
    1229 begin
    1230 end;
    1231 
    1232 destructor TPascalParser.Destroy;
    1233 begin
    1234   inherited Destroy;
    1235 end;
    1236 
    1237 { TParserUsedModuleList }
    1238 
    1239 procedure TPascalParser.ParseUses(SourceCode: TUsedModuleList; AExported: Boolean = False);
    1240 var
    1241   NewUsedModule: TUsedModule;
    1242 begin
    1243   Expect('uses');
    1244   with TUsedModule(SourceCode.Items[SourceCode.Add(TUsedModule.Create)]) do
    1245   begin
    1246     Name := ReadCode;
    1247     if FNextToken = 'in' then begin
    1248       Expect('in');
    1249       Location := ReadCode;
    1250     end else Location := Name + '.pas';
    1251     Module := SourceCode.ParentModule.ParentProgram.Modules.Search(Name);
    1252     if not Assigned(Module) then begin
    1253       if ParseFile(Name) then begin
    1254         Module := SourceCode.ParentModule.ParentProgram.Modules.Search(Name);
    1255         Exported := AExported;
    1256       end else ErrorMessage(SUnitNotFound, [Name]);
    1257     end;
    1258   end;
    1259   while FNextToken = ',' do begin
    1260     Expect(',');
    1261     with TUsedModule(SourceCode.Items[SourceCode.Add(TUsedModule.Create)]) do
    1262     begin
    1263       Name := ReadCode;
    1264       if FNextToken = 'in' then begin
    1265         Expect('in');
    1266         Location := ReadCode;
    1267       end else Location := Name + '.pas';
    1268       Module := SourceCode.ParentModule.ParentProgram.Modules.Search(Name);
    1269       if not Assigned(Module) then begin
    1270         if not ParseFile(Name) then ErrorMessage(SUnitNotFound, [Name]);
    1271       end;
    1272     end;
    1273   end;
    1274   Expect(';');
    1275 end;
    1276 
    1277320end.
    1278321
Note: See TracChangeset for help on using the changeset viewer.