source: trunk/Compiler/Analyze/UPascalParser.pas@ 3

Last change on this file since 3 was 3, checked in by george, 11 years ago
  • Modified: More parsing procedures transformed to functions.
File size: 38.6 KB
Line 
1unit UPascalParser;
2
3{$mode delphi}
4
5interface
6
7uses
8 Classes, SysUtils, UParser, USourceCode, Dialogs;
9
10type
11 TGetSourceEvent = function (Name: string; Source: TStringList): Boolean of object;
12
13 { TPascalParser }
14
15 TPascalParser = class(TBaseParser)
16 private
17 FOnGetSource: TGetSourceEvent;
18 public
19 function ParseFile(Name: string): Boolean;
20 function ParseWhileDo(var WhileDo: TWhileDo; SourceCode: TCommonBlock): Boolean;
21 procedure ParseExpression(SourceCode: TExpression);
22 function ParseRightValue(SourceCode: TExpression): TObject;
23 function ParseFunctionCall(SourceCode: TExpression): TObject;
24 function ParseUses(SourceCode: TUsedModuleList; AExported: Boolean): Boolean;
25 function ParseModule(ProgramCode: TProgram): TModule;
26 function ParseUnit(var SourceCode: TModuleUnit; ProgramCode: TProgram): Boolean;
27 function ParseUnitInterface(SourceCode: TModuleUnit): Boolean;
28 function ParseUnitImplementation(SourceCode: TModuleUnit): Boolean;
29 procedure ParseProgram(SourceCode: TModuleProgram);
30 procedure ParseCommonBlock(SourceCode: TCommonBlock; EndSymbol: char = ';';
31 WithBody: Boolean = True);
32 procedure ParseCommonBlockInterface(SourceCode: TCommonBlock);
33 function ParseCommand(SourceCode: TCommonBlock): TCommand;
34 function ParseBeginEnd(var BeginEnd: TBeginEnd; SourceCode: TCommonBlock): Boolean;
35 function ParseFunctionList(SourceCode: TFunctionList; Exported: Boolean = False): Boolean;
36 procedure ParseFunctionParameters(SourceCode: TFunction; ValidateParams: Boolean = False);
37 function ParseIfThenElse(var IfThenElse: TIfThenElse; SourceCode: TCommonBlock): Boolean;
38 function ParseForToDo(var ForToDo: TForToDo; SourceCode: TCommonBlock): Boolean;
39 function ParseVariableList(SourceCode: TVariableList; Exported: Boolean = False): Boolean;
40 procedure ParseVariable(SourceCode: TVariableList; Exported: Boolean = False);
41 function ParseConstantList(SourceCode: TConstantList; Exported: Boolean = False): Boolean;
42 function ParseConstant(SourceCode: TConstantList; Exported: Boolean = False): Boolean;
43 function ParseTypeList(SourceCode: TTypeList; Exported: Boolean = False;
44 AssignSymbol: string = '='): Boolean;
45 function ParseType(TypeList: TTypeList; ExpectName: Boolean = True; AssignSymbol: string = '='): TType;
46 function ParseTypeSubType(TypeList: TTypeList; Name: string; ExpectName: Boolean): TType;
47 function ParseTypeBase(TypeList: TTypeList; Name: string): TType;
48 function ParseTypePointer(TypeList: TTypeList; Name: string): TType;
49 function ParseTypeEnumeration(TypeList: TTypeList; Name: string): TType;
50 function ParseTypeRecord(TypeList: TTypeList; Name: string): TType;
51 function ParseTypeClass(TypeList: TTypeList; Name: string): TType;
52 function ParseTypeArray(TypeList: TTypeList; Name: string): TType;
53 function ParseTypeSubRange(TypeList: TTypeList; Name: string): TType;
54 property OnGetSource: TGetSourceEvent read FOnGetSource
55 write FOnGetSource;
56 constructor Create;
57 destructor Destroy; override;
58 end;
59
60
61resourcestring
62 SUnknownIdentifier = 'Unknown identificator "%s".';
63 SIllegalExpression = 'Illegal expression "%s".';
64 SRedefineIdentifier = 'Identificator "%s" redefinition.';
65 SEndOfDataReached = 'Parser reached to end of input data.';
66 SUndefinedVariable = 'Undefined variable "%s".';
67 SUndefinedType = 'Undefined type "%s".';
68 SUndefinedConstant = 'Undefined constant "%s".';
69 SUnitNotFound = 'Unit "%s" not found.';
70 SFunctionNotDeclared = 'Function "%s" not declared.';
71 SUnknownProcName = 'Unknown proc name "%s".';
72 SUnknownModuleType = 'Unknown module name "%s".';
73 SInvalidConstruction = 'Invalid construction.';
74 SInvalidAssignmentValue = 'Invalid assignment "%s".';
75 SParamDiffers = 'Declaration of parametr "%s" differs.';
76
77implementation
78
79{ TPascalParser }
80
81function TPascalParser.ParseFile(Name: string): Boolean;
82var
83 Parser: TPascalParser;
84 NewModule: TModule;
85begin
86 try
87 Parser := TPascalParser.Create;
88 Parser.SourceCodeText := TStringList.Create;
89 Parser.OnDebugLog := OnDebugLog;
90 Parser.ProgramCode := ProgramCode;
91 Parser.OnGetSource := OnGetSource;
92 if Assigned(OnGetSource) then begin
93 if FOnGetSource(Name, Parser.SourceCodeText) then begin
94 Parser.Process;
95 Parser.FileName := Name;
96 Parser.OnErrorMessage := OnErrorMessage;
97 //NewModule :=
98 Parser.ParseModule(ProgramCode);
99 //ProgramCode.Modules.Add(NewModule);
100 Result := True;
101 end else Result := False;
102 end else Result := False;
103 finally
104 Parser.SourceCodeText.Free;
105 Parser.Free;
106 end;
107end;
108
109function TPascalParser.ParseWhileDo(var WhileDo: TWhileDo; SourceCode: TCommonBlock): Boolean;
110begin
111 if NextToken = 'while' then begin
112 Expect('while');
113 WhileDo := TWhileDo.Create;
114 WhileDo.CommonBlock := SourceCode;
115 with WhileDo do begin
116 Condition.CommonBlock := CommonBlock;
117 ParseExpression(Condition);
118 Expect('do');
119 Command := ParseCommand(CommonBlock);
120 end;
121 Result := True;
122 end else Result := False;
123end;
124
125{ TExpression }
126
127procedure TPascalParser.ParseExpression(SourceCode: TExpression);
128var
129 Identifier: string;
130 IdentifierType: TTokenType;
131 NewVariable: TVariable;
132 NewExpression: TExpression;
133 NewMethod: TFunction;
134 Constant: TConstant;
135 UseType: TType;
136 // Brackets: Integer;
137 Expressions: TExpressionList;
138 I: integer;
139 II: integer;
140 RightValue: TObject;
141begin
142 Expressions := TExpressionList.Create;
143 Expressions.Add(TExpression.Create);
144 with SourceCode do begin
145 while ((NextToken <> ';') and (NextToken <> ',') and (not IsKeyWord(NextToken))) and not
146 (((NextToken = ')') or (NextToken = ']'))) and not (NextTokenType = ttEndOfFile) do begin
147 IdentifierType := NextTokenType;
148 if NextToken = '(' then begin
149 Expect('(');
150 // Subexpression
151 with TExpression(Expressions.Last) do begin
152 SubItems[1] := TExpression.Create;
153 TExpression(SubItems[1]).CommonBlock := SourceCode.CommonBlock;
154 ParseExpression(TExpression(SubItems[1]));
155 end;
156 with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do
157 begin
158 CommonBlock := SourceCode.CommonBlock;
159 SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
160 end;
161 Expect(')');
162 end else
163 if IsOperator(NextToken) then begin
164 // Operator
165 TExpression(Expressions.Last).OperatorName := ReadToken;
166 TExpression(Expressions.Last).NodeType := ntOperator;
167 end else begin
168 RightValue := ParseRightValue(SourceCode);
169 if Assigned(RightValue) then begin
170 with TExpression(Expressions.Last) do begin
171 SubItems[1] := TExpression.Create;
172 TExpression(SubItems[1]).CommonBlock := SourceCode.CommonBlock;
173 if RightValue is TVariable then begin
174 TExpression(SubItems[1]).NodeType := ntVariable;
175 TExpression(SubItems[1]).Variable := TVariable(RightValue);
176 end;
177 if RightValue is TConstant then begin
178 TExpression(SubItems[1]).NodeType := ntConstant;
179 TExpression(SubItems[1]).Constant := TConstant(RightValue);
180 end;
181 if RightValue is TFunctionCall then begin
182 TExpression(SubItems[1]).NodeType := ntFunction;
183 TExpression(SubItems[1]).FunctionCall := TFunction(RightValue);
184 end;
185 end;
186 with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do
187 begin
188 CommonBlock := SourceCode.CommonBlock;
189 SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
190 end;
191 end else begin
192 ErrorMessage(SInvalidAssignmentValue, [NextToken]);
193 ReadToken;
194 end;
195 end;
196 end;
197
198 // Build expression tree
199 for II := 0 to High(Operators) do begin
200 I := 1;
201 while (I < Expressions.Count - 1) do begin
202 if not TExpression(Expressions[I]).Associated and
203 (TExpression(Expressions[I]).OperatorName = Operators[II]) then
204 begin
205 TExpression(Expressions[I]).Associated := True;
206 TExpression(Expressions[I - 1]).SubItems[1] := Expressions[I];
207 TExpression(Expressions[I + 1]).SubItems[0] := Expressions[I];
208 //Expressions.Delete(I);
209 end else Inc(I);
210 end;
211 end;
212 if Assigned(TExpression(Expressions.First).SubItems[1]) then
213 Assign(TExpression(TExpression(Expressions.First).SubItems[1]));
214 TExpression(Expressions.First).SubItems[1] := nil;
215 //ShowMessage(IntToStr(Expressions.Count));
216 if Expressions.Count > 1 then
217 TExpression(Expressions[1]).SubItems[0] := nil;
218 Expressions.Free;
219 end;
220end;
221
222function TPascalParser.ParseRightValue(SourceCode: TExpression): TObject;
223var
224 UseType: TType;
225 UseVariable: TVariable;
226 UseConstant: TConstant;
227 UseFunction: TFunction;
228 Identifier: string;
229begin
230 Result := nil;
231 with SourceCode do
232 if IsIdentificator(NextToken) then begin
233 // Start with type
234 UseType := CommonBlock.Types.Search(NextToken);
235 if Assigned(UseType) then begin
236 ReadToken;
237 if (UseType is TTypeRecord) or (UseType is TTypeClass) then begin
238 Expect('.');
239 Identifier := ReadToken;
240 UseVariable := TTypeRecord(UseType).CommonBlock.Variables.Search(Identifier);
241 if Assigned(UseVariable) then begin
242 Result := UseVariable;
243 end;
244 if not Assigned(Result) then begin
245 UseFunction := TTypeRecord(UseType).CommonBlock.Functions.Search(Identifier);
246 if Assigned(UseFunction) then begin
247 Result := UseFunction;
248 end;
249 end;
250 if not Assigned(Result) then
251 ErrorMessage(SUndefinedVariable, [Identifier]);
252 end else ErrorMessage(SIllegalExpression, [Identifier]);
253 end;
254 if not Assigned(Result) then begin
255 UseVariable := CommonBlock.Variables.Search(Identifier);
256 if Assigned(UseVariable) then begin
257 // Referenced variable
258 ReadToken;
259 Result := UseVariable;
260 end;
261 end;
262 if not Assigned(Result) then begin
263 Result := ParseFunctionCall(SourceCode);
264 end;
265 if not Assigned(Result) then begin
266 UseConstant := CommonBlock.Constants.Search(NextToken);
267 if Assigned(UseConstant) then begin
268 ReadToken;
269 Result := UseConstant;
270 end;
271 end;
272 if not Assigned(Result) then begin
273 // Constant value
274 Result := TConstant.Create;
275 TConstant(Result).Value := ReadToken;
276 end;
277 if not Assigned(Result) then begin
278 ErrorMessage(SUnknownIdentifier, [ReadToken]);
279 end;
280 end else Result := nil;
281end;
282
283function TPascalParser.ParseFunctionCall(SourceCode: TExpression): TObject;
284var
285 UseFunction: TFunction;
286begin
287 Result := nil;
288 with SourceCode do begin
289 UseFunction := CommonBlock.Functions.Search(NextToken);
290 if Assigned(UseFunction) then begin
291 ReadToken;
292 Result := UseFunction;
293 if NextToken = '(' then begin
294 Expect('(');
295 while NextToken = ',' do begin
296 Expect(',');
297 Expect(')');
298 end;
299 end;
300 end;
301 end;
302end;
303
304function TPascalParser.ParseCommand(SourceCode: TCommonBlock): TCommand;
305var
306 Identifier: string;
307 Variable: TVariable;
308 Method: TFunction;
309 First: TOperation;
310 Second: TOperation;
311 StartIndex: integer;
312 LoopVariable: TVariable;
313 IdentName: string;
314 FunctionName: string;
315begin
316 begin
317 if not ParseBeginEnd(TBeginEnd(Result), SourceCode) then
318 if not ParseIfThenElse(TIfThenElse(Result), SourceCode) then
319 if not ParseWhileDo(TWhileDo(Result), SourceCode) then
320 if not ParseForToDo(TForToDo(Result), SourceCode) then
321 if IsIdentificator(NextToken) then begin
322 if Assigned(SourceCode.Variables.Search(NextToken)) then begin
323 // Variable assignment
324 Result := TAssignment.Create;
325 TAssignment(Result).CommonBlock := SourceCode;
326 IdentName := ReadToken;
327 TAssignment(Result).Target := SourceCode.Variables.Search(IdentName);
328 Expect(':=');
329 TAssignment(Result).Source := TExpression.Create;
330 TAssignment(Result).Source.CommonBlock := SourceCode;
331 ParseExpression(TAssignment(Result).Source);
332 end else
333 if Assigned(SourceCode.Functions.Search(NextToken)) then begin
334 // Function call
335 FunctionName := ReadToken;
336 Result := TFunctionCall.Create;
337 TFunctionCall(Result).CommonBlock := SourceCode;
338 TFunctionCall(Result).FunctionRef := SourceCode.Functions.Search(FunctionName);
339 if NextToken = '(' then
340 begin
341 Expect('(');
342 with TFunctionCall(Result) do
343 begin
344 ParameterExpression.Add(TExpression.Create);
345 TExpression(ParameterExpression.Last).CommonBlock := SourceCode;
346 ParseExpression(TExpression(ParameterExpression.Last));
347 end;
348 Expect(')');
349 end;
350 end else begin
351 Result := nil;
352 ErrorMessage(SUnknownIdentifier, [ReadToken], -1);
353 end;
354 end else
355 if NextToken = ';' then
356 Result := nil
357 else begin
358 Result := nil;
359 ErrorMessage(SIllegalExpression, [ReadToken], -1);
360 end;
361 end;
362end;
363
364{ TParserModule }
365
366function TPascalParser.ParseModule(ProgramCode: TProgram): TModule;
367begin
368 Self.ProgramCode := ProgramCode;
369 if not ParseUnit(TModuleUnit(Result), ProgramCode) then begin
370 Result := TModuleProgram.Create;
371 Result.ParentProgram := ProgramCode;
372 ParseProgram(TModuleProgram(Result));
373 end else
374 ErrorMessage(SUnknownModuleType, [NextToken]);
375end;
376
377procedure TPascalParser.ParseProgram(SourceCode: TModuleProgram);
378var
379 Identifier: string;
380begin
381 with SourceCode do begin
382 if NextToken = 'program' then begin
383 Expect('program');
384 Name := ReadToken;
385 Expect(';');
386 end else Name := '';
387
388 // Uses section
389 if NextToken = 'uses' then
390 ParseUses(UsedModules, False);
391
392 ParseCommonBlock(Body, '.');
393 SourceCode.ParentProgram.Modules.Add(SourceCode);
394 end;
395end;
396
397function TPascalParser.ParseUnit(var SourceCode: TModuleUnit; ProgramCode: TProgram): Boolean;
398var
399 NewModule: TModule;
400begin
401 if NextToken = 'unit' then begin
402 SourceCode := TModuleUnit.Create;
403 SourceCode.ParentProgram := ProgramCode;
404 Expect('unit');
405 with Sourcecode do begin
406 Name := ReadToken;
407 end;
408 Expect(';');
409
410 if not ParseUnitInterface(SourceCode) then
411 ErrorMessage(SExpectedButFound, ['interface', NextToken]);
412
413 if not ParseUnitImplementation(SourceCode) then
414 ErrorMessage(SExpectedButFound, ['implementation', NextToken]);
415
416 SourceCode.ParentProgram.Modules.Add(SourceCode);
417
418 if NextToken = 'initialization' then begin
419 Expect('initialization');
420 end;
421 if NextToken = 'finalization' then begin
422 Expect('finalization');
423 end;
424 Result := True;
425 end else Result := False;
426end;
427
428function TPascalParser.ParseUnitInterface(SourceCode: TModuleUnit): Boolean;
429begin
430 if NextToken = 'interface' then begin
431 Expect('interface');
432 // Uses section
433 ParseUses(SourceCode.UsedModules, True);
434
435 ParseCommonBlockInterface(SourceCode.Body);
436 Result := True;
437 end else Result := False;
438end;
439
440function TPascalParser.ParseUnitImplementation(SourceCode: TModuleUnit): Boolean;
441begin
442 if NextToken = 'implementation' then begin
443 Expect('implementation');
444
445 // Uses section
446 if NextToken = 'uses' then
447 ParseUses(SourceCode.UsedModules, False);
448
449 ParseCommonBlock(SourceCode.Body, '.', False);
450 Result := True;
451 end else Result := False;
452end;
453
454{ TParserCommonBlock }
455
456procedure TPascalParser.ParseCommonBlock(SourceCode: TCommonBlock;
457 EndSymbol: char = ';'; WithBody: Boolean = True);
458begin
459 with SourceCode do begin
460 while (NextToken <> EndSymbol) do begin
461 if not ParseVariableList(Variables) then
462 if not ParseConstantList(Constants) then
463 if not ParseTypeList(Types) then
464 if not ParseFunctionList(Functions) then begin
465 if WithBody then
466 if not ParseBeginEnd(Code, SourceCode) then
467 ErrorMessage(SExpectedButFound, ['begin', NextToken]);
468 Break;
469 end;
470 end;
471 if WithBody then Expect(EndSymbol);
472 end;
473end;
474
475procedure TPascalParser.ParseCommonBlockInterface(SourceCode: TCommonBlock);
476begin
477 with SourceCode do begin
478 while (NextToken <> 'implementation') and (NextTokenType <> ttEndOfFile) do begin
479 if not ParseVariableList(Variables, True) then
480 if not ParseConstantList(Constants, True) then
481 if not ParseTypeList(Types, True) then
482 if not ParseFunctionList(Functions, True) then begin
483 ErrorMessage(SUnknownIdentifier, [NextToken], -1);
484 ReadToken;
485 end;
486 end;
487 end;
488end;
489
490{ TParserBeginEnd }
491
492function TPascalParser.ParseBeginEnd(var BeginEnd: TBeginEnd; SourceCode: TCommonBlock): Boolean;
493var
494 NewCommand: TCommand;
495begin
496 if NextToken = 'begin' then begin
497 //ShowMessage(IntToStr(Integer(SourceCode)) + ' ' + IntToStr(Integer(SourceCode.CommonBlock)));
498 BeginEnd := TBeginEnd.Create;
499 TBeginEnd(BeginEnd).CommonBlock := SourceCode;
500 with BeginEnd do
501 begin
502 Expect('begin');
503 while (NextToken <> 'end') and (NextTokenType <> ttEndOfFile) do
504 begin
505 NewCommand := ParseCommand(CommonBlock);
506 if Assigned(NewCommand) then
507 Commands.Add(NewCommand);
508 //ShowMessage(NextCode);
509 if NextToken = ';' then
510 ReadToken;
511 end;
512 Expect('end');
513 end;
514 Result := True;
515 end else Result := False;
516end;
517
518{ TParserParseFunctionList }
519
520function TPascalParser.ParseFunctionList(SourceCode: TFunctionList;
521 Exported: Boolean = False): Boolean;
522var
523 NewValueType: TType;
524 TypeName: string;
525 UseName: string;
526 I: Integer;
527 UseType: TType;
528 UseFunction: TFunction;
529 FunctionType: TFunctionType;
530 ValidParams: Boolean;
531begin
532 if (NextToken = 'procedure') or (NextToken = 'function') then begin
533 with SourceCode do begin
534 if NextToken = 'procedure' then begin
535 Expect('procedure');
536 FunctionType := ftProcedure;
537 end else
538 if NextToken = 'function' then begin
539 Expect('function');
540 FunctionType := ftFunction;
541 end else
542 if NextToken = 'constructor' then begin
543 Expect('constructor');
544 FunctionType := ftConstructor;
545 end else
546 if NextToken = 'destructor' then begin
547 Expect('destructor');
548 FunctionType := ftDestructor;
549 end else ErrorMessage(SUnknownProcName, [NextToken]);
550
551 // Read function name
552 UseName := ReadToken;
553 UseType := SourceCode.Parent.Types.Search(UseName);
554 if Assigned(UseType) and ((UseType is TTypeRecord) or
555 (UseType is TTypeClass)) then begin
556 Expect('.');
557 ValidParams := True;
558 UseName := ReadToken;
559 if UseType is TTypeRecord then begin
560 UseFunction := TTypeRecord(UseType).CommonBlock.Functions.Search(UseName);
561 if not Assigned(UseFunction) then begin
562 ErrorMessage(SFunctionNotDeclared, [UseName]);
563 Exit;
564 end;
565 end;
566 end else begin
567 // Create new function
568 UseFunction := TFunction.Create;
569 UseFunction.Parent := SourceCode.Parent;
570 UseFunction.Name := UseName;
571 UseFunction.FunctionType := FunctionType;
572 Add(UseFunction);
573 ValidParams := False;
574 end;
575 with UseFunction do begin
576 // Parse parameters
577 if NextToken = '(' then
578 ParseFunctionParameters(UseFunction, ValidParams);
579
580 // Parse function result type
581 if FunctionType = ftFunction then begin
582 Expect(':');
583 TypeName := ReadToken;
584 NewValueType := Parent.Types.Search(TypeName);
585 if not Assigned(NewValueType) then
586 ErrorMessage(SUndefinedType, [TypeName], -1);
587(* else
588 begin
589 ResultType := NewValueType;
590 with TVariable(Parent.Variables.Items[Parent.Variables.Add(
591 TVariable.Create)]) do
592 begin
593 Name := 'Result';
594 ValueType := NewValueType;
595 end;
596 end; *)
597 end;
598 Expect(';');
599
600 // Check directives
601 if NextToken = 'internal' then begin
602 Expect('internal');
603 Expect(';');
604 Internal := True;
605 end;
606 end;
607
608 if not Exported then ParseCommonBlock(UseFunction);
609// if UseFunction then UseFunction.Code ;
610 end;
611 Result := True;
612 end else Result := False;
613end;
614
615procedure TPascalParser.ParseFunctionParameters(SourceCode: TFunction;
616 ValidateParams: Boolean = False);
617var
618 Identifiers: TStringList;
619 VariableName: string;
620 UseVariable: TParameter;
621 TypeName: string;
622 UseType: TType;
623 I: Integer;
624begin
625 with SourceCode do
626 try
627 Identifiers := TStringList.Create;
628 Expect('(');
629 while (NextToken <> ')') and (NextTokenType <> ttEndOfFile) do begin
630 // while IsIdentificator(NextCode) do begin
631 with TParameterList(Parameters) do begin
632 VariableName := ReadToken;
633 if VariableName = 'var' then begin
634 end else
635 if VariableName = 'const' then begin
636 end else begin
637 UseVariable := Search(VariableName);
638 if not Assigned(UseVariable) then begin
639 Identifiers.Add(VariableName);
640 while NextToken = ',' do begin
641 Expect(',');
642 Identifiers.Add(ReadToken);
643 end;
644 end else
645 if not ValidateParams then
646 ErrorMessage(SRedefineIdentifier, [VariableName], -1);
647 Expect(':');
648 TypeName := ReadToken;
649 UseType := Parent.Types.Search(TypeName);
650 if not Assigned(UseType) then
651 ErrorMessage(SUndefinedType, [TypeName], -1)
652 else
653 if ValidateParams then begin
654 for I := 0 to Identifiers.Count - 1 do begin
655 UseVariable := Parameters.Search(Identifiers[I]);
656 if Assigned(UseVariable) then
657 if UseVariable.ValueType <> UseType then ;
658 ErrorMessage(SParamDiffers, [Identifiers[I]]);
659 end;
660 end else begin
661 for I := 0 to Identifiers.Count - 1 do
662 with TParameter(Items[Add(TParameter.Create)]) do
663 begin
664 Name := Identifiers[I];
665 ValueType := UseType;
666 end;
667
668 end;
669 end;
670 end;
671 if NextToken = ';' then Expect(';');
672 end;
673 Expect(')');
674 finally
675 Identifiers.Free;
676 end;
677end;
678
679{ TParserIfThenElse }
680
681function TPascalParser.ParseIfThenElse(var IfThenElse: TIfThenElse; SourceCode: TCommonBlock): Boolean;
682begin
683 if NextToken = 'if' then begin
684 IfThenElse := TIfThenElse.Create;
685 IfThenElse.CommonBlock := SourceCode;
686 with IfThenElse do begin
687 Expect('if');
688 Condition.CommonBlock := CommonBlock;
689 ParseExpression(Condition);
690 Expect('then');
691 Command := ParseCommand(CommonBlock);
692 if NextToken = 'else' then
693 begin
694 Expect('else');
695 ElseCommand := ParseCommand(CommonBlock);
696 end;
697 end;
698 Result := True;
699 end else Result := False;
700end;
701
702function TPascalParser.ParseForToDo(var ForToDo: TForToDo; SourceCode: TCommonBlock): Boolean;
703var
704 VariableName: string;
705begin
706 if NextToken = 'for' then begin
707 ForToDo := TForToDo.Create;
708 ForToDo.CommonBlock := SourceCode;
709 with ForToDo do begin
710 Expect('for');
711 VariableName := ReadToken;
712 ControlVariable := ForToDo.CommonBlock.Variables.Search(VariableName);
713 if not Assigned(ControlVariable) then
714 ErrorMessage(SUndefinedVariable, [VariableName], -1);
715 Expect(':=');
716 Start.CommonBlock := CommonBlock;
717 ParseExpression(Start);
718 Expect('to');
719 Stop.CommonBlock := CommonBlock;
720 ParseExpression(Stop);
721 Expect('do');
722 Command := ParseCommand(CommonBlock);
723 end;
724 Result := True;
725 end else Result := False;
726end;
727
728{ TParserVariableList }
729
730function TPascalParser.ParseVariableList(SourceCode: TVariableList; Exported: Boolean = False): Boolean;
731var
732 NewValueType: TType;
733 TypeName: string;
734 I: integer;
735begin
736 if NextToken = 'var' then begin
737 Expect('var');
738 with SourceCode do begin
739 while IsIdentificator(NextToken) and (NextTokenType <> ttEndOfFile) do begin
740 ParseVariable(SourceCode, Exported);
741 end;
742 end;
743 Result := True;
744 end else Result := False;
745end;
746
747{ TParserVariable }
748
749procedure TPascalParser.ParseVariable(SourceCode: TVariableList; Exported: Boolean = False);
750var
751 VariableName: string;
752 Variable: TVariable;
753 TypeName: string;
754 NewValueType: TType;
755 Identifiers: TStringList;
756 I: Integer;
757begin
758 try
759 Identifiers := TStringList.Create;
760 with SourceCode do begin
761 Identifiers.Clear;
762 VariableName := ReadToken;
763 Variable := Search(VariableName);
764 if not Assigned(Variable) then begin
765 Identifiers.Add(VariableName);
766 while NextToken = ',' do begin
767 Expect(',');
768 Identifiers.Add(ReadToken);
769 end;
770 end else
771 ErrorMessage(SRedefineIdentifier, [VariableName], -1);
772 Expect(':');
773 TypeName := ReadToken;
774 NewValueType := Parent.Types.Search(TypeName);
775 if NewValueType = nil then
776 ErrorMessage(SUndefinedType, [TypeName], -1)
777 else
778 for I := 0 to Identifiers.Count - 1 do
779 with TVariable(Items[Add(TVariable.Create)]) do begin
780 Name := Identifiers[I];
781 ValueType := NewValueType;
782 end;
783 Expect(';');
784 end;
785 finally
786 Identifiers.Free;
787 end;
788end;
789
790{ TParserConstantList }
791
792function TPascalParser.ParseConstantList(SourceCode: TConstantList; Exported: Boolean = False): Boolean;
793begin
794 if NextToken = 'const' then begin
795 Expect('const');
796 with SourceCode do begin
797 while IsIdentificator(NextToken) do begin
798 ParseConstant(SourceCode, Exported);
799 end;
800 end;
801 Result := True;
802 end else Result := False;
803end;
804
805function TPascalParser.ParseConstant(SourceCode: TConstantList;
806 Exported: Boolean): Boolean;
807var
808 Identifiers: TStringList;
809 NewValueType: TType;
810 TypeName: string;
811 ConstantName: string;
812 Constant: TConstant;
813 I: integer;
814 ConstantValue: string;
815begin
816 with SourceCode do
817 try
818 Identifiers := TStringList.Create;
819 ConstantName := ReadToken;
820 Constant := Search(ConstantName);
821 if not Assigned(Constant) then begin
822 Identifiers.Add(ConstantName);
823 while NextToken = ',' do begin
824 Expect(',');
825 Identifiers.Add(ReadToken);
826 end;
827 end else
828 ErrorMessage(SRedefineIdentifier, [ConstantName], -1);
829 if NextToken = ':' then begin
830 Expect(':');
831 TypeName := ReadToken;
832 NewValueType := Parent.Types.Search(TypeName);
833 end;
834 Expect('=');
835 ConstantValue := ReadToken;
836 Expect(';');
837
838 if NewValueType = nil then
839 ErrorMessage(SUndefinedType, [TypeName], -1)
840 else
841 for I := 0 to Identifiers.Count - 1 do
842 with TConstant(Items[Add(TConstant.Create)]) do
843 begin
844 Name := Identifiers[I];
845 ValueType := NewValueType;
846 Value := ConstantValue;
847 end;
848 finally
849 Identifiers.Free;
850 end;
851end;
852
853{ TParserTypeList }
854
855function TPascalParser.ParseTypeList(SourceCode: TTypeList;
856 Exported: Boolean = False; AssignSymbol: string = '='): Boolean;
857var
858 NewType: TType;
859begin
860 if NextToken = 'type' then begin
861 Expect('type');
862 with SourceCode do begin
863 while IsIdentificator(NextToken) do begin
864 NewType := ParseType(SourceCode, True, AssignSymbol);
865 if Assigned(NewType) then begin
866 NewType.Parent := SourceCode;
867 Add(NewType);
868 end;
869 Expect(';');
870 end;
871 end;
872 Result := True;
873 end else Result := False
874end;
875
876{ TParserType }
877
878function TPascalParser.ParseType(TypeList: TTypeList; ExpectName: Boolean = True;
879 AssignSymbol: string = '='): TType;
880var
881 Name: string;
882 TypeName: string;
883begin
884 //with SourceCode do
885 begin
886 if ExpectName then begin
887 Name := ReadToken;
888 Expect(AssignSymbol);
889 end;
890 Result := ParseTypeEnumeration(TypeList, Name);
891 if not Assigned(Result) then Result := ParseTypeRecord(TypeList, Name);
892 if not Assigned(Result) then Result := ParseTypeClass(TypeList, Name);
893 if not Assigned(Result) then Result := ParseTypeArray(TypeList, Name);
894 if not Assigned(Result) then Result := ParseTypePointer(TypeList, Name);
895 if not Assigned(Result) then Result := ParseTypeBase(TypeList, Name);
896 if not Assigned(Result) then Result := ParseTypeSubType(TypeList, Name, ExpectName);
897 if not Assigned(Result) then Result := ParseTypeSubRange(TypeList, Name);
898 if not Assigned(Result) then
899 ErrorMessage(SInvalidConstruction, []);
900 end;
901end;
902
903function TPascalParser.ParseTypeSubType(TypeList: TTypeList; Name: string;
904 ExpectName: Boolean): TType;
905var
906 TypeName: string;
907begin
908 // Use existed type
909 if NextTokenType = ttIdentifier then begin
910 TypeName := ReadToken;
911 if ExpectName then begin
912 Result := TType.Create;
913 TType(Result).Parent := TypeList;
914 TType(Result).Name := Name;
915 TType(Result).UsedType := TypeList.Search(TypeName);
916 if not Assigned(TType(Result).UsedType) then
917 ErrorMessage(SUndefinedType, [TypeName], -1);
918 end else begin
919 TType(Result) := TypeList.Search(TypeName);
920 if not Assigned(TType(Result)) then
921 ErrorMessage(SUndefinedType, [TypeName], -1);
922 end;
923 end else Result := nil;
924end;
925
926function TPascalParser.ParseTypeBase(TypeList: TTypeList; Name: string): TType;
927begin
928 // Buildin base type construction
929 if NextToken = 'type' then begin
930 Expect('type');
931 Result := TTypeInherited.Create;
932 TTypeInherited(Result).Parent := TypeList;
933 TTypeInherited(Result).Name := Name;
934 if NextToken = '(' then begin
935 Expect('(');
936 TTypeInherited(Result).UsedType := ParseType(TypeList, False);
937 Expect(')');
938 end else TTypeInherited(Result).UsedType := nil;
939 end else Result := nil;
940end;
941
942function TPascalParser.ParseTypePointer(TypeList: TTypeList; Name: string
943 ): TType;
944begin
945 if NextToken = '^' then begin
946 Expect('^');
947 Result := TTypePointer.Create;
948 TTypePointer(Result).Parent := TypeList;
949 TTypePointer(Result).Name := Name;
950 TTypePointer(Result).UsedType := ParseType(TypeList, False);
951 end else Result := nil;
952end;
953
954function TPascalParser.ParseTypeEnumeration(TypeList: TTypeList; Name: string): TType;
955begin
956 if NextToken = '(' then begin
957 Expect('(');
958 Result := TTypeEnumeration.Create;
959 TTypeEnumeration(Result).Parent := TypeList;
960 TTypeEnumeration(Result).Name := Name;
961 with TTypeEnumeration(Result) do
962 with TEnumItem(Items[Items.Add(TEnumItem.Create)]) do begin
963 Name := ReadToken;
964 if (NextToken = '=') and (NextTokenType = ttConstantNumber) then begin
965 Expect('=');
966 Index := StrToInt(ReadToken);
967 end;
968 end;
969 while (NextToken = ',') and (NextTokenType <> ttEndOfFile) do
970 begin
971 Expect(',');
972 with TTypeEnumeration(Result) do
973 with TEnumItem(Items[Items.Add(TEnumItem.Create)]) do begin
974 Name := ReadToken;
975 if (NextToken = '=') and (NextTokenType = ttConstantNumber) then begin
976 Expect('=');
977 Index := StrToInt(ReadToken);
978 end;
979 end;
980 end;
981 Expect(')');
982 end else Result := nil;
983end;
984
985function TPascalParser.ParseTypeRecord(TypeList: TTypeList; Name: string
986 ): TType;
987type
988 TSectionType = (stVar, stType, stConst);
989var
990 Visibility: TTypeVisibility;
991 SectionType: TSectionType;
992begin
993 if NextToken = 'record' then begin
994 Expect('record');
995 SectionType := stVar;
996 Visibility := tvPublic;
997 Result := TTypeRecord.Create;
998 TTypeRecord(Result).Parent := TypeList;
999 TTypeRecord(Result).CommonBlock.Parent := TypeList.Parent;
1000 TType(Result).Name := Name;
1001 while (NextToken <> 'end') and (NextTokenType <> ttEndOfFile) do begin
1002 if NextToken = 'public' then begin
1003 Expect('public');
1004 Visibility := tvPublic;
1005 end else
1006 if NextToken = 'private' then begin
1007 Expect('private');
1008 Visibility := tvPrivate;
1009 end else
1010 if NextToken = 'published' then begin
1011 Expect('published');
1012 Visibility := tvPublished;
1013 end else
1014 if NextToken = 'protected' then begin
1015 Expect('protected');
1016 Visibility := tvProtected;
1017 end else
1018 if NextToken = 'var' then begin
1019 SectionType := stVar;
1020 ParseVariableList(TTypeRecord(Result).CommonBlock.Variables, True);
1021 end else
1022 if NextToken = 'const' then begin
1023 SectionType := stConst;
1024 ParseConstantList(TTypeRecord(Result).CommonBlock.Constants, True)
1025 end else
1026 if NextToken = 'type' then begin
1027 SectionType := stType;
1028 ParseTypeList(TTypeRecord(Result).CommonBlock.Types, True, '=');
1029 end else
1030 if NextToken = 'procedure' then
1031 ParseFunctionList(TTypeRecord(Result).CommonBlock.Functions, True)
1032 else if NextToken = 'function' then
1033 ParseFunctionList(TTypeRecord(Result).CommonBlock.Functions, True)
1034 else begin
1035 if SectionType = stVar then begin
1036 if IsIdentificator(NextToken) then
1037 ParseVariable(TTypeRecord(Result).CommonBlock.Variables, True)
1038 else ReadToken;
1039 //TTypeRecord(Result).CommonBlock.Types.Add(ParseType(TypeList, True, ':'));
1040 //TType(TTypeRecord(Result).CommonBlock.Types.Last).Visibility := Visibility;
1041 end
1042 else if SectionType = stConst then
1043 ParseConstant(TTypeRecord(Result).CommonBlock.Constants, True)
1044 else if SectionType = stType then
1045 ParseType(TTypeRecord(Result).CommonBlock.Types, True, '=');
1046 end;
1047 end;
1048 Expect('end');
1049 end else Result := nil;
1050end;
1051
1052function TPascalParser.ParseTypeClass(TypeList: TTypeList; Name: string
1053 ): TType;
1054begin
1055 if NextToken = 'class' then begin
1056 Expect('class');
1057 Result := TTypeClass.Create;
1058 TTypeClass(Result).Parent := TypeList;
1059 TTypeClass(Result).Name := Name;
1060 if NextToken <> ';' then begin
1061 while (NextToken <> 'end') and (NextTokenType <> ttEndOfFile) do
1062 begin
1063 TTypeClass(Result).Items.Add(ParseType(TypeList, True, ':'));
1064 Expect(';');
1065 end;
1066 Expect('end');
1067 end;
1068 end else Result := nil;
1069end;
1070
1071function TPascalParser.ParseTypeArray(TypeList: TTypeList; Name: string
1072 ): TType;
1073var
1074 UseName: string;
1075 UseType: TType;
1076begin
1077 if NextToken = 'array' then begin
1078 Expect('array');
1079 Result := TTypeArray.Create;
1080 TTypeArray(Result).Parent := TypeList;
1081 TType(Result).Name := Name;
1082 if NextToken = '[' then begin
1083 Expect('[');
1084 UseName := NextToken;
1085 if NextTokenType = ttIdentifier then begin
1086 UseType := TypeList.Parent.Types.Search(UseName);
1087 if not Assigned(TTypeArray(Result).IndexType) then
1088 ErrorMessage(SUndefinedType, [UseName], -1) else
1089 TTypeArray(Result).IndexType := UseType;
1090 end else
1091 if NextTokenType = ttConstantNumber then begin
1092 UseType := ParseTypeSubRange(TypeList, Name);
1093 if not Assigned(UseType) then begin
1094 ErrorMessage(SInvalidConstruction, [], -1);
1095 end;
1096 end;
1097 Expect(']');
1098 end;
1099 Expect('of');
1100 UseName := NextToken;
1101 TTypeArray(Result).ItemType := ParseType(TypeList, False);
1102 if not Assigned(TTypeArray(Result).ItemType) then
1103 ErrorMessage(SUndefinedType, [UseName], -1);
1104 end else Result := nil;
1105end;
1106
1107function TPascalParser.ParseTypeSubRange(TypeList: TTypeList; Name: string
1108 ): TType;
1109var
1110 UseName: string;
1111begin
1112 if NextTokenType = ttConstantString then begin
1113 Result := TTypeSubRange.Create;
1114 TTypeSubRange(Result).Bottom := ReadToken;
1115 Expect('..');
1116 TTypeSubRange(Result).Top := ReadToken;
1117 end else
1118 if NextTokenType = ttConstantNumber then begin
1119 Result := TTypeSubRange.Create;
1120 TTypeSubRange(Result).Bottom := ReadToken;
1121 Expect('..');
1122 TTypeSubRange(Result).Top := ReadToken;
1123 end else Result := nil;
1124end;
1125
1126constructor TPascalParser.Create;
1127begin
1128 inherited;
1129end;
1130
1131destructor TPascalParser.Destroy;
1132begin
1133 inherited Destroy;
1134end;
1135
1136{ TParserUsedModuleList }
1137
1138function TPascalParser.ParseUses(SourceCode: TUsedModuleList; AExported: Boolean = False): Boolean;
1139var
1140 NewUsedModule: TUsedModule;
1141begin
1142 if NextToken = 'uses' then begin
1143 Expect('uses');
1144 with TUsedModule(SourceCode.Items[SourceCode.Add(TUsedModule.Create)]) do begin
1145 Name := ReadToken;
1146 if NextToken = 'in' then begin
1147 Expect('in');
1148 Location := ReadToken;
1149 end else Location := Name + '.pas';
1150 Module := SourceCode.ParentModule.ParentProgram.Modules.Search(Name);
1151 if not Assigned(Module) then begin
1152 if ParseFile(Name) then begin
1153 Module := SourceCode.ParentModule.ParentProgram.Modules.Search(Name);
1154 Exported := AExported;
1155 end else begin
1156 ErrorMessage(SUnitNotFound, [Name], -2);
1157 SourceCode.Delete(SourceCode.Count - 1);
1158 end;
1159 end;
1160 end;
1161 while NextToken = ',' do begin
1162 Expect(',');
1163 with TUsedModule(SourceCode.Items[SourceCode.Add(TUsedModule.Create)]) do
1164 begin
1165 Name := ReadToken;
1166 if NextToken = 'in' then begin
1167 Expect('in');
1168 Location := ReadToken;
1169 end else Location := Name + '.pas';
1170 Module := SourceCode.ParentModule.ParentProgram.Modules.Search(Name);
1171 if not Assigned(Module) then begin
1172 if not ParseFile(Name) then begin
1173 ErrorMessage(SUnitNotFound, [Name], -2);
1174 SourceCode.Delete(SourceCode.Count - 1);
1175 end;
1176 end;
1177 end;
1178 end;
1179 Expect(';');
1180 Result := True;
1181 end else Result := False;
1182end;
1183
1184
1185end.
1186
Note: See TracBrowser for help on using the repository browser.