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

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