From 0df834ced0dfd977df4db05af767699885ee3fed Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 11:30:11 +0200 Subject: [PATCH 01/42] #220, #181 Added an explicit anKind attribute containing `type` if there is an explicit type. --- Source/DelphiAST.pas | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 4348e907..551e7ccb 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -140,6 +140,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ExceptionBlockElseBranch; override; procedure ExceptionHandler; override; procedure ExceptionVariable; override; + procedure ExplicitType; override; //#220+#181 procedure ExportedHeading; override; procedure ExportsClause; override; procedure ExportsElement; override; @@ -308,7 +309,7 @@ TStringStreamHelper = class helper for TStringStream type TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atClassOf, atClass, atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric, - atOut, atPointer, atName, atString, atSubRange, atVar); + atOut, atPointer, atName, atString, atSubRange, atVar, atType {#220+#181-explicit type}); var AttributeValues: array[TAttributeValue] of string; @@ -1258,6 +1259,12 @@ procedure TPasSyntaxTreeBuilder.ExceptionVariable; end; end; +procedure TPasSyntaxTreeBuilder.ExplicitType; //#220+#181 +begin + inherited; + FStack.Peek.SetAttribute(anKind, AttributeValues[atType]); +end; + procedure TPasSyntaxTreeBuilder.ExportedHeading; begin FStack.PushCompoundSyntaxNode(ntMethod); From 2400ab94fa555c9013957b4cf7f2b55e6ccbf585 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 11:37:44 +0200 Subject: [PATCH 02/42] #221, record type params in the name Record type params (and other parts of the name explicitly in subnodes. Still record the full name in an attribute. --- Source/DelphiAST.Classes.pas | 7 +++- Source/DelphiAST.pas | 74 ++++++++++++++++-------------------- 2 files changed, 38 insertions(+), 43 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 183c8eb9..af7fb36d 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -52,7 +52,7 @@ TSyntaxNode = class function AddChild(Node: TSyntaxNode): TSyntaxNode; overload; function AddChild(Typ: TSyntaxNodeType): TSyntaxNode; overload; procedure DeleteChild(Node: TSyntaxNode); - procedure ExtractChild(Node: TSyntaxNode); + function ExtractChild(Node: TSyntaxNode): TSyntaxNode; function FindNode(Typ: TSyntaxNodeType): TSyntaxNode; @@ -66,6 +66,7 @@ TSyntaxNode = class property Col: Integer read FCol write FCol; property Line: Integer read FLine write FLine; property FileName: string read FFileName write FFileName; + property Attribute[const Key: TAttributeName]: string read GetAttribute write SetAttribute; end; TCompoundSyntaxNode = class(TSyntaxNode) @@ -418,13 +419,15 @@ constructor TSyntaxNode.Create(Typ: TSyntaxNodeType); FTyp := Typ; end; -procedure TSyntaxNode.ExtractChild(Node: TSyntaxNode); +function TSyntaxNode.ExtractChild(Node: TSyntaxNode): TSyntaxNode; var i: integer; begin + Result:= nil; //do not allow undefined result for i := 0 to High(FChildNodes) do if FChildNodes[i] = Node then begin + Result:= Node; if i < High(FChildNodes) then Move(FChildNodes[i + 1], FChildNodes[i], SizeOf(TSyntaxNode) * (Length(FChildNodes) - i - 1)); SetLength(FChildNodes, High(FChildNodes)); diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 551e7ccb..fcf7950f 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -1466,49 +1466,41 @@ procedure TPasSyntaxTreeBuilder.FunctionMethodName; inherited; end; -procedure TPasSyntaxTreeBuilder.FunctionProcedureName; +procedure TPasSyntaxTreeBuilder.FunctionProcedureName; //#221 record method type params explicitly, keep the full name as well. var - ChildNode, NameNode, TypeParam, TypeNode, Temp: TSyntaxNode; - FullName, TypeParams: string; -begin - FStack.Push(ntName); - NameNode := FStack.Peek; - try - inherited; - for ChildNode in NameNode.ChildNodes do - begin - if ChildNode.Typ = ntTypeParams then - begin - TypeParams := ''; - - for TypeParam in ChildNode.ChildNodes do - begin - TypeNode := TypeParam.FindNode(ntType); - if Assigned(TypeNode) then - begin - if TypeParams <> '' then - TypeParams := TypeParams + ','; - TypeParams := TypeParams + TypeNode.GetAttribute(anName); - end; - end; - - FullName := FullName + '<' + TypeParams + '>'; - Continue; - end; - - if FullName <> '' then - FullName := FullName + '.'; - FullName := FullName + TValuedSyntaxNode(ChildNode).Value; - end; - finally - FStack.Pop; - Temp := FStack.Peek; - DoHandleString(FullName); - Temp.SetAttribute(anName, FullName); - Temp.DeleteChild(NameNode); - end; + ChildNode, NameNode, TypeParam, TypeNode, Temp, TypeParams: TSyntaxNode; + FullName, TypeParamStr, Dot, Comma: string; + HasTypeParams: boolean; +begin + Temp:= FStack.Peek; + NameNode:= FStack.Push(ntName); + try + inherited; + finally + FStack.Pop; + end; + //Traverse the name node and reconstruct the full name + Assert(NameNode.HasChildren); + Dot:= ''; + for ChildNode in NameNode.ChildNodes do begin + case ChildNode.Typ of + ntName: begin + FullName:= Fullname + Dot + ChildNode.Attribute[anName]; + Dot:= '.'; + end; {ntName} + ntTypeParams: begin + Comma:= ''; + Fullname:= Fullname + '<'; + for TypeParam in ChildNode.ChildNodes do begin + FullName:= FullName + Comma + TypeParam.FindNode(ntType).Attribute[anName]; + Comma:= ','; + end; {for} + Fullname:= Fullname + '>'; + end; {ntTypeParams:} + end; {case} + end; {for ChildNode} + NameNode.SetAttribute(anName, FullName); end; - procedure TPasSyntaxTreeBuilder.GotoStatement; begin FStack.Push(ntGoto); From c26af5a41fde732cd7cf1d902b8ea62a84edc484 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 11:43:52 +0200 Subject: [PATCH 03/42] #222, use the anName attribute to store names exclusively Store all names in a ntName node with a anName attribute for consistency. A name is not a value, so it should not be stored in a value property. --- Source/DelphiAST.pas | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index fcf7950f..063805c1 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -579,7 +579,8 @@ procedure TPasSyntaxTreeBuilder.AttributeArgumentExpression; procedure TPasSyntaxTreeBuilder.AttributeArgumentName; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName,Lexer.Token); //#222 inherited; end; @@ -595,7 +596,8 @@ procedure TPasSyntaxTreeBuilder.AttributeArguments; procedure TPasSyntaxTreeBuilder.AttributeName; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 inherited; end; @@ -976,7 +978,8 @@ procedure TPasSyntaxTreeBuilder.CallInheritedConstantExpression; procedure TPasSyntaxTreeBuilder.ConstantName; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 inherited; end; @@ -1251,7 +1254,8 @@ procedure TPasSyntaxTreeBuilder.ExceptionHandler; procedure TPasSyntaxTreeBuilder.ExceptionVariable; begin FStack.Push(ntVariable); - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 try inherited; finally @@ -1371,7 +1375,8 @@ procedure TPasSyntaxTreeBuilder.ExternalDirective; procedure TPasSyntaxTreeBuilder.FieldName; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 inherited; end; @@ -1462,7 +1467,8 @@ procedure TPasSyntaxTreeBuilder.FunctionHeading; procedure TPasSyntaxTreeBuilder.FunctionMethodName; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 inherited; end; @@ -1755,7 +1761,8 @@ procedure TPasSyntaxTreeBuilder.Number; procedure TPasSyntaxTreeBuilder.ObjectNameOfMethod; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 inherited; end; @@ -1806,7 +1813,8 @@ procedure TPasSyntaxTreeBuilder.ParameterFormal; procedure TPasSyntaxTreeBuilder.ParameterName; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 inherited; end; @@ -2549,7 +2557,8 @@ procedure TPasSyntaxTreeBuilder.VarDeclaration; procedure TPasSyntaxTreeBuilder.VarName; begin - FStack.AddValuedChild(ntName, Lexer.Token); + //FStack.AddValuedChild(ntName, Lexer.Token); + FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 inherited; end; From 12ca8870f008816076db837443e324faa9f8f108 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 11:46:47 +0200 Subject: [PATCH 04/42] #223 Except else <> if else An except-else has very different semantics from an if-else. It needs a specialized node type. --- Source/DelphiAST.Consts.pas | 2 ++ Source/DelphiAST.pas | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 8532446b..46518d0c 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -41,6 +41,7 @@ interface ntEnum, ntEqual, ntExcept, + ntExceptElse, ntExceptionHandler, ntExports, ntExpression, @@ -194,6 +195,7 @@ interface 'enum', 'equal', 'except', + 'exceptelse', 'exceptionhandler', 'exports', 'expression', diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 063805c1..4d63b6b0 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -1233,7 +1233,7 @@ procedure TPasSyntaxTreeBuilder.ExceptBlock; procedure TPasSyntaxTreeBuilder.ExceptionBlockElseBranch; begin - FStack.Push(ntElse); + FStack.Push(ntExceptElse); //#223 try inherited; finally From 6f33800e43ff6ab8395cb3b52fa4d1c71df3d0ac Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 11:51:25 +0200 Subject: [PATCH 05/42] #226 Add support for forwarded `object` types Both class and object can be declared forward. --- Source/DelphiAST.pas | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 4d63b6b0..34ca1ce2 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -183,6 +183,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure NotOp; override; procedure NilToken; override; procedure Number; override; + procedure ObjectForward; override; procedure ObjectNameOfMethod; override; procedure OutParameter; override; procedure ParameterFormal; override; @@ -309,7 +310,8 @@ TStringStreamHelper = class helper for TStringStream type TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atClassOf, atClass, atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric, - atOut, atPointer, atName, atString, atSubRange, atVar, atType {#220+#181-explicit type}); + atOut, atPointer, atName, atString, atSubRange, atVar, atType, {#220+#181-explicit type} + atObject {#226}); var AttributeValues: array[TAttributeValue] of string; @@ -809,8 +811,9 @@ procedure TPasSyntaxTreeBuilder.ClassField; procedure TPasSyntaxTreeBuilder.ClassForward; begin - FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); - inherited ClassForward; + FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); //#226 + FStack.Peek.SetAttribute(anType, AttributeValues[atClass]); + inherited; end; procedure TPasSyntaxTreeBuilder.ClassFunctionHeading; @@ -1759,6 +1762,13 @@ procedure TPasSyntaxTreeBuilder.Number; inherited; end; +procedure TPasSyntaxTreeBuilder.ObjectForward; +begin + FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); //#226 + FStack.Peek.SetAttribute(anType, AttributeValues[atObject]); + inherited; +end; + procedure TPasSyntaxTreeBuilder.ObjectNameOfMethod; begin //FStack.AddValuedChild(ntName, Lexer.Token); From 8a9b20ce6b5989db1b6d6b43de5089fe1903c58d Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 11:54:08 +0200 Subject: [PATCH 06/42] #227 Labeled statement does not register --- Source/DelphiAST.Consts.pas | 2 ++ Source/DelphiAST.pas | 13 +++++++++++++ 2 files changed, 15 insertions(+) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 46518d0c..308ad9c8 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -72,6 +72,7 @@ interface ntInterface, ntIs, ntLabel, + ntLabeledStatement, ntLHS, ntLiteral, ntLower, @@ -226,6 +227,7 @@ interface 'interface', 'is', 'label', + 'labeledstatement', 'lhs', 'literal', 'lower', diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 34ca1ce2..cf14a9f0 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -175,6 +175,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure InterfaceGUID; override; procedure InterfaceSection; override; procedure InterfaceType; override; + procedure LabeledStatement; override; procedure LabelId; override; procedure MainUsesClause; override; procedure MainUsedUnitStatement; override; @@ -1645,6 +1646,18 @@ procedure TPasSyntaxTreeBuilder.InterfaceType; end; end; +procedure TPasSyntaxTreeBuilder.LabeledStatement; +var + Temp: TSyntaxNode; +begin + FStack.PushValuedNode(ntLabeledStatement, Lexer.Token); //#227 + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.LabelId; begin FStack.AddValuedChild(ntLabel, Lexer.Token); From b7ec406de735feab2217d492e814193074b5995b Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 11:57:20 +0200 Subject: [PATCH 07/42] #228 differentiate between const and resourcestring section --- Source/DelphiAST.pas | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index cf14a9f0..8add30ae 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -1054,11 +1054,11 @@ procedure TPasSyntaxTreeBuilder.ConstSection; begin ConstSect := TSyntaxNode.Create(ntConstants); try - FStack.Push(ntConstants); + FStack.Push(ntConstants).SetAttribute(anKind, Lexer.Token); //#228 FStack.Push(ConstSect); try - inherited ConstSection; + inherited; finally FStack.Pop; end; From 496edbb0719453e890a1558fa34f7e3000a9ce04 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 12:00:56 +0200 Subject: [PATCH 08/42] #229 Parse object type correctly --- Source/DelphiAST.pas | 51 ++++++++++++++++++++++++++++ Source/SimpleParser/SimpleParser.pas | 4 ++- 2 files changed, 54 insertions(+), 1 deletion(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 8add30ae..7c51274d 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -184,8 +184,10 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure NotOp; override; procedure NilToken; override; procedure Number; override; + procedure ObjectField; override; procedure ObjectForward; override; procedure ObjectNameOfMethod; override; + procedure ObjectType; override; procedure OutParameter; override; procedure ParameterFormal; override; procedure ParameterName; override; @@ -1775,6 +1777,45 @@ procedure TPasSyntaxTreeBuilder.Number; inherited; end; +procedure TPasSyntaxTreeBuilder.ObjectField; +var + Fields, Temp: TSyntaxNode; + Field, TypeInfo, TypeArgs: TSyntaxNode; +begin + Fields := TSyntaxNode.Create(ntFields); //#229 + try + FStack.Push(Fields); + try + inherited; + finally + FStack.Pop; + end; + + TypeInfo := Fields.FindNode(ntType); + TypeArgs := Fields.FindNode(ntTypeArgs); + for Field in Fields.ChildNodes do + begin + if Field.Typ <> ntName then + Continue; + + Temp := FStack.Push(ntField); + try + Temp.AssignPositionFrom(Field); + + FStack.AddChild(Field.Clone); + TypeInfo := TypeInfo.Clone; + if Assigned(TypeArgs) then + TypeInfo.AddChild(TypeArgs.Clone); + FStack.AddChild(TypeInfo); + finally + FStack.Pop; + end; + end; + finally + Fields.Free; + end; +end; + procedure TPasSyntaxTreeBuilder.ObjectForward; begin FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); //#226 @@ -1789,6 +1830,16 @@ procedure TPasSyntaxTreeBuilder.ObjectNameOfMethod; inherited; end; +procedure TPasSyntaxTreeBuilder.ObjectType; +begin + FStack.Push(ntType).SetAttribute(anType, AttributeValues[atObject]); //#229 + try + inherited; + finally + MoveMembersToVisibilityNodes(FStack.Pop); + end; +end; + procedure TPasSyntaxTreeBuilder.DoOnComment(Sender: TObject; const Text: string); var Node: TCommentNode; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index c39f44f2..60cb1b35 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -4007,7 +4007,9 @@ procedure TmwSimplePasPar.ObjectVisibility; procedure TmwSimplePasPar.ObjectField; begin - IdentifierList; + if TokenID = ptSquareOpen then //#229 + CustomAttribute; + FieldNameList; Expected(ptColon); TypeKind; TypeDirective; From 0425ee942d714f2432621c4ac5635824edb723d2 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 13:34:00 +0200 Subject: [PATCH 09/42] #225, optimization: use a set to keep track of attributes in use by a node --- Source/DelphiAST.Classes.pas | 32 +++++++++++++++++++++----------- Source/DelphiAST.Consts.pas | 2 ++ 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index af7fb36d..66480069 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -31,12 +31,13 @@ TSyntaxNode = class FFileName: string; function GetHasChildren: Boolean; function GetHasAttributes: Boolean; - function TryGetAttributeEntry(const Key: TAttributeName; var AttributeEntry: PAttributeEntry): boolean; + function TryGetAttributeEntry(const Key: TAttributeName; out AttributeEntry: PAttributeEntry): boolean; protected FAttributes: TArray; FChildNodes: TArray; FTyp: TSyntaxNodeType; FParentNode: TSyntaxNode; + FAttributesInUse: TAttributeNames; public constructor Create(Typ: TSyntaxNodeType); destructor Destroy; override; @@ -350,6 +351,12 @@ class procedure TExpressionTools.RawNodeListToTree(RawParentNode: TSyntaxNode; R { TSyntaxNode } +procedure TSyntaxNode.ClearAttributes; +begin + SetLength(FAttributes, 0); + FAttributesInUse:= []; +end; + procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: string); var AttributeEntry: PAttributeEntry; @@ -363,22 +370,28 @@ procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: strin AttributeEntry^.Key := Key; end; AttributeEntry^.Value := Value; + if (Value = '') then Exclude(FAttributesInUse, Key) + else Include(FAttributesInUse, Key); end; -function TSyntaxNode.TryGetAttributeEntry(const Key: TAttributeName; var AttributeEntry: PAttributeEntry): boolean; +function TSyntaxNode.TryGetAttributeEntry(const Key: TAttributeName; out AttributeEntry: PAttributeEntry): boolean; var i: integer; begin - for i := 0 to High(FAttributes) do + Result:= false; + if not(Key in FAttributesInUse) then begin + //Do not allow the AttributeEntry to be undefined. + AttributeEntry:= nil; + end else for i := 0 to High(FAttributes) do begin if FAttributes[i].Key = Key then begin AttributeEntry := @FAttributes[i]; Exit(True); end; - - Result := False; + end; end; + function TSyntaxNode.AddChild(Node: TSyntaxNode): TSyntaxNode; begin Assert(Assigned(Node)); @@ -410,6 +423,7 @@ function TSyntaxNode.Clone: TSyntaxNode; end; Result.FAttributes := Copy(FAttributes); + Result.FAttributesInUse:= FAttributesInUse; Result.AssignPositionFrom(Self); end; @@ -484,12 +498,8 @@ function TSyntaxNode.HasAttribute(const Key: TAttributeName): Boolean; var AttributeEntry: PAttributeEntry; begin - Result := TryGetAttributeEntry(Key, AttributeEntry); -end; - -procedure TSyntaxNode.ClearAttributes; -begin - SetLength(FAttributes, 0); + //Result := TryGetAttributeEntry(Key, AttributeEntry); + Result:= Key in FAttributesInUse; end; procedure TSyntaxNode.AssignPositionFrom(const Node: TSyntaxNode); diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 308ad9c8..9ae6cc23 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -157,6 +157,8 @@ interface anInline ); + TAttributeNames = set of TAttributeName; + const SyntaxNodeNames: array [TSyntaxNodeType] of string = ( 'unknown', From 76e4e81894ca3ead50de6312aa2758426a03d8f5 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 13:47:18 +0200 Subject: [PATCH 10/42] #224 Optimization fetch correct operator record in O(1) time TOperators.GetItem uses a for loop to extract the correct OperatorsInfo record. This is inefficient. If you reorder the TSyntaxNodeType enumeration so that the operators are in the same order as OperatorsInfo then we can use a simple in statement. --- Source/DelphiAST.Classes.pas | 4 +- Source/DelphiAST.Consts.pas | 330 ++++++++++++++++++----------------- 2 files changed, 169 insertions(+), 165 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 66480069..41af0216 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -167,9 +167,7 @@ class function TOperators.GetItem(Typ: TSyntaxNodeType): TOperatorInfo; var i: Integer; begin - for i := 0 to High(OperatorsInfo) do - if OperatorsInfo[i].Typ = Typ then - Exit(OperatorsInfo[i]); + if (Typ in [ntAddr..ntIs]) then Exit(OperatorsInfo[Ord(Typ) - Ord(ntAddr)]); //#224 end; class function TOperators.IsOpName(Typ: TSyntaxNodeType): Boolean; diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 9ae6cc23..3c006b0f 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -4,20 +4,45 @@ interface type TSyntaxNodeType = ( - ntUnknown, - ntAdd, ntAddr, - ntAlignmentParam, + ntDeref, + ntGeneric, + ntIndexed, + ntDot, + ntCall, + ntUnaryMinus, + ntNot, + ntMul, + ntFDiv, + ntDiv, + ntMod, ntAnd, + ntShl, + ntShr, + ntAs, + ntAdd, + ntSub, + ntOr, + ntXor, + ntEqual, + ntNotEqual, + ntLower, + ntGreater, + ntLowerEqual, + ntGreaterEqual, + ntIn, + ntIs, + + ntUnknown, + ntAlignmentParam, ntAnonymousMethod, + ntAnonymousType, ntArguments, - ntAs, ntAssign, ntAt, ntAttribute, ntAttributes, ntBounds, - ntCall, ntCase, ntCaseElse, ntCaseLabel, @@ -30,16 +55,12 @@ interface ntConstructorConstraint, ntContains, ntDefault, - ntDeref, ntDimension, - ntDiv, - ntDot, ntDownTo, ntElement, ntElse, ntEmptyStatement, ntEnum, - ntEqual, ntExcept, ntExceptElse, ntExceptionHandler, @@ -47,45 +68,31 @@ interface ntExpression, ntExpressions, ntExternal, - ntFDiv, ntField, ntFields, ntFinalization, ntFinally, ntFor, ntFrom, - ntGeneric, ntGoto, - ntGreater, - ntGreaterEqual, ntGuid, ntHelper, ntIdentifier, ntIf, ntImplementation, ntImplements, - ntIn, ntIndex, - ntIndexed, ntInherited, ntInitialization, ntInterface, - ntIs, ntLabel, ntLabeledStatement, ntLHS, ntLiteral, - ntLower, - ntLowerEqual, ntMessage, ntMethod, - ntMod, - ntMul, ntName, ntNamedArgument, - ntNotEqual, - ntNot, - ntOr, ntPackage, ntParameter, ntParameters, @@ -108,13 +115,10 @@ interface ntRoundClose, ntRoundOpen, ntSet, - ntShl, - ntShr, ntStatement, ntStatements, ntStrictPrivate, ntStrictProtected, - ntSub, ntSubrange, ntThen, ntTo, @@ -128,8 +132,6 @@ interface ntValue, ntVariable, ntVariables, - ntXor, - ntUnaryMinus, ntUnit, ntUses, ntWhile, @@ -141,6 +143,8 @@ interface ntSlashesComment ); + TSyntaxNodeTypes = set of TSyntaxNodeType; + TAttributeName = ( anType, anClass, @@ -161,141 +165,143 @@ interface const SyntaxNodeNames: array [TSyntaxNodeType] of string = ( - 'unknown', - 'add', - 'addr', - 'alignmentparam', - 'and', - 'anonymousmethod', - 'arguments', - 'as', - 'assign', - 'at', - 'attribute', - 'attributes', - 'bounds', - 'call', - 'case', - 'caseelse', - 'caselabel', - 'caselabels', - 'caseselector', - 'classconstraint', - 'constant', - 'constants', - 'constraints', - 'constructorconstraint', - 'contains', - 'default', - 'deref', - 'dimension', - 'div', - 'dot', - 'downto', - 'element', - 'else', - 'emptystatement', - 'enum', - 'equal', - 'except', - 'exceptelse', - 'exceptionhandler', - 'exports', - 'expression', - 'expressions', - 'external', - 'fdiv', - 'field', - 'fields', - 'finalization', - 'finally', - 'for', - 'from', - 'generic', - 'goto', - 'greater', - 'greaterequal', - 'guid', - 'helper', - 'identifier', - 'if', - 'implementation', - 'implements', - 'in', - 'index', - 'indexed', - 'inherited', - 'initialization', - 'interface', - 'is', - 'label', - 'labeledstatement', - 'lhs', - 'literal', - 'lower', - 'lowerequal', - 'message', - 'method', - 'mod', - 'mul', - 'name', - 'namedargument', - 'notequal', - 'not', - 'or', - 'package', - 'parameter', - 'parameters', - 'path', - 'positionalargument', - 'protected', - 'private', - 'property', - 'public', - 'published', - 'raise', - 'read', - 'recordconstraint', - 'repeat', - 'requires', - 'resolutionclause', - 'resourcestring', - 'returntype', - 'rhs', - 'roundclose', - 'roundopen', - 'set', - 'shl', - 'shr', - 'statement', - 'statements', - 'strictprivate', - 'strictprotected', - 'sub', - 'subrange', - 'then', - 'to', - 'try', - 'type', - 'typeargs', - 'typedecl', - 'typeparam', - 'typeparams', - 'typesection', - 'value', - 'variable', - 'variables', - 'xor', - 'unaryminus', - 'unit', - 'uses', - 'while', - 'with', - 'write', + 'addr', //ntAddr, + 'deref', //ntDeref, + 'generic', //ntGeneric, + 'indexed', //ntIndexed, + 'dot', //ntDot, + 'call', //ntCall, + 'unaryMinus', //ntUnaryMinus, + 'not', //ntNot, + 'mul', //ntMul, + 'fdiv', //ntFDiv, + 'div', //ntDiv, + 'mod', //ntMod, + 'and', //ntAnd, + 'shl', //ntShl, + 'shr', //ntShr, + 'as', //ntAs, + 'add', //ntAdd, + 'sub', //ntSub, + 'or', //ntOr, + 'xor', //ntXor, + 'equal', //ntEqual, + 'notEqual', //ntNotEqual, + 'lower', //ntLower, + 'greater', //ntGreater, + 'lowerEqual', //ntLowerEqual, + 'greaterEqual', //ntGreaterEqual, + 'in', //ntIn, + 'is', //ntIs, + + 'unknown', //ntUnknown, + 'alignmentparam', //ntAlignmentParam, + 'anonymousmethod', //ntAnonymousMethod, + 'anonymoustype', //ntAnonymousType, + 'arguments', //ntArguments, + 'assign', //ntAssign, + 'at', //ntAt, + 'attribute', //ntAttribute, + 'attributes', //ntAttributes, + 'bounds', //ntBounds, + 'case', //ntCase, + 'caseelse', //ntCaseElse, + 'caselabel', //ntCaseLabel, + 'caselabels', //ntCaseLabels, + 'caseselector', //ntCaseSelector, + 'classconstraint', //ntClassConstraint, + 'constant', //ntConstant, + 'constants', //ntConstants, + 'constraints', //ntConstraints, + 'constructorconstraint', //ntConstructorConstraint, + 'contains', //ntContains, + 'default', //ntDefault, + 'dimension', //ntDimension, + 'downto', //ntDownTo, + 'element', //ntElement, + 'else', //ntElse, + 'emptystatement', //ntEmptyStatement, + 'enum', //ntEnum, + 'except', //ntExcept, + 'exceptelse', //ntExceptElse, + 'exceptionhandler', //ntExceptionHandler, + 'exports', //ntExports, + 'expression', //ntExpression, + 'expressions', //ntExpressions, + 'external', //ntExternal, + 'field', //ntField, + 'fields', //ntFields, + 'finalization', //ntFinalization, + 'finally', //ntFinally, + 'for', //ntFor, + 'from', //ntFrom, + 'goto', //ntGoto, + 'guid', //ntGuid, + 'helper', //ntHelper, + 'identifier', //ntIdentifier, + 'if', //ntIf, + 'implementation', //ntImplementation, + 'implements', //ntImplements, + 'index', //ntIndex, + 'inherited', //ntInherited, + 'initialization', //ntInitialization, + 'interface', //ntInterface, + 'label', //ntLabel, + 'labeledstatement', //ntLabeledStatement, + 'lhs', //ntLHS, + 'literal', //ntLiteral, + 'message', //ntMessage, + 'method', //ntMethod, + 'name', //ntName, + 'namedargument', //ntNamedArgument, + 'package', //ntPackage, + 'parameter', //ntParameter, + 'parameters', //ntParameters, + 'path', //ntPath, + 'positionalargument', //ntPositionalArgument, + 'protected', //ntProtected, + 'private', //ntPrivate, + 'property', //ntProperty, + 'public', //ntPublic, + 'published', //ntPublished, + 'raise', //ntRaise, + 'read', //ntRead, + 'recordconstraint', //ntRecordConstraint, + 'repeat', //ntRepeat, + 'requires', //ntRequires, + 'resolutionclause', //ntResolutionClause, + 'resourcestring', //ntResourceString, + 'returntype', //ntReturnType, + 'rhs', //ntRHS, + 'roundclose', //ntRoundClose, + 'roundopen', //ntRoundOpen, + 'set', //ntSet, + 'statement', //ntStatement, + 'statements', //ntStatements, + 'strictprivate', //ntStrictPrivate, + 'strictprotected', //ntStrictProtected, + 'subrange', //ntSubrange, + 'then', //ntThen, + 'to', //ntTo, + 'try', //ntTry, + 'type', //ntType, + 'typeargs', //ntTypeArgs, + 'typedecl', //ntTypeDecl, + 'typeparam', //ntTypeParam, + 'typeparams', //ntTypeParams, + 'typesection', //ntTypeSection, + 'value', //ntValue, + 'variable', //ntVariable, + 'variables', //ntVariables, + 'unit', //ntUnit, + 'uses', //ntUses, + 'while', //ntWhile, + 'with', //ntWith, + 'write', //ntWrite, - 'ansicomment', - 'borlandcomment', - 'slashescomment' + 'ansicomment', //ntAnsiComment, + 'borlandcomment', //ntBorComment, + 'slashescomment' //ntSlashesComment ); AttributeNameStrings: array[TAttributeName] of string = ( From 8ad0174612a6fc2ca76acbf2fa1f33b5cc46865f Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 14:00:48 +0200 Subject: [PATCH 11/42] #166 Forward declaration fixes Methods can be declared forward in the implementation section. Also the semicolon after forward is optional as per Turbo Pascal legacy. --- Source/DelphiAST.pas | 9 +++++++++ Source/SimpleParser/SimpleParser.pas | 3 ++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 7c51274d..06007f02 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -158,6 +158,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ForStatementFrom; override; procedure ForStatementIn; override; procedure ForStatementTo; override; + procedure ForwardDeclaration; override; procedure FunctionHeading; override; procedure FunctionMethodName; override; procedure FunctionProcedureName; override; @@ -1465,6 +1466,14 @@ procedure TPasSyntaxTreeBuilder.ForStatementTo; end; end; +procedure TPasSyntaxTreeBuilder.ForwardDeclaration; +begin + if FStack.Peek.ParentNode.Typ = ntImplementation then begin //#166 + FStack.Peek.SetAttribute(anForwarded, 'true'); + end; + inherited; +end; + procedure TPasSyntaxTreeBuilder.FunctionHeading; begin FStack.Peek.SetAttribute(anKind, AttributeValues[atFunction]); diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 60cb1b35..0815f521 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -613,8 +613,9 @@ constructor ESyntaxError.CreatePos(const Msg: string; aPosXY: TTokenPoint); procedure TmwSimplePasPar.ForwardDeclaration; begin + //semicolon is optional after forward directive. NextToken; - Semicolon; + if TokenID = ptSemiColon then NextToken; //#166 end; procedure TmwSimplePasPar.ObjectProperty; From 09b4d927de9dcde26dd7a91685b44134eb845beb Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 3 Oct 2017 14:30:48 +0200 Subject: [PATCH 12/42] #232 SyntaxNodeNames should be automatically derived from SyntaxNodeTypes The cool thing about this fix is that no changes are need to the rest of the code and it runs with the same performance as the old code. --- Source/DelphiAST.Consts.pas | 309 ++++++++++++++++++++---------------- 1 file changed, 171 insertions(+), 138 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 3c006b0f..7df16a09 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -163,147 +163,162 @@ interface TAttributeNames = set of TAttributeName; -const - SyntaxNodeNames: array [TSyntaxNodeType] of string = ( - 'addr', //ntAddr, - 'deref', //ntDeref, - 'generic', //ntGeneric, - 'indexed', //ntIndexed, - 'dot', //ntDot, - 'call', //ntCall, - 'unaryMinus', //ntUnaryMinus, - 'not', //ntNot, - 'mul', //ntMul, - 'fdiv', //ntFDiv, - 'div', //ntDiv, - 'mod', //ntMod, - 'and', //ntAnd, - 'shl', //ntShl, - 'shr', //ntShr, - 'as', //ntAs, - 'add', //ntAdd, - 'sub', //ntSub, - 'or', //ntOr, - 'xor', //ntXor, - 'equal', //ntEqual, - 'notEqual', //ntNotEqual, - 'lower', //ntLower, - 'greater', //ntGreater, - 'lowerEqual', //ntLowerEqual, - 'greaterEqual', //ntGreaterEqual, - 'in', //ntIn, - 'is', //ntIs, +type + TSyntaxNodeNames = record + strict private + class var FData: array[TSyntaxNodeType] of string; + function GetItem(const index: TSyntaxNodeType): string; inline; + class constructor Init; + public + property Items[const index: TSyntaxNodeType]: string read GetItem; default; + end; - 'unknown', //ntUnknown, - 'alignmentparam', //ntAlignmentParam, - 'anonymousmethod', //ntAnonymousMethod, - 'anonymoustype', //ntAnonymousType, - 'arguments', //ntArguments, - 'assign', //ntAssign, - 'at', //ntAt, - 'attribute', //ntAttribute, - 'attributes', //ntAttributes, - 'bounds', //ntBounds, - 'case', //ntCase, - 'caseelse', //ntCaseElse, - 'caselabel', //ntCaseLabel, - 'caselabels', //ntCaseLabels, - 'caseselector', //ntCaseSelector, - 'classconstraint', //ntClassConstraint, - 'constant', //ntConstant, - 'constants', //ntConstants, - 'constraints', //ntConstraints, - 'constructorconstraint', //ntConstructorConstraint, - 'contains', //ntContains, - 'default', //ntDefault, - 'dimension', //ntDimension, - 'downto', //ntDownTo, - 'element', //ntElement, - 'else', //ntElse, - 'emptystatement', //ntEmptyStatement, - 'enum', //ntEnum, - 'except', //ntExcept, - 'exceptelse', //ntExceptElse, - 'exceptionhandler', //ntExceptionHandler, - 'exports', //ntExports, - 'expression', //ntExpression, - 'expressions', //ntExpressions, - 'external', //ntExternal, - 'field', //ntField, - 'fields', //ntFields, - 'finalization', //ntFinalization, - 'finally', //ntFinally, - 'for', //ntFor, - 'from', //ntFrom, - 'goto', //ntGoto, - 'guid', //ntGuid, - 'helper', //ntHelper, - 'identifier', //ntIdentifier, - 'if', //ntIf, - 'implementation', //ntImplementation, - 'implements', //ntImplements, - 'index', //ntIndex, - 'inherited', //ntInherited, - 'initialization', //ntInitialization, - 'interface', //ntInterface, - 'label', //ntLabel, - 'labeledstatement', //ntLabeledStatement, - 'lhs', //ntLHS, - 'literal', //ntLiteral, - 'message', //ntMessage, - 'method', //ntMethod, - 'name', //ntName, - 'namedargument', //ntNamedArgument, - 'package', //ntPackage, - 'parameter', //ntParameter, - 'parameters', //ntParameters, - 'path', //ntPath, - 'positionalargument', //ntPositionalArgument, - 'protected', //ntProtected, - 'private', //ntPrivate, - 'property', //ntProperty, - 'public', //ntPublic, - 'published', //ntPublished, - 'raise', //ntRaise, - 'read', //ntRead, - 'recordconstraint', //ntRecordConstraint, - 'repeat', //ntRepeat, - 'requires', //ntRequires, - 'resolutionclause', //ntResolutionClause, - 'resourcestring', //ntResourceString, - 'returntype', //ntReturnType, - 'rhs', //ntRHS, - 'roundclose', //ntRoundClose, - 'roundopen', //ntRoundOpen, - 'set', //ntSet, - 'statement', //ntStatement, - 'statements', //ntStatements, - 'strictprivate', //ntStrictPrivate, - 'strictprotected', //ntStrictProtected, - 'subrange', //ntSubrange, - 'then', //ntThen, - 'to', //ntTo, - 'try', //ntTry, - 'type', //ntType, - 'typeargs', //ntTypeArgs, - 'typedecl', //ntTypeDecl, - 'typeparam', //ntTypeParam, - 'typeparams', //ntTypeParams, - 'typesection', //ntTypeSection, - 'value', //ntValue, - 'variable', //ntVariable, - 'variables', //ntVariables, - 'unit', //ntUnit, - 'uses', //ntUses, - 'while', //ntWhile, - 'with', //ntWith, - 'write', //ntWrite, +var + SyntaxNodeNames: TSyntaxNodeNames; //for some reason default does not work on class properties. - 'ansicomment', //ntAnsiComment, - 'borlandcomment', //ntBorComment, - 'slashescomment' //ntSlashesComment - ); +//const +// OldSyntaxNodeNames: array [TSyntaxNodeType] of string = ( +// 'addr', //ntAddr, +// 'deref', //ntDeref, +// 'generic', //ntGeneric, +// 'indexed', //ntIndexed, +// 'dot', //ntDot, +// 'call', //ntCall, +// 'unaryMinus', //ntUnaryMinus, +// 'not', //ntNot, +// 'mul', //ntMul, +// 'fdiv', //ntFDiv, +// 'div', //ntDiv, +// 'mod', //ntMod, +// 'and', //ntAnd, +// 'shl', //ntShl, +// 'shr', //ntShr, +// 'as', //ntAs, +// 'add', //ntAdd, +// 'sub', //ntSub, +// 'or', //ntOr, +// 'xor', //ntXor, +// 'equal', //ntEqual, +// 'notEqual', //ntNotEqual, +// 'lower', //ntLower, +// 'greater', //ntGreater, +// 'lowerEqual', //ntLowerEqual, +// 'greaterEqual', //ntGreaterEqual, +// 'in', //ntIn, +// 'is', //ntIs, +// +// 'unknown', //ntUnknown, +// 'alignmentparam', //ntAlignmentParam, +// 'anonymousmethod', //ntAnonymousMethod, +// 'anonymoustype', //ntAnonymousType, +// 'arguments', //ntArguments, +// 'assign', //ntAssign, +// 'at', //ntAt, +// 'attribute', //ntAttribute, +// 'attributes', //ntAttributes, +// 'bounds', //ntBounds, +// 'case', //ntCase, +// 'caseelse', //ntCaseElse, +// 'caselabel', //ntCaseLabel, +// 'caselabels', //ntCaseLabels, +// 'caseselector', //ntCaseSelector, +// 'classconstraint', //ntClassConstraint, +// 'constant', //ntConstant, +// 'constants', //ntConstants, +// 'constraints', //ntConstraints, +// 'constructorconstraint', //ntConstructorConstraint, +// 'contains', //ntContains, +// 'default', //ntDefault, +// 'dimension', //ntDimension, +// 'downto', //ntDownTo, +// 'element', //ntElement, +// 'else', //ntElse, +// 'emptystatement', //ntEmptyStatement, +// 'enum', //ntEnum, +// 'except', //ntExcept, +// 'exceptelse', //ntExceptElse, +// 'exceptionhandler', //ntExceptionHandler, +// 'exports', //ntExports, +// 'expression', //ntExpression, +// 'expressions', //ntExpressions, +// 'external', //ntExternal, +// 'field', //ntField, +// 'fields', //ntFields, +// 'finalization', //ntFinalization, +// 'finally', //ntFinally, +// 'for', //ntFor, +// 'from', //ntFrom, +// 'goto', //ntGoto, +// 'guid', //ntGuid, +// 'helper', //ntHelper, +// 'identifier', //ntIdentifier, +// 'if', //ntIf, +// 'implementation', //ntImplementation, +// 'implements', //ntImplements, +// 'index', //ntIndex, +// 'inherited', //ntInherited, +// 'initialization', //ntInitialization, +// 'interface', //ntInterface, +// 'label', //ntLabel, +// 'labeledstatement', //ntLabeledStatement, +// 'lhs', //ntLHS, +// 'literal', //ntLiteral, +// 'message', //ntMessage, +// 'method', //ntMethod, +// 'name', //ntName, +// 'namedargument', //ntNamedArgument, +// 'package', //ntPackage, +// 'parameter', //ntParameter, +// 'parameters', //ntParameters, +// 'path', //ntPath, +// 'positionalargument', //ntPositionalArgument, +// 'protected', //ntProtected, +// 'private', //ntPrivate, +// 'property', //ntProperty, +// 'public', //ntPublic, +// 'published', //ntPublished, +// 'raise', //ntRaise, +// 'read', //ntRead, +// 'recordconstraint', //ntRecordConstraint, +// 'repeat', //ntRepeat, +// 'requires', //ntRequires, +// 'resolutionclause', //ntResolutionClause, +// 'resourcestring', //ntResourceString, +// 'returntype', //ntReturnType, +// 'rhs', //ntRHS, +// 'roundclose', //ntRoundClose, +// 'roundopen', //ntRoundOpen, +// 'set', //ntSet, +// 'statement', //ntStatement, +// 'statements', //ntStatements, +// 'strictprivate', //ntStrictPrivate, +// 'strictprotected', //ntStrictProtected, +// 'subrange', //ntSubrange, +// 'then', //ntThen, +// 'to', //ntTo, +// 'try', //ntTry, +// 'type', //ntType, +// 'typeargs', //ntTypeArgs, +// 'typedecl', //ntTypeDecl, +// 'typeparam', //ntTypeParam, +// 'typeparams', //ntTypeParams, +// 'typesection', //ntTypeSection, +// 'value', //ntValue, +// 'variable', //ntVariable, +// 'variables', //ntVariables, +// 'unit', //ntUnit, +// 'uses', //ntUses, +// 'while', //ntWhile, +// 'with', //ntWith, +// 'write', //ntWrite, +// +// 'ansicomment', //ntAnsiComment, +// 'borlandcomment', //ntBorComment, +// 'slashescomment' //ntSlashesComment +// ); + +const AttributeNameStrings: array[TAttributeName] of string = ( 'type', 'class', @@ -322,4 +337,22 @@ interface implementation +uses + SysUtils, TypInfo; + +{ TSyntaxNodeNames } + +function TSyntaxNodeNames.GetItem(const index: TSyntaxNodeType): string; +begin + Result:= FData[index]; +end; + +class constructor TSyntaxNodeNames.Init; +var + value: TSyntaxNodeType; +begin + for value := Low(TSyntaxNodeType) to High(TSyntaxNodeType) do + FData[value] := Copy(LowerCase(GetEnumName(TypeInfo(TSyntaxNodeType), Ord(value))), 3); +end; + end. From 8fb608de61da7e0c26c9d2a8a8ae3067b1e54a3b Mon Sep 17 00:00:00 2001 From: jbontes Date: Wed, 4 Oct 2017 00:29:21 +0200 Subject: [PATCH 13/42] The remainder of the fixes, issue to follow --- Source/DelphiAST.Classes.pas | 89 +++-- Source/DelphiAST.Consts.pas | 2 + Source/DelphiAST.pas | 180 ++++++++--- .../SimpleParser/SimpleParser.Lexer.Types.pas | 12 + Source/SimpleParser/SimpleParser.Lexer.pas | 61 ++-- Source/SimpleParser/SimpleParser.pas | 304 ++++++++---------- 6 files changed, 380 insertions(+), 268 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 41af0216..0b0ae36d 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -30,8 +30,9 @@ TSyntaxNode = class FLine: Integer; FFileName: string; function GetHasChildren: Boolean; - function GetHasAttributes: Boolean; function TryGetAttributeEntry(const Key: TAttributeName; out AttributeEntry: PAttributeEntry): boolean; + function GetChildCount: cardinal; + function GetChildNode(index: cardinal): TSyntaxNode; protected FAttributes: TArray; FChildNodes: TArray; @@ -44,22 +45,24 @@ TSyntaxNode = class function Clone: TSyntaxNode; virtual; procedure AssignPositionFrom(const Node: TSyntaxNode); - + + function HasAttribute(const Key: TAttributeName): Boolean; inline; function GetAttribute(const Key: TAttributeName): string; - function HasAttribute(const Key: TAttributeName): Boolean; procedure SetAttribute(const Key: TAttributeName; const Value: string); procedure ClearAttributes; + procedure AddChildren(Nodes: TArray); function AddChild(Node: TSyntaxNode): TSyntaxNode; overload; function AddChild(Typ: TSyntaxNodeType): TSyntaxNode; overload; procedure DeleteChild(Node: TSyntaxNode); - function ExtractChild(Node: TSyntaxNode): TSyntaxNode; + function ExtractChild(Node: TSyntaxNode): TSyntaxNode; overload; + function ExtractChild(Typ: TSyntaxNodeType): TSyntaxNode; overload; - function FindNode(Typ: TSyntaxNodeType): TSyntaxNode; + function FindNode(Typ: TSyntaxNodeType): TSyntaxNode; overload; + function FindNode(const Types: TSyntaxNodeTypes): TSyntaxNode; overload; property Attributes: TArray read FAttributes; property ChildNodes: TArray read FChildNodes; - property HasAttributes: Boolean read GetHasAttributes; property HasChildren: Boolean read GetHasChildren; property Typ: TSyntaxNodeType read FTyp; property ParentNode: TSyntaxNode read FParentNode; @@ -67,6 +70,8 @@ TSyntaxNode = class property Col: Integer read FCol write FCol; property Line: Integer read FLine write FLine; property FileName: string read FFileName write FFileName; + property ChildNode[index: cardinal]:TSyntaxNode read GetChildNode; + property ChildCount: cardinal read GetChildCount; property Attribute[const Key: TAttributeName]: string read GetAttribute write SetAttribute; end; @@ -174,10 +179,7 @@ class function TOperators.IsOpName(Typ: TSyntaxNodeType): Boolean; var i: Integer; begin - for i := 0 to High(OperatorsInfo) do - if OperatorsInfo[i].Typ = Typ then - Exit(True); - Result := False; + Result:= (Typ in [ntAddr..ntIs]); end; function IsRoundClose(Typ: TSyntaxNodeType): Boolean; inline; @@ -372,6 +374,15 @@ procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: strin else Include(FAttributesInUse, Key); end; +function SameText(const Needle: string; const HayStack: array of string): boolean; overload; +var + S: string; +begin + for S in HayStack do begin + if (SameText(Needle, S)) then exit(true); + end; + Result:= false; +end; function TSyntaxNode.TryGetAttributeEntry(const Key: TAttributeName; out AttributeEntry: PAttributeEntry): boolean; var i: integer; @@ -407,6 +418,20 @@ function TSyntaxNode.AddChild(Typ: TSyntaxNodeType): TSyntaxNode; Result := AddChild(TSyntaxNode.Create(Typ)); end; +procedure TSyntaxNode.AddChildren(Nodes: TArray); +var + Node: TSyntaxNode; + OldLength: integer; +begin + OldLength:= Length(FChildNodes); + SetLength(FChildNodes, OldLength + Length(Nodes)); + for Node in Nodes do begin + FChildNodes[OldLength]:= Node; + Inc(OldLength); + Node.FParentNode:= Self; + end; +end; + function TSyntaxNode.Clone: TSyntaxNode; var i: Integer; @@ -431,6 +456,11 @@ constructor TSyntaxNode.Create(Typ: TSyntaxNodeType); FTyp := Typ; end; +function TSyntaxNode.HasAttribute(const Key: TAttributeName): Boolean; +begin + Result := Key in FAttributesInUse; +end; + function TSyntaxNode.ExtractChild(Node: TSyntaxNode): TSyntaxNode; var i: integer; @@ -462,6 +492,19 @@ destructor TSyntaxNode.Destroy; inherited; end; +function TSyntaxNode.ExtractChild(Typ: TSyntaxNodeType): TSyntaxNode; +var + Child: TSyntaxNode; +begin + for Child in FChildNodes do begin + if (Child.Typ = Typ) then begin + ExtractChild(Child); + Exit(Child); + end; + end; + Result:= nil; +end; + function TSyntaxNode.FindNode(Typ: TSyntaxNodeType): TSyntaxNode; var i: Integer; @@ -472,6 +515,16 @@ function TSyntaxNode.FindNode(Typ: TSyntaxNodeType): TSyntaxNode; Result := nil; end; +function TSyntaxNode.FindNode(const Types: TSyntaxNodeTypes): TSyntaxNode; +var + i: integer; +begin + for i:= 0 to High(FChildNodes) do begin + if (FChildNodes[i].Typ in Types) then Exit(FChildNodes[i]); + end; + Result:= nil; +end; + function TSyntaxNode.GetAttribute(const Key: TAttributeName): string; var AttributeEntry: PAttributeEntry; @@ -482,22 +535,20 @@ function TSyntaxNode.GetAttribute(const Key: TAttributeName): string; Result := ''; end; -function TSyntaxNode.GetHasAttributes: Boolean; +function TSyntaxNode.GetChildCount: cardinal; begin - Result := Length(FAttributes) > 0; + Result:= Length(FChildNodes); end; -function TSyntaxNode.GetHasChildren: Boolean; +function TSyntaxNode.GetChildNode(index: cardinal): TSyntaxNode; begin - Result := Length(FChildNodes) > 0; + Assert(index < ChildCount); + Result:= FChildNodes[index]; end; -function TSyntaxNode.HasAttribute(const Key: TAttributeName): Boolean; -var - AttributeEntry: PAttributeEntry; +function TSyntaxNode.GetHasChildren: Boolean; begin - //Result := TryGetAttributeEntry(Key, AttributeEntry); - Result:= Key in FAttributesInUse; + Result := Length(FChildNodes) > 0; end; procedure TSyntaxNode.AssignPositionFrom(const Node: TSyntaxNode); diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 7df16a09..fd7cb01c 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -55,6 +55,7 @@ interface ntConstructorConstraint, ntContains, ntDefault, + ntDependency, ntDimension, ntDownTo, ntElement, @@ -68,6 +69,7 @@ interface ntExpression, ntExpressions, ntExternal, + ntExternalName, ntField, ntFields, ntFinalization, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 06007f02..ccfa4ff1 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -78,6 +78,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure SetCurrentCompoundNodesEndPosition; procedure DoOnComment(Sender: TObject; const Text: string); procedure DoHandleString(var s: string); inline; + procedure FieldList; protected FStack: TNodeStack; FComments: TObjectList; @@ -102,7 +103,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure CaseSelector; override; procedure CaseStatement; override; procedure ClassClass; override; - procedure ClassConstraint; override; + procedure ClassConstraint; override; procedure ClassField; override; procedure ClassForward; override; procedure ClassFunctionHeading; override; @@ -127,10 +128,12 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ConstructorName; override; procedure ContainsClause; override; procedure DestructorName; override; + procedure DirectiveAbstract; override; procedure DirectiveBinding; override; procedure DirectiveBindingMessage; override; procedure DirectiveCalling; override; procedure DirectiveInline; override; + procedure DirectiveSealed; override; procedure DispInterfaceForward; override; procedure DotOp; override; procedure ElseStatement; override; @@ -148,6 +151,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ExportsNameId; override; procedure Expression; override; procedure ExpressionList; override; + procedure ExternalDependency; override; procedure ExternalDirective; override; procedure FieldName; override; procedure FinalizationSection; override; @@ -182,6 +186,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure MainUsedUnitStatement; override; procedure MethodKind; override; procedure MultiplicativeOperator; override; + procedure NameSpecifier; override; procedure NotOp; override; procedure NilToken; override; procedure Number; override; @@ -312,10 +317,10 @@ TStringStreamHelper = class helper for TStringStream // do not use const strings here to prevent allocating new strings every time type - TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atClassOf, atClass, + TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atOperator, atClassOf, atClass, atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric, atOut, atPointer, atName, atString, atSubRange, atVar, atType, {#220+#181-explicit type} - atObject {#226}); + atObject, atSealed, atAbstract); var AttributeValues: array[TAttributeValue] of string; @@ -778,7 +783,9 @@ procedure TPasSyntaxTreeBuilder.ClassField; var Fields, Temp: TSyntaxNode; Field, TypeInfo, TypeArgs: TSyntaxNode; + IsClassVarSection: boolean; begin + IsClassVarSection:= FStack.Peek.HasAttribute(anClass); Fields := TSyntaxNode.Create(ntFields); try FStack.Push(Fields); @@ -796,6 +803,7 @@ procedure TPasSyntaxTreeBuilder.ClassField; Continue; Temp := FStack.Push(ntField); + if (IsClassVarSection) then Temp.Attribute[anClass]:= AttributeValues[atTrue]; try Temp.AssignPositionFrom(Field); @@ -812,6 +820,44 @@ procedure TPasSyntaxTreeBuilder.ClassField; Fields.Free; end; end; +procedure TPasSyntaxTreeBuilder.ObjectField; +var + Fields, Temp: TSyntaxNode; + Field, TypeInfo, TypeArgs: TSyntaxNode; + IsClassVarSection: boolean; +begin + IsClassVarSection:= FStack.Peek.HasAttribute(anClass); + Fields := TSyntaxNode.Create(ntFields); + try + FStack.Push(Fields); + try + inherited; + finally + FStack.Pop; + end; + TypeInfo := Fields.FindNode(ntType); + TypeArgs := Fields.FindNode(ntTypeArgs); + for Field in Fields.ChildNodes do + begin + if Field.Typ <> ntName then + Continue; + Temp := FStack.Push(ntField); + if (IsClassVarSection) then Temp.Attribute[anClass]:= AttributeValues[atTrue]; + try + Temp.AssignPositionFrom(Field); + FStack.AddChild(Field.Clone); + TypeInfo := TypeInfo.Clone; + if Assigned(TypeArgs) then + TypeInfo.AddChild(TypeArgs.Clone); + FStack.AddChild(TypeInfo); + finally + FStack.Pop; + end; + end; + finally + Fields.Free; + end; +end; procedure TPasSyntaxTreeBuilder.ClassForward; begin @@ -822,7 +868,8 @@ procedure TPasSyntaxTreeBuilder.ClassForward; procedure TPasSyntaxTreeBuilder.ClassFunctionHeading; begin - FStack.Peek.SetAttribute(anKind, AttributeValues[atFunction]); + if (FLexer.Token = 'operator') then FStack.Peek.SetAttribute(anKind, AttributeValues[atOperator]) + else FStack.Peek.SetAttribute(anKind, AttributeValues[atFunction]); inherited; end; @@ -843,7 +890,11 @@ procedure TPasSyntaxTreeBuilder.ClassMethod; end; procedure TPasSyntaxTreeBuilder.ClassMethodResolution; +var + PrevNode: TSyntaxNode; begin + PrevNode:= FStack.Peek; //Get the ntMethod node above + PrevNode.Attribute[anKind]:= FLexer.Token; FStack.Push(ntResolutionClause); try inherited; @@ -1138,6 +1189,12 @@ procedure TPasSyntaxTreeBuilder.DestructorName; inherited; end; +procedure TPasSyntaxTreeBuilder.DirectiveAbstract; +begin + //anAbstract Attribute can contain both 'sealed' and 'abstract' + FStack.Peek.Attribute[anAbstract]:= Lexer.Token; + inherited; +end; procedure TPasSyntaxTreeBuilder.DirectiveBinding; var token: string; @@ -1153,8 +1210,8 @@ procedure TPasSyntaxTreeBuilder.DirectiveBinding; FStack.Peek.SetAttribute(anReintroduce, AttributeValues[atTrue]) else if SameText(token, 'overload') then FStack.Peek.SetAttribute(anOverload, AttributeValues[atTrue]) - else if SameText(token, 'abstract') then - FStack.Peek.SetAttribute(anAbstract, AttributeValues[atTrue]); + else if SameText(Token, 'abstract') or SameText(Token, 'final') then + FStack.Peek.SetAttribute(anAbstract, Token); inherited; end; @@ -1180,6 +1237,13 @@ procedure TPasSyntaxTreeBuilder.DirectiveInline; FStack.Peek.SetAttribute(anInline, AttributeValues[atTrue]); inherited; end; +procedure TPasSyntaxTreeBuilder.DirectiveSealed; +begin + //hack, must go to a better attributeType, however sealed, abstract cannot coexist + //Perhaps sealed, abstract and final should all share a attribute type called anInheritance + FStack.Peek.Attribute[anAbstract]:= Lexer.Token; + inherited; +end; procedure TPasSyntaxTreeBuilder.DispInterfaceForward; begin @@ -1272,8 +1336,8 @@ procedure TPasSyntaxTreeBuilder.ExceptionVariable; procedure TPasSyntaxTreeBuilder.ExplicitType; //#220+#181 begin - inherited; FStack.Peek.SetAttribute(anKind, AttributeValues[atType]); + inherited; end; procedure TPasSyntaxTreeBuilder.ExportedHeading; @@ -1370,6 +1434,15 @@ procedure TPasSyntaxTreeBuilder.ExpressionList; end; end; +procedure TPasSyntaxTreeBuilder.ExternalDependency; +begin + FStack.Push(ntDependency); + try + inherited; + finally + FStack.Pop; + end; +end; procedure TPasSyntaxTreeBuilder.ExternalDirective; begin FStack.Push(ntExternal); @@ -1379,6 +1452,44 @@ procedure TPasSyntaxTreeBuilder.ExternalDirective; FStack.Pop; end; end; +procedure TPasSyntaxTreeBuilder.FieldList; +var + Fields, Temp: TSyntaxNode; + Field, TypeInfo, TypeArgs: TSyntaxNode; + IsClassVarSection: boolean; +begin + IsClassVarSection:= FStack.Peek.HasAttribute(anClass); + Fields := TSyntaxNode.Create(ntFields); + try + FStack.Push(Fields); + try + inherited; + finally + FStack.Pop; + end; + TypeInfo := Fields.FindNode(ntType); + TypeArgs := Fields.FindNode(ntTypeArgs); + for Field in Fields.ChildNodes do + begin + if Field.Typ <> ntName then + Continue; + Temp := FStack.Push(ntField); + if (IsClassVarSection) then Temp.Attribute[anClass]:= AttributeValues[atTrue]; + try + Temp.AssignPositionFrom(Field); + FStack.AddChild(Field.Clone); + TypeInfo := TypeInfo.Clone; + if Assigned(TypeArgs) then + TypeInfo.AddChild(TypeArgs.Clone); + FStack.AddChild(TypeInfo); + finally + FStack.Pop; + end; + end; + finally + Fields.Free; + end; +end; procedure TPasSyntaxTreeBuilder.FieldName; begin @@ -1490,10 +1601,9 @@ procedure TPasSyntaxTreeBuilder.FunctionMethodName; procedure TPasSyntaxTreeBuilder.FunctionProcedureName; //#221 record method type params explicitly, keep the full name as well. var ChildNode, NameNode, TypeParam, TypeNode, Temp, TypeParams: TSyntaxNode; - FullName, TypeParamStr, Dot, Comma: string; - HasTypeParams: boolean; + FullName, Dot, Comma: string; begin - Temp:= FStack.Peek; + //Temp:= FStack.Peek; NameNode:= FStack.Push(ntName); try inherited; @@ -1658,8 +1768,6 @@ procedure TPasSyntaxTreeBuilder.InterfaceType; end; procedure TPasSyntaxTreeBuilder.LabeledStatement; -var - Temp: TSyntaxNode; begin FStack.PushValuedNode(ntLabeledStatement, Lexer.Token); //#227 try @@ -1765,6 +1873,15 @@ procedure TPasSyntaxTreeBuilder.NamedArgument; end; end; +procedure TPasSyntaxTreeBuilder.NameSpecifier; +begin + FStack.Push(ntExternalName); + try + inherited; + finally + FStack.Pop; + end; +end; procedure TPasSyntaxTreeBuilder.NilToken; begin FStack.AddChild(ntLiteral).SetAttribute(anType, AttributeValues[atNil]); @@ -1786,45 +1903,6 @@ procedure TPasSyntaxTreeBuilder.Number; inherited; end; -procedure TPasSyntaxTreeBuilder.ObjectField; -var - Fields, Temp: TSyntaxNode; - Field, TypeInfo, TypeArgs: TSyntaxNode; -begin - Fields := TSyntaxNode.Create(ntFields); //#229 - try - FStack.Push(Fields); - try - inherited; - finally - FStack.Pop; - end; - - TypeInfo := Fields.FindNode(ntType); - TypeArgs := Fields.FindNode(ntTypeArgs); - for Field in Fields.ChildNodes do - begin - if Field.Typ <> ntName then - Continue; - - Temp := FStack.Push(ntField); - try - Temp.AssignPositionFrom(Field); - - FStack.AddChild(Field.Clone); - TypeInfo := TypeInfo.Clone; - if Assigned(TypeArgs) then - TypeInfo.AddChild(TypeArgs.Clone); - FStack.AddChild(TypeInfo); - finally - FStack.Pop; - end; - end; - finally - Fields.Free; - end; -end; - procedure TPasSyntaxTreeBuilder.ObjectForward; begin FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); //#226 diff --git a/Source/SimpleParser/SimpleParser.Lexer.Types.pas b/Source/SimpleParser/SimpleParser.Lexer.Types.pas index 97de26a1..81d05823 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.Types.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.Types.pas @@ -56,6 +56,7 @@ interface ptAddressOp, ptAmpersand, ptAnd, + ptAnsiChar, ptAnsiComment, ptAnsiString, ptArray, @@ -96,6 +97,7 @@ interface ptDefault, ptDefineDirect, ptDeprecated, + ptDependency, //for external declarations ptDestructor, ptDispid, ptDispinterface, @@ -248,7 +250,9 @@ interface ptTo, ptTry, ptType, + ptUInt64, ptUndefDirect, + ptUnicodeString, ptUnit, ptUnknown, ptUnsafe, @@ -285,6 +289,14 @@ EIncludeError = class(Exception); function GetIncludeFileContent(const FileName: string): string; end; + const + ReservedWords = [ptAnd, ptEnd, ptInterface, ptrecord, ptvar,ptarray,ptexcept,ptis,ptrepeat,ptwhile,ptas,ptexports, + ptlabel,ptresourcestring, ptwith,ptasm,ptfile,ptlibrary,ptset,ptxor,ptbegin,ptfinalization, + ptmod,ptshl,ptcase,ptfinally,ptnil,ptshr,ptclass,ptfor,ptnot,ptstring,ptconst,ptfunction,ptobject, + ptthen,ptconstructor,ptgoto,ptof,ptthreadvar,ptdestructor,ptif,ptor,ptto,ptdispinterface, + ptimplementation,ptpacked,pttry,ptdiv,ptin,ptprocedure,pttype,ptdo,ptinherited,ptprogram, + ptunit,ptdownto,ptinitialization,ptproperty,ptuntil,ptelse,ptinline,ptraise,ptuses]; + function TokenName(Value: TptTokenKind): string; function ptTokenName(Value: TptTokenKind): string; function IsTokenIDJunk(const aTokenID: TptTokenKind): Boolean; diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index d0181b8d..f895b32b 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -212,6 +212,7 @@ TmwBasePasLex = class(TObject) function Func141: TptTokenKind; function Func142: TptTokenKind; function Func143: TptTokenKind; + function Func158: TptTokenKind; function Func166: TptTokenKind; function Func167: TptTokenKind; function Func168: TptTokenKind; @@ -384,7 +385,7 @@ implementation StrUtils; type - TmwPasLexExpressionEvaluation = (leeNone, leeAnd, leeOr); + TmwPasLexExpressionEvaluation = (leeNone, leeAnd, leeOr, leeXor); procedure MakeIdentTable; var @@ -392,14 +393,10 @@ procedure MakeIdentTable; begin for I := #0 to #127 do begin - case I of - '_', '0'..'9', 'a'..'z', 'A'..'Z': Identifiers[I] := True; - else - Identifiers[I] := False; - end; - J := UpperCase(I)[1]; - case I of - 'a'..'z', 'A'..'Z', '_': mHashTable[I] := Ord(J) - 64; + Identifiers[I]:= I in ['_', '0'..'9', 'a'..'z', 'A'..'Z']; + J := UpCase(I); + case J of + 'A'..'Z', '_': mHashTable[I] := Ord(J) - 64; else mHashTable[Char(I)] := 0; end; @@ -922,7 +919,8 @@ function TmwBasePasLex.Func72: TptTokenKind; function TmwBasePasLex.Func73: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Except') then Result := ptExcept; + if KeyComp('Except') then Result := ptExcept else + if KeyComp('AnsiChar') then FExId := ptAnsiChar; end; function TmwBasePasLex.Func75: TptTokenKind; @@ -1019,8 +1017,9 @@ function TmwBasePasLex.Func94: TptTokenKind; function TmwBasePasLex.Func95: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Contains') then FExID := ptContains else - if KeyComp('Absolute') then FExID := ptAbsolute; + if KeyComp('Contains') then FExID := ptContains + else if KeyComp('Absolute') then FExID := ptAbsolute + else if KeyComp('Dependency') then FExID := ptDependency; //#240 end; function TmwBasePasLex.Func96: TptTokenKind; @@ -1060,9 +1059,9 @@ function TmwBasePasLex.Func100: TptTokenKind; function TmwBasePasLex.Func101: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Register') then FExID := ptRegister else - if KeyComp('Platform') then FExID := ptPlatform else - if KeyComp('Continue') then FExID := ptContinue; + if KeyComp('Register') then FExID:= ptRegister + else if KeyComp('Platform') then FExID:= ptPlatform + else if KeyComp('Continue') then FExID:= ptContinue; end; function TmwBasePasLex.Func102: TptTokenKind; @@ -1117,8 +1116,8 @@ function TmwBasePasLex.Func112: TptTokenKind; function TmwBasePasLex.Func117: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Exports') then Result := ptExports else - if KeyComp('OleVariant') then FExID := ptOleVariant; + if KeyComp('Exports') then Result:= ptExports + else if KeyComp('OleVariant') then FExID:= ptOleVariant; end; function TmwBasePasLex.Func123: TptTokenKind; @@ -1154,7 +1153,10 @@ function TmwBasePasLex.Func129: TptTokenKind; function TmwBasePasLex.Func130: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('AnsiString') then FExID := ptAnsiString; + if KeyComp('AnsiString') then begin + Result:= ptString; + FExID := ptAnsiString; + end; end; function TmwBasePasLex.Func132: TptTokenKind; @@ -1193,11 +1195,19 @@ function TmwBasePasLex.Func143: TptTokenKind; if KeyComp('Destructor') then Result := ptDestructor; end; +function TmwBasePasLex.Func158: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Unicodestring') then begin + Result := ptString; + FExID:= ptUnicodeString; + end; +end; function TmwBasePasLex.Func166: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Constructor') then Result := ptConstructor else - if KeyComp('Implementation') then Result := ptImplementation; + if KeyComp('Constructor') then Result:= ptConstructor + else if KeyComp('Implementation') then Result:= ptImplementation; end; function TmwBasePasLex.Func167: TptTokenKind; @@ -1215,8 +1225,8 @@ function TmwBasePasLex.Func168: TptTokenKind; function TmwBasePasLex.Func191: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Resourcestring') then Result := ptResourcestring else - if KeyComp('Stringresource') then FExID := ptStringresource; + if KeyComp('Resourcestring') then Result:= ptResourcestring + else if KeyComp('Stringresource') then FExID:= ptStringresource; end; function TmwBasePasLex.AltFunc: TptTokenKind; @@ -1703,6 +1713,7 @@ function TmwBasePasLex.EvaluateConditionalExpression(const AParams: String): Boo leeNone: Result := IsDefined(LDefine); leeAnd: Result := Result and IsDefined(LDefine); leeOr: Result := Result or IsDefined(LDefine); + leeXor: Result:= Result xor IsDefined(LDefine); end; end else if Pos('NOT DEFINED(', LParams) = 1 then @@ -1713,6 +1724,7 @@ function TmwBasePasLex.EvaluateConditionalExpression(const AParams: String): Boo leeNone: Result := (not IsDefined(LDefine)); leeAnd: Result := Result and (not IsDefined(LDefine)); leeOr: Result := Result or (not IsDefined(LDefine)); + leeXor: Result:= Result xor (not IsDefined(LDefine)); end; end; // Determine next Evaluation @@ -1725,6 +1737,11 @@ function TmwBasePasLex.EvaluateConditionalExpression(const AParams: String): Boo begin LEvaluation := leeOr; LParams := TrimLeft(Copy(LParams, 3, Length(LParams) - 2)); + end + else if Pos('XOR ', LParams) = 1 then + begin + LEvaluation := leeXor; + LParams := TrimLeft(Copy(LParams, 3, Length(LParams) - 2)); end; end; end else diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 0815f521..24a8df07 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -297,15 +297,19 @@ TmwSimplePasPar = class(TObject) procedure DestructorHeading; virtual; procedure DestructorName; virtual; procedure Directive16Bit; virtual; + procedure DirectiveAbstract; virtual; procedure DirectiveBinding; virtual; procedure DirectiveBindingMessage; virtual; procedure DirectiveCalling; virtual; + procedure DirectiveDelayed; virtual; procedure DirectiveDeprecated; virtual; + procedure DirectiveExperimental; virtual; procedure DirectiveInline; virtual; procedure DirectiveLibrary; virtual; procedure DirectiveLocal; virtual; procedure DirectivePlatform; virtual; procedure DirectiveVarargs; virtual; + procedure DirectiveSealed; virtual; procedure DispInterfaceForward; virtual; procedure DispIDSpecifier; virtual; procedure DotOp; virtual; @@ -329,8 +333,9 @@ TmwSimplePasPar = class(TObject) procedure Expression; virtual; procedure ExpressionList; virtual; procedure ExternalDirective; virtual; - procedure ExternalDirectiveThree; virtual; procedure ExternalDirectiveTwo; virtual; + procedure ExternalDirectiveThree; virtual; + procedure ExternalDependency; virtual; procedure Factor; virtual; procedure FieldDeclaration; virtual; procedure FieldList; virtual; @@ -385,6 +390,7 @@ TmwSimplePasPar = class(TObject) procedure MethodKind; virtual; procedure MultiplicativeOperator; virtual; procedure FormalParameterType; virtual; + procedure NameSpecifier; virtual; procedure NotOp; virtual; procedure NilToken; virtual; procedure Number; virtual; @@ -434,7 +440,7 @@ TmwSimplePasPar = class(TObject) procedure RealIdentifier; virtual; procedure RealType; virtual; procedure RecordConstant; virtual; - procedure RecordConstraint; virtual; + procedure RecordConstraint; virtual; procedure RecordFieldConstant; virtual; procedure RecordType; virtual; procedure RecordVariant; virtual; @@ -443,6 +449,7 @@ TmwSimplePasPar = class(TObject) procedure RequiresClause; virtual; procedure RequiresIdentifier; virtual; procedure RequiresIdentifierId; virtual; + procedure Resident; virtual; procedure ResolutionInterfaceName; virtual; procedure ResourceDeclaration; virtual; procedure ResourceValue; virtual; @@ -543,7 +550,7 @@ TmwSimplePasPar = class(TObject) procedure GlobalAttributeTarget; procedure Attributes; procedure AttributeSections; virtual; - procedure AttributeSection; + procedure AttributeSection; virtual; procedure AttributeTargetSpecifier; procedure AttributeTarget; procedure AttributeList; @@ -1195,19 +1202,7 @@ procedure TmwSimplePasPar.MainUsesClause; procedure TmwSimplePasPar.MethodKind; begin case TokenID of - ptConstructor: - begin - NextToken; - end; - ptDestructor: - begin - NextToken; - end; - ptProcedure: - begin - NextToken; - end; - ptFunction: + ptConstructor, ptDestructor, ptProcedure, ptFunction: begin NextToken; end; @@ -1835,41 +1830,21 @@ procedure TmwSimplePasPar.Directive16Bit; end; end; +procedure TmwSimplePasPar.DirectiveAbstract; +begin + ExpectedEx(ptAbstract); //abstract is an ExID. +end; + procedure TmwSimplePasPar.DirectiveBinding; begin case ExID of - ptAbstract: - begin - NextToken; - end; - ptVirtual: - begin - NextToken; - end; - ptDynamic: - begin - NextToken; - end; - ptMessage: - begin - DirectiveBindingMessage; - end; - ptOverride: - begin - NextToken; - end; - ptOverload: - begin - NextToken; - end; - ptReintroduce: - begin - NextToken; - end; - else - begin - SynError(InvalidDirectiveBinding); - end; + ptAbstract, ptVirtual, ptDynamic, ptMessage, ptOverride, ptOverload, + ptReintroduce, ptFinal: begin + NextToken; + end + else begin + SynError(InvalidDirectiveBinding); + end; end; end; @@ -2149,7 +2124,7 @@ procedure TmwSimplePasPar.ExternalDirective; SimpleExpression; if FLexer.ExID = ptDelayed then - NextToken; + DirectiveDelayed; ExternalDirectiveTwo; end; @@ -2165,15 +2140,15 @@ procedure TmwSimplePasPar.ExternalDirectiveTwo; end; ptName: begin - NextToken; - SimpleExpression; + NameSpecifier; end; ptSemiColon: begin Semicolon; ExternalDirectiveThree; end; - end + end; + if (FLexer.ExID = ptDependency) then ExternalDependency; end; procedure TmwSimplePasPar.ExternalDirectiveThree; @@ -2192,6 +2167,19 @@ procedure TmwSimplePasPar.ExternalDirectiveThree; end; end; + +procedure TmwSimplePasPar.ExternalDependency; +begin + ExpectedEx(ptDependency); + Identifier; + while TokenID = ptComma do begin + NextToken; + Identifier; + end; {while} + SemiColon; +end; + + procedure TmwSimplePasPar.ForStatement; begin Expected(ptFor); @@ -3350,79 +3338,13 @@ procedure TmwSimplePasPar.RealType; procedure TmwSimplePasPar.OrdinalIdentifier; begin - case ExID of - ptBoolean: - begin - NextToken; - end; - ptByte: - begin - NextToken; - end; - ptBytebool: - begin - NextToken; - end; - ptCardinal: - begin - NextToken; - end; - ptChar: - begin - NextToken; - end; - ptDWord: - begin - NextToken; - end; - ptInt64: - begin - NextToken; - end; - ptInteger: - begin - NextToken; - end; - ptLongBool: - begin - NextToken; - end; - ptLongInt: - begin - NextToken; - end; - ptLongWord: - begin - NextToken; - end; - ptPChar: - begin - NextToken; - end; - ptShortInt: - begin - NextToken; - end; - ptSmallInt: - begin - NextToken; - end; - ptWideChar: - begin - NextToken; - end; - ptWord: - begin - NextToken; - end; - ptWordbool: - begin - NextToken; - end; - else - begin - SynError(InvalidOrdinalIdentifier); - end; + if (ExID in [ptBoolean,ptByte,ptBytebool,ptCardinal,ptChar,ptAnsiChar,ptDWord, + ptInt64,ptUInt64,ptInteger,ptLongBool,ptLongInt,ptLongWord,ptPChar,ptShortInt, + ptSmallInt,ptWideChar,ptWord,ptWordbool]) then + begin + NextToken; + end else begin + SynError(InvalidOrdinalIdentifier); end; end; @@ -3632,6 +3554,42 @@ procedure TmwSimplePasPar.InterfaceMemberList; end; end; +procedure TmwSimplePasPar.ObjectType; +begin + Expected(ptObject); + case TokenID of + ptEnd: + begin + ObjectTypeEnd; + NextToken; { Direct descendant without new members } + end; + ptRoundOpen: + begin + ObjectHeritage; + case TokenID of + ptEnd: + begin + Expected(ptEnd); + ObjectTypeEnd; + end; + ptSemiColon: ObjectTypeEnd; + else + begin + ObjectMemberList; { Direct descendant } + Expected(ptEnd); + ObjectTypeEnd; + end; + end; + end; + else + begin + ObjectMemberList; { Direct descendant } + Expected(ptEnd); + ObjectTypeEnd; + end; + end; +end; + procedure TmwSimplePasPar.ClassType; begin Expected(ptClass); @@ -3639,13 +3597,13 @@ procedure TmwSimplePasPar.ClassType; ptIdentifier: //NASTY hack because Abstract is generally an ExID, except in this case when it should be a keyword. begin if Lexer.ExID = ptAbstract then - Expected(ptIdentifier); + DirectiveAbstract; if Lexer.ExID = ptHelper then ClassHelper; end; ptSealed: - Expected(ptSealed); + DirectiveSealed; end; case TokenID of ptEnd: @@ -3912,42 +3870,6 @@ procedure TmwSimplePasPar.ClassField; TypeDirective; end; -procedure TmwSimplePasPar.ObjectType; -begin - Expected(ptObject); - case TokenID of - ptEnd: - begin - ObjectTypeEnd; - NextToken; { Direct descendant without new members } - end; - ptRoundOpen: - begin - ObjectHeritage; - case TokenID of - ptEnd: - begin - Expected(ptEnd); - ObjectTypeEnd; - end; - ptSemiColon: ObjectTypeEnd; - else - begin - ObjectMemberList; { Direct descendant } - Expected(ptEnd); - ObjectTypeEnd; - end; - end; - end; - else - begin - ObjectMemberList; { Direct descendant } - Expected(ptEnd); - ObjectTypeEnd; - end; - end; -end; - procedure TmwSimplePasPar.ObjectHeritage; begin Expected(ptRoundOpen); @@ -4700,7 +4622,7 @@ procedure TmwSimplePasPar.LabelDeclarationSection; procedure TmwSimplePasPar.ProceduralDirective; begin case GenID of - ptAbstract: + ptAbstract, ptFinal: begin DirectiveBinding; end; @@ -4742,8 +4664,10 @@ procedure TmwSimplePasPar.ProceduralDirective; DirectiveLocal; ptVarargs: DirectiveVarargs; - ptFinal, ptExperimental, ptDelayed: - NextToken; + ptExperimental: + DirectiveExperimental; + ptDelayed: + DirectiveDelayed; else begin SynError(InvalidProceduralDirective); @@ -4843,7 +4767,7 @@ procedure TmwSimplePasPar.TypeSection; begin Expected(ptType); - while (TokenID = ptIdentifier) or (Lexer.TokenID = ptSquareOpen) do + while (TokenID in [ptIdentifier, ptSquareOpen]) do begin if TokenID = ptSquareOpen then CustomAttribute @@ -4868,7 +4792,7 @@ procedure TmwSimplePasPar.TypeSection; procedure TmwSimplePasPar.TypeSimple; begin case GenID of - ptBoolean, ptByte, ptChar, ptDWord, ptInt64, ptInteger, ptLongInt, + ptBoolean, ptByte, ptChar, ptAnsiChar, ptDWord, ptInt64, ptUInt64, ptInteger, ptCardinal, ptLongInt, ptLongWord, ptPChar, ptShortInt, ptSmallInt, ptWideChar, ptWord: begin OrdinalIdentifier; @@ -4877,7 +4801,7 @@ procedure TmwSimplePasPar.TypeSimple; begin RealIdentifier; end; - ptAnsiString, ptShortString, ptWideString: + ptAnsiString, ptShortString, ptWideString, ptUnicodeString: begin StringIdentifier; end; @@ -5061,20 +4985,25 @@ procedure TmwSimplePasPar.ExportsElement; if FLexer.ExID = ptIndex then begin - NextToken; - Expected(ptIntegerConst); + IndexSpecifier end; if FLexer.ExID = ptName then begin - NextToken; - SimpleExpression; + NameSpecifier end; if FLexer.ExID = ptResident then begin - NextToken; + Resident; end; end; +procedure TmwSimplePasPar.Resident; +begin + ExpectedEx(ptResident); +end; + + + procedure TmwSimplePasPar.CompoundStatement; begin Expected(ptBegin); @@ -5336,10 +5265,16 @@ procedure TmwSimplePasPar.IndexSpecifier; ConstantExpression; end; +procedure TmwSimplePasPar.NameSpecifier; +begin + ExpectedEx(ptName); + SimpleExpression; +end; + procedure TmwSimplePasPar.ClassTypeEnd; begin case ExID of - ptExperimental: NextToken; + ptExperimental: DirectiveExperimental; ptDeprecated: DirectiveDeprecated; end; end; @@ -5370,6 +5305,23 @@ procedure TmwSimplePasPar.DirectivePlatform; ExpectedEx(ptPlatform); end; +procedure TmwSimplePasPar.DirectiveExperimental; +begin + ExpectedEx(ptExperimental); +end; + +procedure TmwSimplePasPar.DirectiveDelayed; +begin + ExpectedEx(ptDelayed); +end; + + + +procedure TmwSimplePasPar.DirectiveSealed; +begin + Expected(ptSealed); +end; + procedure TmwSimplePasPar.EnumeratedTypeItem; begin QualifiedIdentifier; @@ -5546,7 +5498,7 @@ procedure TmwSimplePasPar.TypeDirective; ptDeprecated: DirectiveDeprecated; ptLibrary: DirectiveLibrary; ptPlatform: DirectivePlatform; - ptExperimental: NextToken; + ptExperimental: DirectiveExperimental; end; end; From f41630830fa04b9bce403cbd9bf7482a7a9278df Mon Sep 17 00:00:00 2001 From: jbontes Date: Thu, 5 Oct 2017 16:50:01 +0200 Subject: [PATCH 14/42] #216 reference to anonymoustype fixed. #237 resident external keyword added. Plus a few other small fixes. --- Source/DelphiAST.Consts.pas | 5 ++-- Source/DelphiAST.pas | 42 +++++++++++++++++++++++++--- Source/SimpleParser/SimpleParser.pas | 28 +++++++++++++++---- 3 files changed, 63 insertions(+), 12 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index fd7cb01c..78ba6492 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -36,7 +36,7 @@ interface ntUnknown, ntAlignmentParam, ntAnonymousMethod, - ntAnonymousType, + ntAnonymousMethodType, ntArguments, ntAssign, ntAt, @@ -110,6 +110,7 @@ interface ntRecordConstraint, ntRepeat, ntRequires, + ntResident, ntResolutionClause, ntResourceString, ntReturnType, @@ -213,7 +214,7 @@ TSyntaxNodeNames = record // 'unknown', //ntUnknown, // 'alignmentparam', //ntAlignmentParam, // 'anonymousmethod', //ntAnonymousMethod, -// 'anonymoustype', //ntAnonymousType, +// 'anonymousmethodtype', //ntAnonymousMethodType, // 'arguments', //ntArguments, // 'assign', //ntAssign, // 'at', //ntAt, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index ccfa4ff1..e449ec60 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -78,7 +78,6 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure SetCurrentCompoundNodesEndPosition; procedure DoOnComment(Sender: TObject; const Text: string); procedure DoHandleString(var s: string); inline; - procedure FieldList; protected FStack: TNodeStack; FComments: TObjectList; @@ -90,6 +89,9 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure AddressOp; override; procedure AlignmentParameter; override; procedure AnonymousMethod; override; + procedure AnonymousMethodType; override; + procedure AnonymousMethodTypeFunction; override; + procedure AnonymousMethodTypeProcedure; override; procedure ArrayBounds; override; procedure ArrayConstant; override; procedure ArrayDimension; override; @@ -151,8 +153,9 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ExportsNameId; override; procedure Expression; override; procedure ExpressionList; override; - procedure ExternalDependency; override; procedure ExternalDirective; override; + procedure ExternalDependency; override; + procedure FieldList; override; procedure FieldName; override; procedure FinalizationSection; override; procedure FinallyBlock; override; @@ -216,6 +219,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure RequiresClause; override; procedure RequiresIdentifier; override; procedure RequiresIdentifierId; override; + procedure Resident; override; procedure ReturnType; override; procedure RoundClose; override; procedure RoundOpen; override; @@ -497,7 +501,7 @@ procedure TPasSyntaxTreeBuilder.AlignmentParameter; procedure TPasSyntaxTreeBuilder.AnonymousMethod; begin - FStack.Push(ntAnonymousMethod); + FStack.Push(ntAnonymousMethod).Attribute[anKind]:= Lexer.Token; try inherited; finally @@ -505,6 +509,26 @@ procedure TPasSyntaxTreeBuilder.AnonymousMethod; end; end; +procedure TPasSyntaxTreeBuilder.AnonymousMethodType; +begin + FStack.Push(ntAnonymousMethodType); + try + inherited; + finally + FStack.Pop + end; +end; + +procedure TPasSyntaxTreeBuilder.AnonymousMethodTypeProcedure; +begin + FStack.Peek.Attribute[anKind]:= Lexer.Token; +end; + +procedure TPasSyntaxTreeBuilder.AnonymousMethodTypeFunction; +begin + FStack.Peek.Attribute[anKind]:= Lexer.Token; +end; + procedure TPasSyntaxTreeBuilder.ArrayBounds; begin FStack.Push(ntBounds); @@ -2034,7 +2058,7 @@ procedure TPasSyntaxTreeBuilder.ProcedureHeading; procedure TPasSyntaxTreeBuilder.ProcedureProcedureName; begin - FStack.Peek.SetAttribute(anName, Lexer.Token); + //FStack.Peek.SetAttribute(anName, Lexer.Token); inherited; end; @@ -2154,6 +2178,16 @@ procedure TPasSyntaxTreeBuilder.RequiresIdentifierId; inherited; end; +procedure TPasSyntaxTreeBuilder.Resident; +begin + FStack.Push(ntResident); + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.ResourceDeclaration; begin FStack.Push(ntResourceString); diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 24a8df07..b652ef72 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -242,6 +242,8 @@ TmwSimplePasPar = class(TObject) procedure AncestorId; virtual; procedure AnonymousMethod; virtual; procedure AnonymousMethodType; virtual; + procedure AnonymousMethodTypeFunction; virtual; + procedure AnonymousMethodTypeProcedure; virtual; procedure ArrayConstant; virtual; procedure ArrayBounds; virtual; procedure ArrayDimension; virtual; @@ -5368,16 +5370,20 @@ procedure TmwSimplePasPar.AnonymousMethod; ptFunction: begin NextToken; - if TokenID = ptRoundOpen then - FormalParameterList; - Expected(ptColon); - ReturnType; + if TokenID = ptRoundOpen then begin + RoundOpen; + ExpressionList; + RoundClose; + end; end; ptProcedure: begin NextToken; - if TokenId = ptRoundOpen then - FormalParameterList; + if TokenId = ptRoundOpen then begin + RoundOpen; + ExpressionList; + RoundClose; + end; end; end; Block; @@ -5390,12 +5396,14 @@ procedure TmwSimplePasPar.AnonymousMethodType; case TokenID of ptProcedure: begin + AnonymousMethodTypeProcedure; NextToken; if TokenID = ptRoundOpen then FormalParameterList; end; ptFunction: begin + AnonymousMethodTypeFunction; NextToken; if TokenID = ptRoundOpen then FormalParameterList; @@ -5404,6 +5412,14 @@ procedure TmwSimplePasPar.AnonymousMethodType; end; end; end; +procedure TmwSimplePasPar.AnonymousMethodTypeProcedure; +begin + Expected(ptProcedure); +end; +procedure TmwSimplePasPar.AnonymousMethodTypeFunction; +begin + Expected(ptFunction); +end; procedure TmwSimplePasPar.AddDefine(const ADefine: string); begin From 9226c1fffbfc4d8fef1d40dfcf43412cff5240b0 Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 6 Oct 2017 10:48:18 +0200 Subject: [PATCH 15/42] #230 Variant records are now supported Also included are a few minor optimizations. --- Source/DelphiAST.Consts.pas | 3 + Source/DelphiAST.pas | 63 ++++++++++-- Source/SimpleParser/SimpleParser.pas | 144 ++++++++++++++------------- 3 files changed, 133 insertions(+), 77 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 78ba6492..d8ae1160 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -108,6 +108,7 @@ interface ntRaise, ntRead, ntRecordConstraint, + ntRecordVariant, ntRepeat, ntRequires, ntResident, @@ -135,6 +136,8 @@ interface ntValue, ntVariable, ntVariables, + ntVariantSection, + ntVariantTag, ntUnit, ntUses, ntWhile, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index e449ec60..5b14d665 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -27,7 +27,7 @@ TPasLexer = class FOnHandleString: TStringEvent; function GetToken: string; inline; function GetPosXY: TTokenPoint; inline; - function GetFileName: string; + function GetFileName: string; inline; public constructor Create(const ALexer: TmwPasLex; AOnHandleString: TStringEvent); @@ -41,7 +41,7 @@ TNodeStack = class FLexer: TPasLexer; FStack: TStack; - function GetCount: Integer; + function GetCount: Integer; inline; public constructor Create(Lexer: TPasLexer); destructor Destroy; override; @@ -50,9 +50,9 @@ TNodeStack = class function AddChild(Node: TSyntaxNode): TSyntaxNode; overload; function AddValuedChild(Typ: TSyntaxNodeType; const Value: string): TSyntaxNode; - procedure Clear; - function Peek: TSyntaxNode; - function Pop: TSyntaxNode; + procedure Clear; inline; + function Peek: TSyntaxNode; inline; + function Pop: TSyntaxNode; inline; function Push(Typ: TSyntaxNodeType): TSyntaxNode; overload; function Push(Node: TSyntaxNode): TSyntaxNode; overload; @@ -71,11 +71,11 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ParserMessage(Sender: TObject; const Typ: TMessageEventType; const Msg: string; X, Y: Integer); function NodeListToString(NamesNode: TSyntaxNode): string; procedure MoveMembersToVisibilityNodes(TypeNode: TSyntaxNode); - procedure CallInheritedConstantExpression; - procedure CallInheritedExpression; - procedure CallInheritedFormalParameterList; - procedure CallInheritedPropertyParameterList; - procedure SetCurrentCompoundNodesEndPosition; + procedure CallInheritedConstantExpression; inline; + procedure CallInheritedExpression; inline; + procedure CallInheritedFormalParameterList; inline; + procedure CallInheritedPropertyParameterList; inline; + procedure SetCurrentCompoundNodesEndPosition; inline; procedure DoOnComment(Sender: TObject; const Text: string); procedure DoHandleString(var s: string); inline; protected @@ -212,6 +212,9 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure RecordConstraint; override; procedure RecordFieldConstant; override; procedure RecordType; override; + procedure RecordVariant; override; + procedure RecordVariantSection; override; + procedure RecordVariantTag; override; procedure RelativeOperator; override; procedure RepeatStatement; override; procedure ResourceDeclaration; override; @@ -797,6 +800,16 @@ procedure TPasSyntaxTreeBuilder.CaseStatement; end; end; +procedure TPasSyntaxTreeBuilder.RecordVariant; +begin + FStack.Push(ntRecordVariant); + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.ClassClass; begin FStack.Peek.SetAttribute(anClass, AttributeValues[atTrue]); @@ -2750,6 +2763,36 @@ procedure TPasSyntaxTreeBuilder.VarDeclaration; end; end; +procedure TPasSyntaxTreeBuilder.RecordVariantSection; +begin + FStack.Push(ntVariantSection); + try + inherited; + finally + FStack.Pop; + end; +end; + +procedure TPasSyntaxTreeBuilder.RecordVariantTag; +var + Temp: TSyntaxNode; +begin + Temp:= FStack.Push(ntVariantTag); + try + inherited; + if Temp.ChildCount = 2 then begin + Temp.Attribute[anName]:= Temp.ChildNode[0].Attribute[anName]; + Temp.Attribute[anType]:= Temp.ChildNode[1].Attribute[anName]; + Temp.DeleteChild(Temp.ChildNode[1]); + end else begin + Temp.Attribute[anType]:= Temp.ChildNode[0].Attribute[anName]; + end; + Temp.DeleteChild(Temp.ChildNode[0]); + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.VarName; begin //FStack.AddValuedChild(ntName, Lexer.Token); diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index b652ef72..09beb326 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -204,13 +204,13 @@ TmwSimplePasPar = class(TObject) FInRound: Integer; procedure InitAhead; procedure VariableTail; - function GetInRound: Boolean; - function GetUseDefines: Boolean; - function GetScopedEnums: Boolean; - procedure SetUseDefines(const Value: Boolean); - procedure SetIncludeHandler(IncludeHandler: IIncludeHandler); - function GetOnComment: TCommentEvent; - procedure SetOnComment(const Value: TCommentEvent); + function GetInRound: Boolean; inline; + function GetUseDefines: Boolean; inline; + function GetScopedEnums: Boolean; inline; + procedure SetUseDefines(const Value: Boolean); inline; + procedure SetIncludeHandler(IncludeHandler: IIncludeHandler); inline; + function GetOnComment: TCommentEvent; inline; + procedure SetOnComment(const Value: TCommentEvent); inline; protected procedure Expected(Sym: TptTokenKind); virtual; procedure ExpectedEx(Sym: TptTokenKind); virtual; @@ -524,7 +524,8 @@ TmwSimplePasPar = class(TObject) procedure Variable; virtual; procedure VariableReference; virtual; procedure VariantIdentifier; virtual; - procedure VariantSection; virtual; + procedure RecordVariantSection; virtual; + procedure RecordVariantTag; virtual; procedure VarParameter; virtual; procedure VarName; virtual; procedure VarNameList; virtual; @@ -545,23 +546,23 @@ TmwSimplePasPar = class(TObject) {This is the syntax for custom attributes, based quite strictly on the ECMA syntax specifications for C#, but with a Delphi expression being used at the bottom as opposed to a C# expression} - procedure GlobalAttributes; - procedure GlobalAttributeSections; - procedure GlobalAttributeSection; - procedure GlobalAttributeTargetSpecifier; - procedure GlobalAttributeTarget; - procedure Attributes; + procedure GlobalAttributes; virtual; + procedure GlobalAttributeSections; virtual; + procedure GlobalAttributeSection; virtual; + procedure GlobalAttributeTargetSpecifier; virtual; + procedure GlobalAttributeTarget; virtual; + procedure Attributes; virtual; procedure AttributeSections; virtual; procedure AttributeSection; virtual; - procedure AttributeTargetSpecifier; - procedure AttributeTarget; - procedure AttributeList; + procedure AttributeTargetSpecifier; virtual; + procedure AttributeTarget; virtual; + procedure AttributeList; virtual; procedure Attribute; virtual; procedure AttributeName; virtual; procedure AttributeArguments; virtual; - procedure PositionalArgumentList; + procedure PositionalArgumentList; virtual; procedure PositionalArgument; virtual; - procedure NamedArgumentList; + procedure NamedArgumentList; virtual; procedure NamedArgument; virtual; procedure AttributeArgumentName; virtual; procedure AttributeArgumentExpression; virtual; @@ -576,11 +577,11 @@ TmwSimplePasPar = class(TObject) procedure SynError(Error: TmwParseError); virtual; procedure Run(const UnitName: string; SourceStream: TStream); virtual; - procedure ClearDefines; - procedure InitDefinesDefinedByCompiler; - procedure AddDefine(const ADefine: string); - procedure RemoveDefine(const ADefine: string); - function IsDefined(const ADefine: string): Boolean; + procedure ClearDefines; inline; + procedure InitDefinesDefinedByCompiler; inline; + procedure AddDefine(const ADefine: string); inline; + procedure RemoveDefine(const ADefine: string); inline; + function IsDefined(const ADefine: string): Boolean; inline; property InterfaceOnly: Boolean read FInterfaceOnly write FInterfaceOnly; property Lexer: TmwPasLex read FLexer; @@ -2270,6 +2271,34 @@ procedure TmwSimplePasPar.CaseStatement; Expected(ptEnd); end; +procedure TmwSimplePasPar.RecordVariantTag; +begin + Identifier; + if (TokenId = ptColon) then + Identifier; +end; + + +procedure TmwSimplePasPar.RecordVariantSection; +begin + Expected(ptCase); + RecordVariantTag; + Expected(ptOf); + RecordVariant; + while TokenID = ptSemiColon do + begin + Semicolon; + case TokenID of + ptEnd: + Break; + ptRoundClose: + Break; + else + RecordVariant; + end; + end; +end; + procedure TmwSimplePasPar.CaseSelector; begin CaseLabelList; @@ -2281,6 +2310,18 @@ procedure TmwSimplePasPar.CaseSelector; end; end; +procedure TmwSimplePasPar.RecordVariant; +begin + CaseLabelList; + Expected(ptColon); + Expected(ptRoundOpen); + if TokenID <> ptRoundClose then + begin + FieldList; + end; + Expected(ptRoundClose); +end; + procedure TmwSimplePasPar.CaseElseStatement; begin Expected(ptElse); @@ -2288,6 +2329,16 @@ procedure TmwSimplePasPar.CaseElseStatement; Semicolon; end; +procedure TmwSimplePasPar.CaseLabelList; +begin + CaseLabel; + while TokenID = ptComma do + begin + NextToken; + CaseLabel; + end; +end; + procedure TmwSimplePasPar.CaseLabel; begin ConstantExpression; @@ -3100,39 +3151,7 @@ procedure TmwSimplePasPar.DirectiveCalling; end; end; -procedure TmwSimplePasPar.RecordVariant; -begin - ConstantExpression; - while (TokenID = ptComma) do - begin - NextToken; - ConstantExpression; - end; - Expected(ptColon); - Expected(ptRoundOpen); - if TokenID <> ptRoundClose then - begin - FieldList; - end; - Expected(ptRoundClose); -end; -procedure TmwSimplePasPar.VariantSection; -begin - Expected(ptCase); - TagField; - Expected(ptOf); - RecordVariant; - while TokenID = ptSemiColon do - begin - Semicolon; - case TokenID of - ptEnd, ptRoundClose: Break; - else - RecordVariant; - end; - end; -end; procedure TmwSimplePasPar.TagField; begin @@ -3173,7 +3192,7 @@ procedure TmwSimplePasPar.FieldList; end; if TokenID = ptCase then begin - VariantSection; + RecordVariantSection; end; end; @@ -3781,7 +3800,7 @@ procedure TmwSimplePasPar.ClassMemberList; TypeSection; if TokenID = ptCase then begin - VariantSection; + RecordVariantSection; end; end; end; @@ -5468,15 +5487,6 @@ procedure TmwSimplePasPar.AttributeArgumentName; Expected(ptIdentifier); end; -procedure TmwSimplePasPar.CaseLabelList; -begin - CaseLabel; - while TokenID = ptComma do - begin - NextToken; - CaseLabel; - end; -end; procedure TmwSimplePasPar.ArrayBounds; begin From c78a6d54778a49803add43be5e89526c91dc25a3 Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 6 Oct 2017 18:17:07 +0200 Subject: [PATCH 16/42] #239 Nil literal should be a ValuesSyntaxNode --- Source/DelphiAST.pas | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 5b14d665..a8bd3360 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -1919,9 +1919,13 @@ procedure TPasSyntaxTreeBuilder.NameSpecifier; FStack.Pop; end; end; + procedure TPasSyntaxTreeBuilder.NilToken; +var + Node: TSyntaxNode; begin - FStack.AddChild(ntLiteral).SetAttribute(anType, AttributeValues[atNil]); + Node:= FStack.AddValuedChild(ntLiteral, AttributeValues[atNil]); + Node.Attribute[anType]:= AttributeValues[atNil]; inherited; end; From 02195f198b2717d2d9f66d694522a592430a0029 Mon Sep 17 00:00:00 2001 From: jbontes Date: Thu, 12 Oct 2017 15:00:19 +0200 Subject: [PATCH 17/42] #242 subrange and enum should use anType attributes Also changes all attribute access to use the attribute property. --- Source/DelphiAST.pas | 200 ++++++++++++++++++++++++------------------- 1 file changed, 114 insertions(+), 86 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index a8bd3360..6b4af524 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -237,6 +237,8 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure StringStatement; override; procedure StructuredType; override; procedure SubrangeType; override; + procedure TagField; override; + procedure TagFieldTypeName; override; procedure ThenStatement; override; procedure TryStatement; override; procedure TypeArgs; override; @@ -326,8 +328,8 @@ TStringStreamHelper = class helper for TStringStream type TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atOperator, atClassOf, atClass, atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric, - atOut, atPointer, atName, atString, atSubRange, atVar, atType, {#220+#181-explicit type} - atObject, atSealed, atAbstract); + atOut, atPointer, atName, atString, atSubRange, atVar, atType{ExplicitType}, + atObject, atSealed, atAbstract, atBegin); var AttributeValues: array[TAttributeValue] of string; @@ -618,7 +620,7 @@ procedure TPasSyntaxTreeBuilder.AttributeArgumentExpression; procedure TPasSyntaxTreeBuilder.AttributeArgumentName; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName,Lexer.Token); //#222 + FStack.AddChild(ntName).Attribute[anName]:= Lexer.Token; inherited; end; @@ -635,7 +637,7 @@ procedure TPasSyntaxTreeBuilder.AttributeArguments; procedure TPasSyntaxTreeBuilder.AttributeName; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntname).Attribute[anName]:= Lexer.Token; inherited; end; @@ -719,7 +721,7 @@ procedure TPasSyntaxTreeBuilder.BuildParametersList( for ParamList in Params.ChildNodes do begin TypeInfo := ParamList.FindNode(ntType); - ParamKind := ParamList.GetAttribute(anKind); + ParamKind := ParamList.Attribute[anKind]; ParamExpr := ParamList.FindNode(ntExpression); for Param in ParamList.ChildNodes do @@ -729,7 +731,7 @@ procedure TPasSyntaxTreeBuilder.BuildParametersList( Temp := FStack.Push(ntParameter); if ParamKind <> '' then - Temp.SetAttribute(anKind, ParamKind); + Temp.Attribute[anKind] := ParamKind; Temp.Col := Param.Col; Temp.Line := Param.Line; @@ -812,7 +814,7 @@ procedure TPasSyntaxTreeBuilder.RecordVariant; procedure TPasSyntaxTreeBuilder.ClassClass; begin - FStack.Peek.SetAttribute(anClass, AttributeValues[atTrue]); + FStack.Peek.Attribute[anClass]:= AttributeValues[atTrue]; inherited; end; @@ -898,15 +900,15 @@ procedure TPasSyntaxTreeBuilder.ObjectField; procedure TPasSyntaxTreeBuilder.ClassForward; begin - FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); //#226 - FStack.Peek.SetAttribute(anType, AttributeValues[atClass]); + FStack.Peek.Attribute[anForwarded]:= AttributeValues[atTrue]; + FStack.Peek.Attribute[anType]:= AttributeValues[atClass]; inherited; end; procedure TPasSyntaxTreeBuilder.ClassFunctionHeading; begin - if (FLexer.Token = 'operator') then FStack.Peek.SetAttribute(anKind, AttributeValues[atOperator]) - else FStack.Peek.SetAttribute(anKind, AttributeValues[atFunction]); + if (FLexer.Token = 'operator') then FStack.Peek.Attribute[anKind]:= AttributeValues[atOperator] + else FStack.Peek.Attribute[anKind]:= AttributeValues[atFunction]; inherited; end; @@ -922,7 +924,7 @@ procedure TPasSyntaxTreeBuilder.ClassHelper; procedure TPasSyntaxTreeBuilder.ClassMethod; begin - FStack.Peek.SetAttribute(anClass, AttributeValues[atTrue]); + FStack.Peek.Attribute[anClass]:= AttributeValues[atTrue]; inherited; end; @@ -953,7 +955,7 @@ procedure TPasSyntaxTreeBuilder.ClassMethodHeading; procedure TPasSyntaxTreeBuilder.ClassProcedureHeading; begin - FStack.Peek.SetAttribute(anKind, AttributeValues[atProcedure]); + FStack.Peek.Attribute[anKind]:= AttributeValues[atProcedure]; inherited; end; @@ -969,7 +971,7 @@ procedure TPasSyntaxTreeBuilder.ClassProperty; procedure TPasSyntaxTreeBuilder.ClassReferenceType; begin - FStack.Push(ntType).SetAttribute(anType, AttributeValues[atClassof]); + FStack.Push(ntType).Attribute[anType]:= AttributeValues[atClassof]; try inherited; finally @@ -979,7 +981,7 @@ procedure TPasSyntaxTreeBuilder.ClassReferenceType; procedure TPasSyntaxTreeBuilder.ClassType; begin - FStack.Push(ntType).SetAttribute(anType, AttributeValues[atClass]); + FStack.Push(ntType).Attribute[anType]:= AttributeValues[atClass]; try inherited; finally @@ -1014,7 +1016,7 @@ procedure TPasSyntaxTreeBuilder.MoveMembersToVisibilityNodes(TypeNode: TSyntaxNo procedure TPasSyntaxTreeBuilder.ConstParameter; begin - FStack.Push(ntParameters).SetAttribute(anKind, AttributeValues[atConst]); + FStack.Push(ntParameters).Attribute[anKind]:= AttributeValues[atConst]; try inherited; finally @@ -1027,14 +1029,14 @@ procedure TPasSyntaxTreeBuilder.ConstructorName; Temp: TSyntaxNode; begin Temp := FStack.Peek; - Temp.SetAttribute(anKind, AttributeValues[atConstructor]); - Temp.SetAttribute(anName, Lexer.Token); + Temp.Attribute[anKind]:= AttributeValues[atConstructor]; + Temp.Attribute[anName]:= Lexer.Token; inherited; end; procedure TPasSyntaxTreeBuilder.CompoundStatement; begin - FStack.PushCompoundSyntaxNode(ntStatements); + FStack.PushCompoundSyntaxNode(ntStatements).Attribute[anKind]:= AttributeValues[atBegin]; try inherited; SetCurrentCompoundNodesEndPosition; @@ -1074,7 +1076,7 @@ procedure TPasSyntaxTreeBuilder.CallInheritedConstantExpression; procedure TPasSyntaxTreeBuilder.ConstantName; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntName).Attribute[anName]:= Lexer.Token; inherited; end; @@ -1145,7 +1147,7 @@ procedure TPasSyntaxTreeBuilder.ConstSection; begin ConstSect := TSyntaxNode.Create(ntConstants); try - FStack.Push(ntConstants).SetAttribute(anKind, Lexer.Token); //#228 + FStack.Push(ntConstants).Attribute[anKind]:= Lexer.Token; //resourcestring or const FStack.Push(ConstSect); try @@ -1221,8 +1223,8 @@ procedure TPasSyntaxTreeBuilder.DestructorName; Temp: TSyntaxNode; begin Temp := FStack.Peek; - Temp.SetAttribute(anKind, AttributeValues[atDestructor]); - Temp.SetAttribute(anName, Lexer.Token); + Temp.Attribute[anKind]:= AttributeValues[atDestructor]; + Temp.Attribute[anName]:= Lexer.Token; inherited; end; @@ -1241,14 +1243,14 @@ procedure TPasSyntaxTreeBuilder.DirectiveBinding; if SameText(token, 'override') or SameText(token, 'virtual') or SameText(token, 'dynamic') then - FStack.Peek.SetAttribute(anMethodBinding, token) + FStack.Peek.Attribute[anMethodBinding]:= Token // Other directives else if SameText(token, 'reintroduce') then - FStack.Peek.SetAttribute(anReintroduce, AttributeValues[atTrue]) + FStack.Peek.Attribute[anReintroduce]:= AttributeValues[atTrue] else if SameText(token, 'overload') then - FStack.Peek.SetAttribute(anOverload, AttributeValues[atTrue]) + FStack.Peek.Attribute[anOverload]:= AttributeValues[atTrue] else if SameText(Token, 'abstract') or SameText(Token, 'final') then - FStack.Peek.SetAttribute(anAbstract, Token); + FStack.Peek.Attribute[anAbstract]:= Token; inherited; end; @@ -1265,13 +1267,13 @@ procedure TPasSyntaxTreeBuilder.DirectiveBindingMessage; procedure TPasSyntaxTreeBuilder.DirectiveCalling; begin - FStack.Peek.SetAttribute(anCallingConvention, Lexer.Token); + FStack.Peek.Attribute[anCallingConvention]:= Lexer.Token; inherited; end; procedure TPasSyntaxTreeBuilder.DirectiveInline; begin - FStack.Peek.SetAttribute(anInline, AttributeValues[atTrue]); + FStack.Peek.Attribute[anInline]:= AttributeValues[atTrue]; inherited; end; procedure TPasSyntaxTreeBuilder.DirectiveSealed; @@ -1284,7 +1286,7 @@ procedure TPasSyntaxTreeBuilder.DirectiveSealed; procedure TPasSyntaxTreeBuilder.DispInterfaceForward; begin - FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); + FStack.Peek.Attribute[anForwarded]:= AttributeValues[atTrue]; inherited; end; @@ -1320,9 +1322,9 @@ procedure TPasSyntaxTreeBuilder.EnumeratedType; begin TypeNode := FStack.Push(ntType); try - TypeNode.SetAttribute(anName, AttributeValues[atEnum]); + TypeNode.Attribute[anName]:= AttributeValues[atEnum]; if ScopedEnums then - TypeNode.SetAttribute(anVisibility, 'scoped'); + TypeNode.Attribute[anVisibility]:= 'scoped'; inherited; finally FStack.Pop; @@ -1363,7 +1365,7 @@ procedure TPasSyntaxTreeBuilder.ExceptionVariable; begin FStack.Push(ntVariable); //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntName).Attribute[anName]:= Lexer.Token; try inherited; finally @@ -1373,7 +1375,7 @@ procedure TPasSyntaxTreeBuilder.ExceptionVariable; procedure TPasSyntaxTreeBuilder.ExplicitType; //#220+#181 begin - FStack.Peek.SetAttribute(anKind, AttributeValues[atType]); + FStack.Peek.Attribute[anKind]:= AttributeValues[atType]; inherited; end; @@ -1421,7 +1423,7 @@ procedure TPasSyntaxTreeBuilder.ExportsName; FStack.Pop; end; - FStack.Peek.SetAttribute(anName, NodeListToString(NamesNode)); + FStack.Peek.Attribute[anName]:= NodeListToString(NamesNode); finally NamesNode.Free; end; @@ -1429,7 +1431,7 @@ procedure TPasSyntaxTreeBuilder.ExportsName; procedure TPasSyntaxTreeBuilder.ExportsNameId; begin - FStack.AddChild(ntUnknown).SetAttribute(anName, Lexer.Token); + FStack.AddChild(ntUnknown).Attribute[anName]:= Lexer.Token; inherited; end; @@ -1531,7 +1533,7 @@ procedure TPasSyntaxTreeBuilder.FieldList; procedure TPasSyntaxTreeBuilder.FieldName; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntname).Attribute[anName]:= Lexer.Token; inherited; end; @@ -1617,21 +1619,21 @@ procedure TPasSyntaxTreeBuilder.ForStatementTo; procedure TPasSyntaxTreeBuilder.ForwardDeclaration; begin if FStack.Peek.ParentNode.Typ = ntImplementation then begin //#166 - FStack.Peek.SetAttribute(anForwarded, 'true'); + FStack.Peek.Attribute[anForwarded]:= AttributeValues[atTrue]; end; inherited; end; procedure TPasSyntaxTreeBuilder.FunctionHeading; begin - FStack.Peek.SetAttribute(anKind, AttributeValues[atFunction]); + FStack.Peek.Attribute[anKind]:= AttributeValues[atFunction]; inherited; end; procedure TPasSyntaxTreeBuilder.FunctionMethodName; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntName).Attribute[anName]:= Lexer.Token; inherited; end; @@ -1667,7 +1669,7 @@ procedure TPasSyntaxTreeBuilder.FunctionProcedureName; //#221 record method t end; {ntTypeParams:} end; {case} end; {for ChildNode} - NameNode.SetAttribute(anName, FullName); + NameNode.Attribute[anName]:= FullName; end; procedure TPasSyntaxTreeBuilder.GotoStatement; begin @@ -1681,7 +1683,7 @@ procedure TPasSyntaxTreeBuilder.GotoStatement; procedure TPasSyntaxTreeBuilder.Identifier; begin - FStack.AddChild(ntIdentifier).SetAttribute(anName, Lexer.Token); + FStack.AddChild(ntIdentifier).Attribute[anName]:= Lexer.Token; inherited; end; @@ -1769,7 +1771,7 @@ procedure TPasSyntaxTreeBuilder.InitializationSection; procedure TPasSyntaxTreeBuilder.InterfaceForward; begin - FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); + FStack.Peek.Attribute[anForwarded]:= AttributeValues[atTrue]; inherited InterfaceForward; end; @@ -1796,7 +1798,7 @@ procedure TPasSyntaxTreeBuilder.InterfaceSection; procedure TPasSyntaxTreeBuilder.InterfaceType; begin - FStack.Push(ntType).SetAttribute(anType, AttributeValues[atInterface]); + FStack.Push(ntType).Attribute[anType]:= AttributeValues[atInterface]; try inherited; finally @@ -1833,7 +1835,7 @@ procedure TPasSyntaxTreeBuilder.MainUsedUnitStatement; if Assigned(NameNode) then begin Temp := FStack.Peek; - Temp.SetAttribute(anName, NameNode.GetAttribute(anName)); + Temp.Attribute[anName]:= NameNode.Attribute[anName]; Temp.DeleteChild(NameNode); end; @@ -1845,7 +1847,7 @@ procedure TPasSyntaxTreeBuilder.MainUsedUnitStatement; PathLiteralNode := PathNode.FindNode(ntLiteral); if PathLiteralNode is TValuedSyntaxNode then - FStack.Peek.SetAttribute(anPath, TValuedSyntaxNode(PathLiteralNode).Value); + FStack.Peek.Attribute[anPath]:= TValuedSyntaxNode(PathLiteralNode).Value; finally PathNode.Free; end; @@ -1870,9 +1872,8 @@ procedure TPasSyntaxTreeBuilder.MethodKind; var value: string; begin - value := LowerCase(Lexer.Token); DoHandleString(value); - FStack.Peek.SetAttribute(anKind, value); + FStack.Peek.Attribute[anKind]:= Lexer.Token; inherited; end; @@ -1940,27 +1941,27 @@ procedure TPasSyntaxTreeBuilder.Number; Node: TSyntaxNode; begin Node := FStack.AddValuedChild(ntLiteral, Lexer.Token); - Node.SetAttribute(anType, AttributeValues[atNumeric]); + Node.Attribute[anType]:= AttributeValues[atNumeric]; inherited; end; procedure TPasSyntaxTreeBuilder.ObjectForward; begin - FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]); //#226 - FStack.Peek.SetAttribute(anType, AttributeValues[atObject]); + FStack.Peek.Attribute[anForwarded]:= AttributeValues[atTrue]; + FStack.Peek.Attribute[anType]:= AttributeValues[atObject]; inherited; end; procedure TPasSyntaxTreeBuilder.ObjectNameOfMethod; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntName).Attribute[anName]:= Lexer.Token; inherited; end; procedure TPasSyntaxTreeBuilder.ObjectType; begin - FStack.Push(ntType).SetAttribute(anType, AttributeValues[atObject]); //#229 + FStack.Push(ntType).Attribute[anType]:= AttributeValues[atObject]; try inherited; finally @@ -1995,7 +1996,7 @@ procedure TPasSyntaxTreeBuilder.ParserMessage(Sender: TObject; procedure TPasSyntaxTreeBuilder.OutParameter; begin - FStack.Push(ntParameters).SetAttribute(anKind, AttributeValues[atOut]); + FStack.Push(ntParameters).Attribute[anKind]:= AttributeValues[atOut]; try inherited; finally @@ -2016,7 +2017,7 @@ procedure TPasSyntaxTreeBuilder.ParameterFormal; procedure TPasSyntaxTreeBuilder.ParameterName; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntname).Attribute[anName]:= Lexer.Token; inherited; end; @@ -2028,7 +2029,7 @@ procedure TPasSyntaxTreeBuilder.PointerSymbol; procedure TPasSyntaxTreeBuilder.PointerType; begin - FStack.Push(ntType).SetAttribute(anType, AttributeValues[atPointer]); + FStack.Push(ntType).Attribute[anType]:= AttributeValues[atPointer]; try inherited; finally @@ -2048,7 +2049,7 @@ procedure TPasSyntaxTreeBuilder.PositionalArgument; procedure TPasSyntaxTreeBuilder.ProceduralType; begin - FStack.Push(ntType).SetAttribute(anName, Lexer.Token); + FStack.Push(ntType).Attribute[anName]:= Lexer.Token; try inherited; finally @@ -2069,7 +2070,7 @@ procedure TPasSyntaxTreeBuilder.ProcedureDeclarationSection; procedure TPasSyntaxTreeBuilder.ProcedureHeading; begin - FStack.Peek.SetAttribute(anKind, AttributeValues[atProcedure]); + FStack.Peek.Attribute[anKind]:= AttributeValues[atProcedure]; inherited; end; @@ -2081,7 +2082,7 @@ procedure TPasSyntaxTreeBuilder.ProcedureProcedureName; procedure TPasSyntaxTreeBuilder.PropertyName; begin - FStack.Peek.SetAttribute(anName, Lexer.Token); + FStack.Peek.Attribute[anName]:= Lexer.Token; inherited PropertyName; end; @@ -2109,7 +2110,7 @@ procedure TPasSyntaxTreeBuilder.RecordFieldConstant; begin Node := FStack.PushValuedNode(ntField, Lexer.Token); try - Node.SetAttribute(anType, AttributeValues[atName]); + Node.Attribute[anType]:= AttributeValues[atName]; inherited; finally FStack.Pop; @@ -2183,7 +2184,7 @@ procedure TPasSyntaxTreeBuilder.RequiresIdentifier; FStack.Pop; end; - FStack.AddChild(ntPackage).SetAttribute(anName, NodeListToString(NamesNode)); + FStack.AddChild(ntPackage).Attribute[anName]:= NodeListToString(NamesNode); finally NamesNode.Free; end; @@ -2191,7 +2192,7 @@ procedure TPasSyntaxTreeBuilder.RequiresIdentifier; procedure TPasSyntaxTreeBuilder.RequiresIdentifierId; begin - FStack.AddChild(ntUnknown).SetAttribute(anName, Lexer.Token); + FStack.AddChild(ntUnknown).Attribute[anName]:= Lexer.Token; inherited; end; @@ -2306,7 +2307,7 @@ function TPasSyntaxTreeBuilder.NodeListToString(NamesNode: TSyntaxNode): string; begin if Result <> '' then Result := Result + '.'; - Result := Result + NamePartNode.GetAttribute(anName); + Result := Result + NamePartNode.Attribute[anName]; end; DoHandleString(Result); end; @@ -2428,7 +2429,7 @@ procedure TPasSyntaxTreeBuilder.SimpleStatement; procedure TPasSyntaxTreeBuilder.SimpleType; begin - FStack.Push(ntType).SetAttribute(anName, Lexer.Token); + FStack.Push(ntType).Attribute[anName]:= Lexer.Token; try inherited; finally @@ -2480,8 +2481,8 @@ procedure TPasSyntaxTreeBuilder.StringConst; end; DoHandleString(Str); - Node := FStack.AddValuedChild(ntLiteral, Str); - Node.SetAttribute(anType, AttributeValues[atString]); + Node := FStack.AddValuedChild(ntLiteral, ''''+Str+''''); + Node.Attribute[anType]:= AttributeValues[atString]; end; procedure TPasSyntaxTreeBuilder.StringConstSimple; @@ -2493,13 +2494,13 @@ procedure TPasSyntaxTreeBuilder.StringConstSimple; procedure TPasSyntaxTreeBuilder.StringStatement; begin - FStack.AddChild(ntType).SetAttribute(anName, Lexer.Token); + FStack.AddChild(ntType).Attribute[anName]:= Lexer.Token; inherited; end; procedure TPasSyntaxTreeBuilder.StructuredType; begin - FStack.Push(ntType).SetAttribute(anType, Lexer.Token); + FStack.Push(ntType).Attribute[anType]:= Lexer.Token; try inherited; finally @@ -2509,7 +2510,35 @@ procedure TPasSyntaxTreeBuilder.StructuredType; procedure TPasSyntaxTreeBuilder.SubrangeType; begin - FStack.Push(ntType).SetAttribute(anName, AttributeValues[atSubRange]); + FStack.Push(ntType).Attribute[anName]:= AttributeValues[atSubRange]; + try + inherited; + finally + FStack.Pop; + end; +end; +procedure TPasSyntaxTreeBuilder.TagField; +var + TagNode: TSyntaxNode; + TypeNode: TSyntaxNode; +begin + TagNode:= FStack.Push(ntCaseSelector); + TagNode.Attribute[anKind]:= Lexer.Token; + try + inherited; + TypeNode:= FStack.Peek.FindNode(ntIdentifier); + if (Assigned(TypeNode)) then begin + TagNode.Attribute[anName]:= TagNode.Attribute[anKind]; + TagNode.Attribute[anKind]:= TypeNode.Attribute[anKind]; + TagNode.DeleteChild(TypeNode); + end; + finally + FStack.Pop; + end; +end; +procedure TPasSyntaxTreeBuilder.TagFieldTypeName; +begin + FStack.Push(ntIdentifier).Attribute[anKind]:= Lexer.Token; try inherited; finally @@ -2549,7 +2578,7 @@ procedure TPasSyntaxTreeBuilder.TypeArgs; procedure TPasSyntaxTreeBuilder.TypeDeclaration; begin - FStack.PushCompoundSyntaxNode(ntTypeDecl).SetAttribute(anName, Lexer.Token); + FStack.PushCompoundSyntaxNode(ntTypeDecl).Attribute[anName]:= Lexer.Token; try inherited; SetCurrentCompoundNodesEndPosition; @@ -2572,7 +2601,7 @@ procedure TPasSyntaxTreeBuilder.TypeId; InnerTypeNode := TypeNode.FindNode(ntType); if Assigned(InnerTypeNode) then begin - InnerTypeName := InnerTypeNode.GetAttribute(anName); + InnerTypeName := InnerTypeNode.Attribute[anName]; for SubNode in InnerTypeNode.ChildNodes do TypeNode.AddChild(SubNode.Clone); @@ -2588,7 +2617,7 @@ procedure TPasSyntaxTreeBuilder.TypeId; if TypeName <> '' then TypeName := '.' + TypeName; - TypeName := SubNode.GetAttribute(anName) + TypeName; + TypeName := SubNode.Attribute[anName] + TypeName; TypeNode.DeleteChild(SubNode); end; end; @@ -2598,7 +2627,7 @@ procedure TPasSyntaxTreeBuilder.TypeId; TypeName := InnerTypeName + TypeName; DoHandleString(TypeName); - TypeNode.SetAttribute(anName, TypeName); + TypeNode.Attribute[anName]:= TypeName; finally FStack.Pop; end; @@ -2670,7 +2699,7 @@ procedure TPasSyntaxTreeBuilder.TypeSection; procedure TPasSyntaxTreeBuilder.TypeSimple; begin - FStack.Push(ntType).SetAttribute(anName, Lexer.Token); + FStack.Push(ntType).Attribute[anName]:= Lexer.Token; try inherited; finally @@ -2695,7 +2724,7 @@ procedure TPasSyntaxTreeBuilder.UnitFile; procedure TPasSyntaxTreeBuilder.UnitId; begin - FStack.AddChild(ntUnknown).SetAttribute(anName, Lexer.Token); + FStack.AddChild(ntUnknown).Attribute[anName]:= Lexer.Token; inherited; end; @@ -2712,7 +2741,7 @@ procedure TPasSyntaxTreeBuilder.UnitName; FStack.Pop; end; - FStack.Peek.SetAttribute(anName, NodeListToString(NamesNode)); + FStack.Peek.Attribute[anName]:= NodeListToString(NamesNode); finally NamesNode.Free; end; @@ -2737,7 +2766,7 @@ procedure TPasSyntaxTreeBuilder.UsedUnitName; end; UnitNode := FStack.AddChild(ntUnit); - UnitNode.SetAttribute(anName, NodeListToString(NamesNode)); + UnitNode.Attribute[anName]:= NodeListToString(NamesNode); UnitNode.Col := Position.X; UnitNode.Line := Position.Y; UnitNode.FileName := FileName; @@ -2800,13 +2829,13 @@ procedure TPasSyntaxTreeBuilder.RecordVariantTag; procedure TPasSyntaxTreeBuilder.VarName; begin //FStack.AddValuedChild(ntName, Lexer.Token); - FStack.AddChild(ntName).SetAttribute(anName, Lexer.Token); //#222 + FStack.AddChild(ntName).Attribute[anName]:= Lexer.Token; //#222 inherited; end; procedure TPasSyntaxTreeBuilder.VarParameter; begin - FStack.Push(ntParameters).SetAttribute(anKind, AttributeValues[atVar]); + FStack.Push(ntParameters).Attribute[anKind]:= AttributeValues[atVar]; try inherited; finally @@ -2867,7 +2896,7 @@ procedure TPasSyntaxTreeBuilder.VisibilityStrictPrivate; begin Temp := FStack.Push(ntStrictPrivate); try - Temp.SetAttribute(anVisibility, AttributeValues[atTrue]); + Temp.Attribute[anVisibility]:= AttributeValues[atTrue]; inherited; finally FStack.Pop; @@ -2880,7 +2909,7 @@ procedure TPasSyntaxTreeBuilder.VisibilityPrivate; begin Temp := FStack.Push(ntPrivate); try - Temp.SetAttribute(anVisibility, AttributeValues[atTrue]); + Temp.Attribute[anVisibility]:= AttributeValues[atTrue]; inherited; finally FStack.Pop; @@ -2893,7 +2922,7 @@ procedure TPasSyntaxTreeBuilder.VisibilityStrictProtected; begin Temp := FStack.Push(ntStrictProtected); try - Temp.SetAttribute(anVisibility, AttributeValues[atTrue]); + Temp.Attribute[anVisibility]:= AttributeValues[atTrue]; inherited; finally FStack.Pop; @@ -2906,7 +2935,7 @@ procedure TPasSyntaxTreeBuilder.VisibilityProtected; begin Temp := FStack.Push(ntProtected); try - Temp.SetAttribute(anVisibility, AttributeValues[atTrue]); + Temp.Attribute[anVisibility]:= AttributeValues[atTrue]; inherited; finally FStack.Pop; @@ -2919,7 +2948,7 @@ procedure TPasSyntaxTreeBuilder.VisibilityPublic; begin Temp := FStack.Push(ntPublic); try - Temp.SetAttribute(anVisibility, AttributeValues[atTrue]); + Temp.Attribute[anVisibility]:= AttributeValues[atTrue]; inherited; finally FStack.Pop; @@ -2932,7 +2961,7 @@ procedure TPasSyntaxTreeBuilder.VisibilityPublished; begin Temp := FStack.Push(ntPublished); try - Temp.SetAttribute(anVisibility, AttributeValues[atTrue]); + Temp.Attribute[anVisibility]:= AttributeValues[atTrue]; inherited; finally FStack.Pop; @@ -2986,5 +3015,4 @@ destructor ESyntaxTreeException.Destroy; initialization InitAttributeValues; - end. \ No newline at end of file From 45c50a08ae0111105fb00f1909e9933e56dbb3d6 Mon Sep 17 00:00:00 2001 From: jbontes Date: Thu, 12 Oct 2017 19:29:37 +0200 Subject: [PATCH 18/42] #242 and #243 --- Source/DelphiAST.pas | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 6b4af524..24d94a1c 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -566,7 +566,7 @@ procedure TPasSyntaxTreeBuilder.ArrayDimension; procedure TPasSyntaxTreeBuilder.AsmStatement; begin - FStack.PushCompoundSyntaxNode(ntStatements).SetAttribute(anType, AttributeValues[atAsm]); + FStack.PushCompoundSyntaxNode(ntStatements).Attribute[anType]:= AttributeValues[atAsm]; try inherited; SetCurrentCompoundNodesEndPosition; @@ -1322,7 +1322,7 @@ procedure TPasSyntaxTreeBuilder.EnumeratedType; begin TypeNode := FStack.Push(ntType); try - TypeNode.Attribute[anName]:= AttributeValues[atEnum]; + TypeNode.Attribute[anType]:= AttributeValues[atEnum]; if ScopedEnums then TypeNode.Attribute[anVisibility]:= 'scoped'; inherited; @@ -2301,13 +2301,16 @@ function TPasSyntaxTreeBuilder.Run(SourceStream: TStream): TSyntaxNode; function TPasSyntaxTreeBuilder.NodeListToString(NamesNode: TSyntaxNode): string; var NamePartNode: TSyntaxNode; + Part: string; begin Result := ''; for NamePartNode in NamesNode.ChildNodes do begin - if Result <> '' then + Part:= NamePartNode.Attribute[anName]; + //do not add empty parts (in case non-name and name node are mixed. + if (Result <> '') and (Part <> '') then Result := Result + '.'; - Result := Result + NamePartNode.Attribute[anName]; + Result:= Result + Part; end; DoHandleString(Result); end; @@ -2510,7 +2513,7 @@ procedure TPasSyntaxTreeBuilder.StructuredType; procedure TPasSyntaxTreeBuilder.SubrangeType; begin - FStack.Push(ntType).Attribute[anName]:= AttributeValues[atSubRange]; + FStack.Push(ntType).Attribute[anType]:= AttributeValues[atSubRange]; try inherited; finally @@ -2749,29 +2752,31 @@ procedure TPasSyntaxTreeBuilder.UnitName; procedure TPasSyntaxTreeBuilder.UsedUnitName; var - NamesNode, UnitNode: TSyntaxNode; + UnitNode: TSyntaxNode; Position: TTokenPoint; FileName: string; + i: integer; begin Position := Lexer.PosXY; FileName := Lexer.FileName; - NamesNode := TSyntaxNode.Create(ntUnit); try - FStack.Push(NamesNode); + UnitNode:= FStack.Push(ntUnit); try inherited; finally FStack.Pop; end; - UnitNode := FStack.AddChild(ntUnit); - UnitNode.Attribute[anName]:= NodeListToString(NamesNode); + UnitNode.Attribute[anName]:= NodeListToString(UnitNode); UnitNode.Col := Position.X; UnitNode.Line := Position.Y; UnitNode.FileName := FileName; finally - NamesNode.Free; + for i:= UnitNode.ChildCount -1 downto 0 do begin + if (UnitNode.ChildNode[i].HasAttribute(anName)) then + UnitNode.DeleteChild(UnitNode.ChildNode[i]); + end; end; end; From 0160fc3936bdf6e536ed77ffd6d1eaa631133c48 Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 13 Oct 2017 14:56:56 +0200 Subject: [PATCH 19/42] #243 retracted, uses in not allowed outside program or library --- Source/DelphiAST.pas | 20 ++++++++------------ Source/SimpleParser/SimpleParser.pas | 23 ++++++++++++----------- 2 files changed, 20 insertions(+), 23 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 24d94a1c..30f8dbec 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -2301,16 +2301,13 @@ function TPasSyntaxTreeBuilder.Run(SourceStream: TStream): TSyntaxNode; function TPasSyntaxTreeBuilder.NodeListToString(NamesNode: TSyntaxNode): string; var NamePartNode: TSyntaxNode; - Part: string; begin Result := ''; for NamePartNode in NamesNode.ChildNodes do begin - Part:= NamePartNode.Attribute[anName]; - //do not add empty parts (in case non-name and name node are mixed. - if (Result <> '') and (Part <> '') then + if (Result <> '') then Result := Result + '.'; - Result:= Result + Part; + Result:= Result + NamePartNode.Attribute[anName]; end; DoHandleString(Result); end; @@ -2752,7 +2749,7 @@ procedure TPasSyntaxTreeBuilder.UnitName; procedure TPasSyntaxTreeBuilder.UsedUnitName; var - UnitNode: TSyntaxNode; + NamesNode, UnitNode: TSyntaxNode; Position: TTokenPoint; FileName: string; i: integer; @@ -2760,23 +2757,22 @@ procedure TPasSyntaxTreeBuilder.UsedUnitName; Position := Lexer.PosXY; FileName := Lexer.FileName; + NamesNode:= TSyntaxNode.Create(ntUnit); try - UnitNode:= FStack.Push(ntUnit); + FStack.Push(NamesNode); try inherited; finally FStack.Pop; end; - UnitNode.Attribute[anName]:= NodeListToString(UnitNode); + UnitNode := FStack.AddChild(ntUnit); + UnitNode.Attribute[anName]:= NodeListToString(NamesNode); UnitNode.Col := Position.X; UnitNode.Line := Position.Y; UnitNode.FileName := FileName; finally - for i:= UnitNode.ChildCount -1 downto 0 do begin - if (UnitNode.ChildNode[i].HasAttribute(anName)) then - UnitNode.DeleteChild(UnitNode.ChildNode[i]); - end; + NamesNode.Free; end; end; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 09beb326..3f369273 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -1190,17 +1190,6 @@ procedure TmwSimplePasPar.ProgramBlock; Block; end; -procedure TmwSimplePasPar.MainUsesClause; -begin - Expected(ptUses); - MainUsedUnitStatement; - while TokenID = ptComma do - begin - NextToken; - MainUsedUnitStatement; - end; - Semicolon; -end; procedure TmwSimplePasPar.MethodKind; begin @@ -1216,6 +1205,18 @@ procedure TmwSimplePasPar.MethodKind; end; end; +procedure TmwSimplePasPar.MainUsesClause; +begin + Expected(ptUses); + MainUsedUnitStatement; + while TokenID = ptComma do + begin + NextToken; + MainUsedUnitStatement; + end; + Semicolon; +end; + procedure TmwSimplePasPar.MainUsedUnitStatement; begin MainUsedUnitName; From cfa5cc3795340c0db7ec65788a067fd1ac07c3c0 Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 13 Oct 2017 16:19:50 +0200 Subject: [PATCH 20/42] Fix for #246 varargs, #245 proc of object, #244 automated section --- Source/DelphiAST.Consts.pas | 15 +++++--- Source/DelphiAST.pas | 56 +++++++++++++++++++++++++--- Source/SimpleParser/SimpleParser.pas | 3 +- 3 files changed, 61 insertions(+), 13 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index d8ae1160..ca0333b5 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -33,6 +33,15 @@ interface ntIn, ntIs, + //Allow the use of [ntStrictPrivate..ntAutomated]. + ntStrictPrivate, + ntPrivate, + ntStrictProtected, + ntProtected, + ntPublic, + ntPublished, + ntAutomated, + ntUnknown, ntAlignmentParam, ntAnonymousMethod, @@ -100,11 +109,7 @@ interface ntParameters, ntPath, ntPositionalArgument, - ntProtected, - ntPrivate, ntProperty, - ntPublic, - ntPublished, ntRaise, ntRead, ntRecordConstraint, @@ -121,8 +126,6 @@ interface ntSet, ntStatement, ntStatements, - ntStrictPrivate, - ntStrictProtected, ntSubrange, ntThen, ntTo, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 30f8dbec..f1b37cf7 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -136,6 +136,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure DirectiveCalling; override; procedure DirectiveInline; override; procedure DirectiveSealed; override; + procedure DirectiveVarargs; override; procedure DispInterfaceForward; override; procedure DotOp; override; procedure ElseStatement; override; @@ -202,6 +203,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ParameterName; override; procedure PointerSymbol; override; procedure PointerType; override; + procedure ProceduralDirectiveOf; override; procedure ProceduralType; override; procedure ProcedureHeading; override; procedure ProcedureDeclarationSection; override; @@ -258,6 +260,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure VarName; override; procedure VarParameter; override; procedure VarSection; override; + procedure VisibilityAutomated; override; procedure VisibilityPrivate; override; procedure VisibilityProtected; override; procedure VisibilityPublic; override; @@ -329,7 +332,8 @@ TStringStreamHelper = class helper for TStringStream TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atOperator, atClassOf, atClass, atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric, atOut, atPointer, atName, atString, atSubRange, atVar, atType{ExplicitType}, - atObject, atSealed, atAbstract, atBegin); + atObject, atSealed, atAbstract, atBegin, atOf_Object{procedure of object}, + atVarargs, atExternal{Varargs and external are mutually exclusive}); var AttributeValues: array[TAttributeValue] of string; @@ -337,9 +341,13 @@ TStringStreamHelper = class helper for TStringStream procedure InitAttributeValues; var value: TAttributeValue; + AttributeStr: string; begin - for value := Low(TAttributeValue) to High(TAttributeValue) do - AttributeValues[value] := Copy(LowerCase(GetEnumName(TypeInfo(TAttributeValue), Ord(value))), 3); + for value := Low(TAttributeValue) to High(TAttributeValue) do begin + AttributeStr:= Copy(LowerCase(GetEnumName(TypeInfo(TAttributeValue), Ord(value))), 3); + AttributeStr:= StringReplace(AttributeStr, '_', ' ', [rfReplaceAll]); + AttributeValues[value] := AttributeStr; + end; end; procedure AssignLexerPositionToNode(const Lexer: TPasLexer; const Node: TSyntaxNode); @@ -1284,6 +1292,16 @@ procedure TPasSyntaxTreeBuilder.DirectiveSealed; inherited; end; +procedure TPasSyntaxTreeBuilder.DirectiveVarargs; +begin + FStack.Push(ntExternal).Attribute[anKind]:= AttributeValues[atVarArgs]; + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.DispInterfaceForward; begin FStack.Peek.Attribute[anForwarded]:= AttributeValues[atTrue]; @@ -1482,15 +1500,17 @@ procedure TPasSyntaxTreeBuilder.ExternalDependency; FStack.Pop; end; end; + procedure TPasSyntaxTreeBuilder.ExternalDirective; begin - FStack.Push(ntExternal); + FStack.Push(ntExternal).Attribute[anKind]:= AttributeValues[atExternal]; try inherited; finally FStack.Pop; end; end; + procedure TPasSyntaxTreeBuilder.FieldList; var Fields, Temp: TSyntaxNode; @@ -2047,9 +2067,22 @@ procedure TPasSyntaxTreeBuilder.PositionalArgument; end; end; +procedure TPasSyntaxTreeBuilder.ProceduralDirectiveOf; +var + Proc: TSyntaxNode; +begin + //anType is already used for set/enum/subrange/class/record/interface/object. + //It could be reused for this data, but it's a directive, not a type as such. + //And it's to close to `object` proper. + //It should not be a subnode, because only 'of object' is allowed. + FStack.Peek.Attribute[anKind]:= AttributeValues[atOf_Object]; + inherited; +end; + procedure TPasSyntaxTreeBuilder.ProceduralType; begin - FStack.Push(ntType).Attribute[anName]:= Lexer.Token; + //procedure/function is a reserved word, so it cannot be the same as an identifier. + FStack.Push(ntType).Attribute[anType]:= Lexer.Token; try inherited; finally @@ -2969,6 +3002,19 @@ procedure TPasSyntaxTreeBuilder.VisibilityPublished; end; end; +procedure TPasSyntaxTreeBuilder.VisibilityAutomated; +var + Temp: TSyntaxNode; +begin + Temp := FStack.Push(ntAutomated); + try + Temp.Attribute[anVisibility]:= AttributeValues[atTrue]; + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.WhileStatement; begin FStack.Push(ntWhile); diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 3f369273..166e43cd 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -1190,7 +1190,6 @@ procedure TmwSimplePasPar.ProgramBlock; Block; end; - procedure TmwSimplePasPar.MethodKind; begin case TokenID of @@ -4024,7 +4023,7 @@ procedure TmwSimplePasPar.ProceduralType; end; while TheTokenID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, - ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, ptStatic, ptInline] do + ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, ptStatic, ptInline, ptVarargs] do // DR 2001-11-14 no checking for deprecated etc. since it's captured by the typedecl begin if TokenID = ptSemiColon then Semicolon; From 21d28728f2421204b54e0264349445c203da086d Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 13 Oct 2017 20:00:21 +0200 Subject: [PATCH 21/42] Fix for #62, #247 hinting directives --- Source/DelphiAST.Consts.pas | 4 +++ Source/DelphiAST.pas | 49 ++++++++++++++++++++++++++-- Source/SimpleParser/SimpleParser.pas | 4 +-- 3 files changed, 53 insertions(+), 4 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index ca0333b5..adaf54d8 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -65,6 +65,7 @@ interface ntContains, ntDefault, ntDependency, + ntDeprecated, ntDimension, ntDownTo, ntElement, @@ -74,6 +75,7 @@ interface ntExcept, ntExceptElse, ntExceptionHandler, + ntExperimental, ntExports, ntExpression, ntExpressions, @@ -99,6 +101,7 @@ interface ntLabel, ntLabeledStatement, ntLHS, + ntLibrary, ntLiteral, ntMessage, ntMethod, @@ -108,6 +111,7 @@ interface ntParameter, ntParameters, ntPath, + ntPlatform, ntPositionalArgument, ntProperty, ntRaise, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index f1b37cf7..d8d21d94 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -134,7 +134,11 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure DirectiveBinding; override; procedure DirectiveBindingMessage; override; procedure DirectiveCalling; override; + procedure DirectiveDeprecated; override; + procedure DirectiveExperimental; override; procedure DirectiveInline; override; + procedure DirectiveLibrary; override; + procedure DirectivePlatForm; override; procedure DirectiveSealed; override; procedure DirectiveVarargs; override; procedure DispInterfaceForward; override; @@ -1279,11 +1283,52 @@ procedure TPasSyntaxTreeBuilder.DirectiveCalling; inherited; end; +procedure TPasSyntaxTreeBuilder.DirectiveDeprecated; +begin + FStack.Push(ntDeprecated); + try + inherited; + finally + FStack.Pop; + end; +end; + +procedure TPasSyntaxTreeBuilder.DirectiveExperimental; +begin + FStack.Push(ntExperimental); + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.DirectiveInline; begin FStack.Peek.Attribute[anInline]:= AttributeValues[atTrue]; inherited; end; + +procedure TPasSyntaxTreeBuilder.DirectiveLibrary; +begin + FStack.Push(ntLibrary); + try + inherited; + finally + FStack.Pop; + end; +end; + +procedure TPasSyntaxTreeBuilder.DirectivePlatForm; +begin + FStack.Push(ntPlatform); + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.DirectiveSealed; begin //hack, must go to a better attributeType, however sealed, abstract cannot coexist @@ -2514,14 +2559,14 @@ procedure TPasSyntaxTreeBuilder.StringConst; end; DoHandleString(Str); - Node := FStack.AddValuedChild(ntLiteral, ''''+Str+''''); + Node := FStack.AddValuedChild(ntLiteral, Str); Node.Attribute[anType]:= AttributeValues[atString]; end; procedure TPasSyntaxTreeBuilder.StringConstSimple; begin //TODO support ptAsciiChar - FStack.AddValuedChild(ntLiteral, AnsiDequotedStr(Lexer.Token, '''')); + FStack.AddValuedChild(ntLiteral, {AnsiDequotedStr(}Lexer.Token{, '''')}); inherited; end; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 166e43cd..00c4e3d4 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -4624,7 +4624,7 @@ procedure TmwSimplePasPar.ProcedureDeclarationSection; else begin SynError(InvalidProcedureDeclarationSection); - end; + end; end; end; @@ -5308,7 +5308,7 @@ procedure TmwSimplePasPar.DirectiveDeprecated; begin ExpectedEx(ptDeprecated); if TokenID = ptStringConst then - NextToken; + StringConst; end; procedure TmwSimplePasPar.DirectiveInline; From 5e647753fa1c9dc89eacf993592d810d188d3d10 Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 13 Oct 2017 23:06:58 +0200 Subject: [PATCH 22/42] #248 static methodbinding --- Source/DelphiAST.pas | 14 +++++++------ Source/SimpleParser/SimpleParser.pas | 30 ++++++++++++++++++---------- 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index d8d21d94..3e1e6e3d 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -337,7 +337,8 @@ TStringStreamHelper = class helper for TStringStream atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric, atOut, atPointer, atName, atString, atSubRange, atVar, atType{ExplicitType}, atObject, atSealed, atAbstract, atBegin, atOf_Object{procedure of object}, - atVarargs, atExternal{Varargs and external are mutually exclusive}); + atVarargs, atExternal{Varargs and external are mutually exclusive}, + atStatic); var AttributeValues: array[TAttributeValue] of string; @@ -1242,28 +1243,29 @@ procedure TPasSyntaxTreeBuilder.DestructorName; procedure TPasSyntaxTreeBuilder.DirectiveAbstract; begin - //anAbstract Attribute can contain both 'sealed' and 'abstract' + //anAbstract Attribute can contain either 'sealed' or 'abstract' or `final` FStack.Peek.Attribute[anAbstract]:= Lexer.Token; inherited; end; + procedure TPasSyntaxTreeBuilder.DirectiveBinding; var - token: string; + Token: string; begin token := Lexer.Token; // Method bindings: - if SameText(token, 'override') or SameText(token, 'virtual') or SameText(token, 'dynamic') + if SameText(Token, 'override') or SameText(token, 'virtual') + or SameText(Token, 'dynamic') or SameText(Token, 'static') then FStack.Peek.Attribute[anMethodBinding]:= Token // Other directives else if SameText(token, 'reintroduce') then FStack.Peek.Attribute[anReintroduce]:= AttributeValues[atTrue] - else if SameText(token, 'overload') then + else if SameText(Token, 'overload') then FStack.Peek.Attribute[anOverload]:= AttributeValues[atTrue] else if SameText(Token, 'abstract') or SameText(Token, 'final') then FStack.Peek.Attribute[anAbstract]:= Token; - inherited; end; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 00c4e3d4..59435b24 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -299,6 +299,7 @@ TmwSimplePasPar = class(TObject) procedure DestructorHeading; virtual; procedure DestructorName; virtual; procedure Directive16Bit; virtual; + procedure DirectiveAssembler; virtual; procedure DirectiveAbstract; virtual; procedure DirectiveBinding; virtual; procedure DirectiveBindingMessage; virtual; @@ -312,6 +313,7 @@ TmwSimplePasPar = class(TObject) procedure DirectivePlatform; virtual; procedure DirectiveVarargs; virtual; procedure DirectiveSealed; virtual; + procedure DirectiveStatic; virtual; procedure DispInterfaceForward; virtual; procedure DispIDSpecifier; virtual; procedure DotOp; virtual; @@ -1838,11 +1840,16 @@ procedure TmwSimplePasPar.DirectiveAbstract; ExpectedEx(ptAbstract); //abstract is an ExID. end; +procedure TmwSimplePasPar.DirectiveAssembler; +begin + ExpectedEx(ptAssembler); +end; + procedure TmwSimplePasPar.DirectiveBinding; begin case ExID of ptAbstract, ptVirtual, ptDynamic, ptMessage, ptOverride, ptOverload, - ptReintroduce, ptFinal: begin + ptReintroduce, ptFinal, ptStatic: begin NextToken; end else begin @@ -4659,17 +4666,13 @@ procedure TmwSimplePasPar.ProceduralDirective; begin ExternalDirective; end; - ptDynamic, ptMessage, ptOverload, ptOverride, ptReintroduce, ptVirtual: + ptDynamic, ptMessage, ptOverload, ptOverride, ptReintroduce, ptVirtual, ptStatic: begin DirectiveBinding; end; ptAssembler: begin - NextToken; - end; - ptStatic: - begin - NextToken; + DirectiveAssembler; end; ptInline: begin @@ -4714,15 +4717,14 @@ procedure TmwSimplePasPar.ExportedHeading; end; if TokenID = ptSemiColon then Semicolon; - //TODO: Add FINAL while ExID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, ptDeprecated, ptLibrary, ptPlatform, ptLocal, ptVarargs, - ptStatic, ptInline, ptAssembler, ptForward, ptDelayed] do + ptStatic, ptInline, ptAssembler, ptForward, ptDelayed, ptFinal] do begin case ExID of - ptAssembler: NextToken; + //ptAssembler: DirectiveAssembler; ptForward: ForwardDeclaration; else ProceduralDirective; @@ -5294,9 +5296,12 @@ procedure TmwSimplePasPar.NameSpecifier; procedure TmwSimplePasPar.ClassTypeEnd; begin + //should be while? because all hinting directive can occur. case ExID of ptExperimental: DirectiveExperimental; ptDeprecated: DirectiveDeprecated; + ptPlatform: DirectivePlatform; + ptLibrary: DirectiveLibrary; end; end; @@ -5343,6 +5348,11 @@ procedure TmwSimplePasPar.DirectiveSealed; Expected(ptSealed); end; +procedure TmwSimplePasPar.DirectiveStatic; +begin + ExpectedEx(ptStatic); +end; + procedure TmwSimplePasPar.EnumeratedTypeItem; begin QualifiedIdentifier; From 5c34b3dce456764784923e998bf09c9b82d11653 Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 13 Oct 2017 23:34:36 +0200 Subject: [PATCH 23/42] #249 `assembler` inline directive --- Source/DelphiAST.pas | 6 ++++-- Source/SimpleParser/SimpleParser.pas | 26 +++++++++++++++++++------- 2 files changed, 23 insertions(+), 9 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 3e1e6e3d..544bc55b 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -1254,7 +1254,6 @@ procedure TPasSyntaxTreeBuilder.DirectiveBinding; begin token := Lexer.Token; // Method bindings: - or SameText(token, 'dynamic') if SameText(Token, 'override') or SameText(token, 'virtual') or SameText(Token, 'dynamic') or SameText(Token, 'static') then @@ -1271,6 +1270,8 @@ procedure TPasSyntaxTreeBuilder.DirectiveBinding; procedure TPasSyntaxTreeBuilder.DirectiveBindingMessage; begin + //message is a method binding directive, for correctness we should record this. + FStack.Peek.Attribute[anMethodBinding]:= 'message'; FStack.Push(ntMessage); try inherited; @@ -1307,7 +1308,8 @@ procedure TPasSyntaxTreeBuilder.DirectiveExperimental; procedure TPasSyntaxTreeBuilder.DirectiveInline; begin - FStack.Peek.Attribute[anInline]:= AttributeValues[atTrue]; + //'inline' and 'assembler' are both inline directives. + FStack.Peek.Attribute[anInline]:= Lexer.Token; inherited; end; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 59435b24..637beb5c 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -213,7 +213,8 @@ TmwSimplePasPar = class(TObject) procedure SetOnComment(const Value: TCommentEvent); inline; protected procedure Expected(Sym: TptTokenKind); virtual; - procedure ExpectedEx(Sym: TptTokenKind); virtual; + procedure ExpectedEx(Sym: TptTokenKind); overload; virtual; + procedure ExpectedEx(Syms: array of TptTokenKind); overload; virtual; procedure ExpectedFatal(Sym: TptTokenKind); virtual; procedure HandlePtCompDirect(Sender: TmwBasePasLex); virtual; procedure HandlePtDefineDirect(Sender: TmwBasePasLex); virtual; @@ -781,6 +782,21 @@ procedure TmwSimplePasPar.Expected(Sym: TptTokenKind); NextToken; end; +procedure TmwSimplePasPar.ExpectedEx(Syms: array of TptTokenKind); +var + Sym, S: TptTokenKind; + Found: boolean; +begin + Found:= false; + for S in Syms do begin + Found:= (S = Lexer.ExID); + if (Found) then break; + end; + FOnMessage(Self, meError, Format(rsExpected, ['EX:' + TokenName(Sym), FLexer.Token]), + FLexer.PosXY.X, FLexer.PosXY.Y); + end; +end; + procedure TmwSimplePasPar.ExpectedEx(Sym: TptTokenKind); begin if Sym <> Lexer.ExID then @@ -4670,11 +4686,7 @@ procedure TmwSimplePasPar.ProceduralDirective; begin DirectiveBinding; end; - ptAssembler: - begin - DirectiveAssembler; - end; - ptInline: + ptInline, ptAssembler: begin DirectiveInline; end; @@ -5318,7 +5330,7 @@ procedure TmwSimplePasPar.DirectiveDeprecated; procedure TmwSimplePasPar.DirectiveInline; begin - Expected(ptInline); + ExpectedEx([ptInline, ptAssembler]); end; procedure TmwSimplePasPar.DirectiveLibrary; From 8ae51f0610a1e70fe40f7010265bfd3824794a36 Mon Sep 17 00:00:00 2001 From: jbontes Date: Sat, 14 Oct 2017 21:50:36 +0200 Subject: [PATCH 24/42] #248 static + 249 assembler inline directive --- Source/SimpleParser/SimpleParser.pas | 29 +++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 637beb5c..21eeeda1 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -193,6 +193,7 @@ ESyntaxError = class(Exception) property PosXY: TTokenPoint read FPosXY write FPosXY; end; + TptTokenKinds = set of TptTokenKind; TmwSimplePasPar = class(TObject) private FOnMessage: TMessageEvent; @@ -214,7 +215,7 @@ TmwSimplePasPar = class(TObject) protected procedure Expected(Sym: TptTokenKind); virtual; procedure ExpectedEx(Sym: TptTokenKind); overload; virtual; - procedure ExpectedEx(Syms: array of TptTokenKind); overload; virtual; + procedure ExpectedEx(const Syms: TptTokenKinds); overload; virtual; procedure ExpectedFatal(Sym: TptTokenKind); virtual; procedure HandlePtCompDirect(Sender: TmwBasePasLex); virtual; procedure HandlePtDefineDirect(Sender: TmwBasePasLex); virtual; @@ -782,18 +783,24 @@ procedure TmwSimplePasPar.Expected(Sym: TptTokenKind); NextToken; end; -procedure TmwSimplePasPar.ExpectedEx(Syms: array of TptTokenKind); +procedure TmwSimplePasPar.ExpectedEx(const Syms: TptTokenKinds); var - Sym, S: TptTokenKind; - Found: boolean; -begin - Found:= false; - for S in Syms do begin - Found:= (S = Lexer.ExID); - if (Found) then break; - end; - FOnMessage(Self, meError, Format(rsExpected, ['EX:' + TokenName(Sym), FLexer.Token]), + Sym: TptTokenKind; + Symbols: string; + Optional: string; +begin + if (Lexer.ExID in Syms) then NextToken + else if (Lexer.TokenID = ptNull) or Assigned(FOnMessage) then begin + for Sym in Syms do begin + Symbols:= Symbols + Optional + TokenName(Sym); + Optional:= ' or '; + end; + if (Lexer.TokenID = ptNull) then + raise ESyntaxError.CreatePos(Format(rsExpected, [Symbols, rsEndOfFile]), FLexer.PosXY) + else if Assigned(FOnMessage) then begin + FOnMessage(Self, meError, Format(rsExpected, ['EX:' + Symbols, FLexer.Token]), FLexer.PosXY.X, FLexer.PosXY.Y); + end; end; end; From 6d607075126b1b1787e73a7bd79f7da17fdd84a5 Mon Sep 17 00:00:00 2001 From: jbontes Date: Sun, 15 Oct 2017 19:03:40 +0200 Subject: [PATCH 25/42] #250 record constants are not recorded correctly This is esp. evident in the following example: const OperatorsInfo: array [0..2] of TOperatorInfo = ((Typ: ntAddr; AssocType: atRight), (Typ: ntDeref; AssocType: atLeft), (Typ: ntGeneric; AssocType: atRight)); All constants are incorrectly listed as one long list, instead of as separate records. --- Source/DelphiAST.Consts.pas | 1 + Source/DelphiAST.pas | 26 ++++++++++++++++++++++---- 2 files changed, 23 insertions(+), 4 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index adaf54d8..8d028578 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -116,6 +116,7 @@ interface ntProperty, ntRaise, ntRead, + ntRecordConstant, ntRecordConstraint, ntRecordVariant, ntRepeat, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 544bc55b..6459c9a6 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -216,6 +216,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure PropertyParameterList; override; procedure RaiseStatement; override; procedure RecordConstraint; override; + procedure RecordConstant; override; procedure RecordFieldConstant; override; procedure RecordType; override; procedure RecordVariant; override; @@ -333,7 +334,7 @@ TStringStreamHelper = class helper for TStringStream // do not use const strings here to prevent allocating new strings every time type - TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atOperator, atClassOf, atClass, + TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atOperator, atClass_Of, atClass, atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric, atOut, atPointer, atName, atString, atSubRange, atVar, atType{ExplicitType}, atObject, atSealed, atAbstract, atBegin, atOf_Object{procedure of object}, @@ -984,7 +985,7 @@ procedure TPasSyntaxTreeBuilder.ClassProperty; procedure TPasSyntaxTreeBuilder.ClassReferenceType; begin - FStack.Push(ntType).Attribute[anType]:= AttributeValues[atClassof]; + FStack.Push(ntType).Attribute[anType]:= AttributeValues[atClass_of]; try inherited; finally @@ -1143,6 +1144,15 @@ procedure TPasSyntaxTreeBuilder.ConstructorConstraint; end; end; +procedure TPasSyntaxTreeBuilder.RecordConstant; +begin + FStack.Push(ntRecordConstant); + try + inherited; + finally + FStack.Pop; + end; +end; procedure TPasSyntaxTreeBuilder.RecordConstraint; begin FStack.Push(ntRecordConstraint); @@ -2190,9 +2200,17 @@ procedure TPasSyntaxTreeBuilder.RecordFieldConstant; var Node: TSyntaxNode; begin - Node := FStack.PushValuedNode(ntField, Lexer.Token); + //A field in a record constant should have exactly the same layout + //as a field in a class. + //ntField (class) + //+-- ntName (anName = name) + //+-- ntType + //Recordconstant + //ntField (recordconstant) + //+-- ntName + //+-- ntExpression. + FStack.Push(ntField).AddChild(ntName).Attribute[anName]:= Lexer.Token; try - Node.Attribute[anType]:= AttributeValues[atName]; inherited; finally FStack.Pop; From 7ef300fba80588f54c2891a5fd6fe15e41d92810 Mon Sep 17 00:00:00 2001 From: jbontes Date: Mon, 16 Oct 2017 12:43:08 +0200 Subject: [PATCH 26/42] #251 Also parse programs, libs and packages --- Source/DelphiAST.Consts.pas | 1 + Source/DelphiAST.pas | 42 +++++++++++++++++++++++++++++++------ 2 files changed, 37 insertions(+), 6 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 8d028578..196594c5 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -113,6 +113,7 @@ interface ntPath, ntPlatform, ntPositionalArgument, + ntProgram, ntProperty, ntRaise, ntRead, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 6459c9a6..fc825c07 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -190,6 +190,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure InterfaceType; override; procedure LabeledStatement; override; procedure LabelId; override; + procedure LibraryFile; override; procedure MainUsesClause; override; procedure MainUsedUnitStatement; override; procedure MethodKind; override; @@ -203,6 +204,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ObjectNameOfMethod; override; procedure ObjectType; override; procedure OutParameter; override; + procedure PackageFile; override; procedure ParameterFormal; override; procedure ParameterName; override; procedure PointerSymbol; override; @@ -212,6 +214,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ProcedureHeading; override; procedure ProcedureDeclarationSection; override; procedure ProcedureProcedureName; override; + procedure ProgramFile; override; procedure PropertyName; override; procedure PropertyParameterList; override; procedure RaiseStatement; override; @@ -1901,6 +1904,15 @@ procedure TPasSyntaxTreeBuilder.LabelId; inherited; end; +procedure TPasSyntaxTreeBuilder.LibraryFile; +begin + //Assert(FStack.Peek.ParentNode = nil); + FStack.Push(TSyntaxNode.Create(ntLibrary)); + AssignLexerPositionToNode(Lexer, FStack.Peek); + inherited; + //Stack.pop is done in `Run` +end; + procedure TPasSyntaxTreeBuilder.MainUsedUnitStatement; var NameNode, PathNode, PathLiteralNode, Temp: TSyntaxNode; @@ -2083,6 +2095,15 @@ procedure TPasSyntaxTreeBuilder.OutParameter; end; end; +procedure TPasSyntaxTreeBuilder.PackageFile; +begin + //Assert(FStack.Peek.ParentNode = nil); + FStack.Push(TSyntaxNode.Create(ntPackage)); + AssignLexerPositionToNode(Lexer, FStack.Peek); + inherited; + //Stack.pop is done in `Run` +end; + procedure TPasSyntaxTreeBuilder.ParameterFormal; begin FStack.Push(ntParameters); @@ -2172,6 +2193,15 @@ procedure TPasSyntaxTreeBuilder.ProcedureProcedureName; inherited; end; +procedure TPasSyntaxTreeBuilder.ProgramFile; +begin + //Assert(FStack.Peek.ParentNode = nil); + FStack.Push(TSyntaxNode.Create(ntProgram)); + AssignLexerPositionToNode(Lexer, FStack.Peek); + inherited; + //Stack.pop is done in `Run` +end; + procedure TPasSyntaxTreeBuilder.PropertyName; begin FStack.Peek.Attribute[anName]:= Lexer.Token; @@ -2375,14 +2405,14 @@ class function TPasSyntaxTreeBuilder.Run(const FileName: string; function TPasSyntaxTreeBuilder.Run(SourceStream: TStream): TSyntaxNode; begin - Result := TSyntaxNode.Create(ntUnit); + Result:= nil; try FStack.Clear; - FStack.Push(Result); try self.OnMessage := ParserMessage; inherited Run('', SourceStream); finally + Result:= FStack.Peek; FStack.Pop; end; except @@ -2814,12 +2844,12 @@ procedure TPasSyntaxTreeBuilder.UnaryMinus; end; procedure TPasSyntaxTreeBuilder.UnitFile; -var - Temp: TSyntaxNode; begin - Temp := FStack.Peek; - AssignLexerPositionToNode(Lexer, Temp); + //Assert(FStack.Peek.ParentNode = nil); + FStack.Push(TSyntaxNode.Create(ntUnit)); + AssignLexerPositionToNode(Lexer, FStack.Peek); inherited; + //Stack.pop is done in `Run` end; procedure TPasSyntaxTreeBuilder.UnitId; From 468a2bed0b47b6283a3bb619caf5a121ef258750 Mon Sep 17 00:00:00 2001 From: jbontes Date: Mon, 16 Oct 2017 14:26:13 +0200 Subject: [PATCH 27/42] #252 record compiler directive --- Source/DelphiAST.Consts.pas | 1 + Source/DelphiAST.pas | 7 +++++++ Source/SimpleParser/SimpleParser.pas | 13 +++++++++---- 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 196594c5..b2a27826 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -58,6 +58,7 @@ interface ntCaseLabels, ntCaseSelector, ntClassConstraint, + ntCompilerDirective, ntConstant, ntConstants, ntConstraints, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index fc825c07..0628d913 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -117,6 +117,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ClassProperty; override; procedure ClassReferenceType; override; procedure ClassType; override; + procedure CompilerDirective; override; procedure CompoundStatement; override; procedure ConstParameter; override; procedure ConstantDeclaration; override; @@ -1051,6 +1052,12 @@ procedure TPasSyntaxTreeBuilder.ConstructorName; inherited; end; +procedure TPasSyntaxTreeBuilder.CompilerDirective; +begin + FStack.AddValuedChild(ntCompilerDirective, Lexer.Token); + inherited; +end; + procedure TPasSyntaxTreeBuilder.CompoundStatement; begin FStack.PushCompoundSyntaxNode(ntStatements).Attribute[anKind]:= AttributeValues[atBegin]; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 21eeeda1..1b956fe0 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -279,6 +279,7 @@ TmwSimplePasPar = class(TObject) procedure ClassType; virtual; procedure ClassTypeEnd; virtual; procedure ClassVisibility; virtual; + procedure CompilerDirective; virtual; procedure CompoundStatement; virtual; procedure ConstantColon; virtual; procedure ConstantDeclaration; virtual; @@ -840,9 +841,10 @@ procedure TmwSimplePasPar.ExpectedFatal(Sym: TptTokenKind); procedure TmwSimplePasPar.HandlePtCompDirect(Sender: TmwBasePasLex); begin - if Assigned(FOnMessage) then - FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); - Sender.Next; + CompilerDirective; + //if Assigned(FOnMessage) then + // FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); + //Sender.Next; end; procedure TmwSimplePasPar.HandlePtDefineDirect(Sender: TmwBasePasLex); @@ -5044,7 +5046,10 @@ procedure TmwSimplePasPar.Resident; ExpectedEx(ptResident); end; - +procedure TmwSimplePasPar.CompilerDirective; +begin + Expected(ptCompDirect); +end; procedure TmwSimplePasPar.CompoundStatement; begin From 602e980a94c9fca156e137bf388432644eb7b3a1 Mon Sep 17 00:00:00 2001 From: jbontes Date: Mon, 16 Oct 2017 18:01:56 +0200 Subject: [PATCH 28/42] #35 More capable {$IF ... } handling It can parse arbitrarily complex expressions and also deal with more complex comparisons and floating point numbers. --- Source/DelphiAST.Classes.pas | 4 - Source/DelphiAST.pas | 10 +- Source/SimpleParser/SimpleParser.Lexer.pas | 378 +++++++++++++++------ Source/SimpleParser/SimpleParser.pas | 3 +- 4 files changed, 278 insertions(+), 117 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 0b0ae36d..e4284a09 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -169,15 +169,11 @@ TOperators = class { TOperators } class function TOperators.GetItem(Typ: TSyntaxNodeType): TOperatorInfo; -var - i: Integer; begin if (Typ in [ntAddr..ntIs]) then Exit(OperatorsInfo[Ord(Typ) - Ord(ntAddr)]); //#224 end; class function TOperators.IsOpName(Typ: TSyntaxNodeType): Boolean; -var - i: Integer; begin Result:= (Typ in [ntAddr..ntIs]); end; diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 0628d913..75b00cbb 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -139,7 +139,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure DirectiveExperimental; override; procedure DirectiveInline; override; procedure DirectiveLibrary; override; - procedure DirectivePlatForm; override; + procedure DirectivePlatform; override; procedure DirectiveSealed; override; procedure DirectiveVarargs; override; procedure DispInterfaceForward; override; @@ -1055,6 +1055,7 @@ procedure TPasSyntaxTreeBuilder.ConstructorName; procedure TPasSyntaxTreeBuilder.CompilerDirective; begin FStack.AddValuedChild(ntCompilerDirective, Lexer.Token); + inherited; end; @@ -1728,7 +1729,7 @@ procedure TPasSyntaxTreeBuilder.FunctionMethodName; procedure TPasSyntaxTreeBuilder.FunctionProcedureName; //#221 record method type params explicitly, keep the full name as well. var - ChildNode, NameNode, TypeParam, TypeNode, Temp, TypeParams: TSyntaxNode; + ChildNode, NameNode, TypeParam: TSyntaxNode; FullName, Dot, Comma: string; begin //Temp:= FStack.Peek; @@ -2155,8 +2156,6 @@ procedure TPasSyntaxTreeBuilder.PositionalArgument; end; procedure TPasSyntaxTreeBuilder.ProceduralDirectiveOf; -var - Proc: TSyntaxNode; begin //anType is already used for set/enum/subrange/class/record/interface/object. //It could be reused for this data, but it's a directive, not a type as such. @@ -2234,8 +2233,6 @@ procedure TPasSyntaxTreeBuilder.RaiseStatement; end; procedure TPasSyntaxTreeBuilder.RecordFieldConstant; -var - Node: TSyntaxNode; begin //A field in a record constant should have exactly the same layout //as a field in a class. @@ -2889,7 +2886,6 @@ procedure TPasSyntaxTreeBuilder.UsedUnitName; NamesNode, UnitNode: TSyntaxNode; Position: TTokenPoint; FileName: string; - i: integer; begin Position := Lexer.PosXY; FileName := Lexer.FileName; diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index f895b32b..2afd6bfb 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -280,9 +280,9 @@ TmwBasePasLex = class(TObject) procedure CloneDefinesFrom(ALexer: TmwBasePasLex); procedure DoProcTable(AChar: Char); function IsIdentifiers(AChar: Char): Boolean; inline; - function HashValue(AChar: Char): Integer; + function HashValue(AChar: Char): Integer; inline; function EvaluateComparison(AValue1: Extended; const AOper: String; AValue2: Extended): Boolean; - function EvaluateConditionalExpression(const AParams: String): Boolean; + function EvaluateConditionalExpression(const AParams: String; StartResult: boolean = false): Boolean; procedure IncludeFile; function GetIncludeFileNameFromToken(const IncludeToken: string): string; function GetOrigin: string; @@ -1636,117 +1636,284 @@ procedure TmwBasePasLex.BraceOpenProc; function TmwBasePasLex.EvaluateComparison(AValue1: Extended; const AOper: String; AValue2: Extended): Boolean; begin - if AOper = '=' then - Result := AValue1 = AValue2 - else if AOper = '<>' then - Result := AValue1 <> AValue2 - else if AOper = '<' then - Result := AValue1 < AValue2 - else if AOper = '<=' then - Result := AValue1 <= AValue2 - else if AOper = '>' then - Result := AValue1 > AValue2 - else if AOper = '>=' then - Result := AValue1 >= AValue2 - else - Result := False; + case AOper[1] of + '=': Result := (AValue1 = AValue2); + '<': begin + if (AOper = '<') then Result := AValue1 < AValue2 + else if (AOper = '<>') then Result := AValue1 <> AValue2 + else Result:= AValue1 <= AValue2; + end; + '>': begin + if (AOper = '>') then Result := AValue1 > AValue2 + else Result:= AValue1 >= AValue2; + end; + else Result:= false; + end; end; -function TmwBasePasLex.EvaluateConditionalExpression(const AParams: String): Boolean; +function TmwBasePasLex.EvaluateConditionalExpression(const AParams: string; StartResult: boolean = false): Boolean; var - LParams: String; - LDefine: String; - LEvaluation: TmwPasLexExpressionEvaluation; - LIsComVer: Boolean; - LIsRtlVer: Boolean; - LOper: string; - LValue: Integer; - p: Integer; -begin - { TODO : Expand support for <=> evaluations (complicated to do). Expand support for NESTED expressions } - LEvaluation := leeNone; - LParams := TrimLeft(AParams); - LIsComVer := Pos('COMPILERVERSION', LParams) = 1; - LIsRtlVer := Pos('RTLVERSION', LParams) = 1; - if LIsComVer or LIsRtlVer then //simple parser which covers most frequent use cases - begin - Result := False; - if LIsComVer then - Delete(LParams, 1, Length('COMPILERVERSION')); - if LIsRtlVer then - Delete(LParams, 1, Length('RTLVERSION')); - while (LParams <> '') and (LParams[1] = ' ') do - Delete(LParams, 1, 1); - p := Pos(' ', LParams); - if p > 0 then - begin - LOper := Copy(LParams, 1, p-1); - Delete(LParams, 1, p); - while (LParams <> '') and (LParams[1] = ' ') do - Delete(LParams, 1, 1); - p := Pos(' ', LParams); - if p = 0 then - p := Length(LParams) + 1; - if TryStrToInt(Copy(LParams, 1, p-1), LValue) then - begin - Delete(LParams, 1, p); - while (LParams <> '') and (LParams[1] = ' ') do - Delete(LParams, 1, 1); - if LParams = '' then - if LIsComVer then - Result := EvaluateComparison(CompilerVersion, LOper, LValue) - else if LIsRtlVer then - Result := EvaluateComparison(RTLVersion, LOper, LValue); + LParams: string; + i: integer; + NextPart: string; + +function ExtractNextPart(StartPos: integer; BracketCount: integer = 0): string; +var + i: integer; + BracketFound: boolean; + TokenFound: boolean; + InternalBracketCount: integer; +begin + i:= 1; + BracketFound:= false; + TokenFound:= false; + InternalBracketCount:= 0;//BracketCount; + while i < Length(LParams) do begin + case LParams[i] of + '(': begin + Inc(InternalBracketCount); + BracketFound:= true; end; + ')': begin + Dec(InternalBracketCount); + end; + else TokenFound:= true; end; - end else - if (Pos('DEFINED(', LParams) = 1) or (Pos('NOT DEFINED(', LParams) = 1) then - begin - Result := True; // Optimistic - while (Pos('DEFINED(', LParams) = 1) or (Pos('NOT DEFINED(', LParams) = 1) do - begin - if Pos('DEFINED(', LParams) = 1 then - begin + if (InternalBracketCount = 0) and BracketFound and TokenFound then begin + break; + end; + Inc(i); + end; + Result:= MidStr(LParams, StartPos, i-((StartPos-1)*2)); +end; + +//Assumes the first char is part of a number +function ExtractNumber: string; +begin + i:= 1; + while i <= Length(LParams) do begin + if (LParams[i] in ['0'..'9','-','.']) then Inc(i) + else begin + Dec(i); + Break; + end; + end; {while} + Result:= LeftStr(LParams, i); +end; + +var + LDefine: string; + IsComVer, IsRTLVer: boolean; + LOper: string; + Value: Extended; + MyFormatSettings: TFormatSettings; + +begin + IsComVer:= false; + IsRTLVer:= false; + LParams:= Trim(Uppercase(AParams)); + Result:= StartResult; + while (Length(LParams) > 0) do begin + case LParams[1] of + '(': begin + while Pos('(', LParams) = 1 do begin + NextPart:= ExtractNextPart(2,1); + Result:= EvaluateConditionalExpression(NextPart, Result); + Delete(LParams, 1, Length(NextPart) + 2); + LParams:= TrimLeft(LParams); + end; {while} + end; {'('} + 'O':if Pos('OR',LParams) = 1 then begin + Delete(LParams,1,2); + LParams:= TrimLeft(LParams); + NextPart:= ExtractNextPart(1); + if not(Result) then Result:= Result or EvaluateConditionalExpression(NextPart, Result); + Delete(LParams, 1, Length(NextPart)); + LParams:= TrimLeft(LParams); + end; + 'A':if Pos('AND ',LParams) = 1 then begin + Delete(LParams,1,3); + LParams:= TrimLeft(LParams); + NextPart:= ExtractNextPart(1); + if(Result) then Result:= Result and EvaluateConditionalExpression(NextPart, Result); + Delete(LParams, 1, Length(NextPart)); + LParams:= TrimLeft(LParams); + end; + 'X':if Pos('XOR',LParams) = 1 then begin + Delete(LParams,1,3); + LParams:= TrimLeft(LParams); + NextPart:= ExtractNextPart(1); + Result:= Result xor EvaluateConditionalExpression(NextPart, Result); + Delete(LParams, 1, Length(NextPart)); + LParams:= TrimLeft(LParams); + end; + 'D': if Pos('DEFINED(',LParams) = 1 then begin LDefine := Copy(LParams, 9, Pos(')', LParams) - 9); - LParams := TrimLeft(Copy(LParams, 10 + Length(LDefine), Length(AParams) - (9 + Length(LDefine)))); - case LEvaluation of - leeNone: Result := IsDefined(LDefine); - leeAnd: Result := Result and IsDefined(LDefine); - leeOr: Result := Result or IsDefined(LDefine); - leeXor: Result:= Result xor IsDefined(LDefine); - end; - end - else if Pos('NOT DEFINED(', LParams) = 1 then - begin - LDefine := Copy(LParams, 13, Pos(')', LParams) - 13); - LParams := TrimLeft(Copy(LParams, 14 + Length(LDefine), Length(AParams) - (13 + Length(LDefine)))); - case LEvaluation of - leeNone: Result := (not IsDefined(LDefine)); - leeAnd: Result := Result and (not IsDefined(LDefine)); - leeOr: Result := Result or (not IsDefined(LDefine)); - leeXor: Result:= Result xor (not IsDefined(LDefine)); - end; + Result:= IsDefined(LDefine); + Delete(LParams, 1, Length(LDefine)+9); + LParams:= TrimLeft(LParams); end; - // Determine next Evaluation - if Pos('AND ', LParams) = 1 then - begin - LEvaluation := leeAnd; - LParams := TrimLeft(Copy(LParams, 4, Length(LParams) - 3)); - end - else if Pos('OR ', LParams) = 1 then - begin - LEvaluation := leeOr; - LParams := TrimLeft(Copy(LParams, 3, Length(LParams) - 2)); - end - else if Pos('XOR ', LParams) = 1 then - begin - LEvaluation := leeXor; - LParams := TrimLeft(Copy(LParams, 3, Length(LParams) - 2)); + 'N': if (Pos('NOT',LParams) = 1) then begin + Delete(LParams,1,3); + LParams:= TrimLeft(LParams); + NextPart:= ExtractNextPart(1); + Result:= not EvaluateConditionalExpression(NextPart, Result); + Delete(LParams, 1, Length(NextPart)); + LParams:= TrimLeft(LParams); end; - end; - end else - Result := False; -end; + 'C': if (Pos('COMPILERVERSION',LParams) = 1) then begin + IsComVer := true; + Delete(LParams, 1, Length('COMPILERVERSION')); + LParams:= TrimLeft(LParams); + + end; + 'R': if (Pos('RTLVERSION',LParams) = 1) then begin + IsRTLVer:= true; + Delete(LParams, 1, Length('RTLVERSION')); + LParams:= TrimLeft(LParams); + end; + '<','=','>': begin + if (Pos('>=',LParams) = 1) then LOper:= '>=' + else if (Pos('<=',LParams) = 1) then LOper:= '<=' + else if (Pos('<>',LParams) = 1) then LOper:= '<>' + else LOper:= LParams[1]; + Delete(LParams, 1, Length(LOper)); + LParams:= TrimLeft(LParams); + NextPart:= ExtractNumber; + MyFormatSettings:= FormatSettings; + MyFormatSettings.DecimalSeparator:= '.'; + if TryStrToFloat(NextPart, Value, MyFormatSettings) then begin + if IsComVer then + Result := EvaluateComparison(CompilerVersion, LOper, Value) + else if IsRtlVer then + Result := EvaluateComparison(RTLVersion, LOper, Value); + Delete(LParams, 1, Length(NextPart)); + LParams:= Trim(LParams); + end else Result:= false; + end; + else Exit(false); //Should not happen. + end; {case} + end; {while} +end; + + +//function TmwBasePasLex.EvaluateConditionalExpression(const AParams: string): Boolean; +//var +// LParams: String; +// LDefine: String; +// LEvaluation: TmwPasLexExpressionEvaluation; +// LIsComVer: Boolean; +// LIsRtlVer: Boolean; +// LOper: string; +// LValue: Integer; +// p: Integer; +// BracketCount,i: integer; +// BracketPart: string; +// PartialResult: boolean; +//begin +// { TODO : Expand support for <=> evaluations (complicated to do). Expand support for NESTED expressions } +// LEvaluation := leeNone; +// LParams := TrimLeft(AParams); +// LIsComVer := Pos('COMPILERVERSION', LParams) = 1; +// LIsRtlVer := Pos('RTLVERSION', LParams) = 1; +// if LIsComVer or LIsRtlVer then //simple parser which covers most frequent use cases +// begin +// Result := False; +// if LIsComVer then +// Delete(LParams, 1, Length('COMPILERVERSION')); +// if LIsRtlVer then +// Delete(LParams, 1, Length('RTLVERSION')); +// while (LParams <> '') and (LParams[1] = ' ') do +// Delete(LParams, 1, 1); +// p := Pos(' ', LParams); +// if p > 0 then +// begin +// LOper := Copy(LParams, 1, p-1); +// Delete(LParams, 1, p); +// while (LParams <> '') and (LParams[1] = ' ') do +// Delete(LParams, 1, 1); +// p := Pos(' ', LParams); +// if p = 0 then +// p := Length(LParams) + 1; +// if TryStrToInt(Copy(LParams, 1, p-1), LValue) then +// begin +// Delete(LParams, 1, p); +// while (LParams <> '') and (LParams[1] = ' ') do +// Delete(LParams, 1, 1); +// if LParams = '' then +// if LIsComVer then +// Result := EvaluateComparison(CompilerVersion, LOper, LValue) +// else if LIsRtlVer then +// Result := EvaluateComparison(RTLVersion, LOper, LValue); +// end; +// end; +// end else +// while Pos('(', LParams) = 1 do begin +// //Extract the Part between the brackets and feed this to the evaluator. +// BracketCount:= 1; +// i:= 2; +// while i <= Length(LParams) do begin +// case LParams[i] of +// '(': Inc(BracketCount); +// ')': Dec(BracketCount); +// end; {case} +// if (BracketCount = 0) then break; +// Inc(i); +// end; {while} +// BracketPart:= MidStr(LParams,2,i-2); +// PartialResult:= EvaluateConditionalExpression(BracketPart); +// Result:= Result or PartialResult; +// Delete(LParams, 1, Length(BracketPart)+2); +// LParams:= TrimLeft(LParams); +// end; +// +// if (Pos('DEFINED(', LParams) = 1) or (Pos('NOT DEFINED(', LParams) = 1) then +// begin +// Result := True; // Optimistic +// while (Pos('DEFINED(', LParams) = 1) or (Pos('NOT DEFINED(', LParams) = 1) do +// begin +// if Pos('DEFINED(', LParams) = 1 then +// begin +// LDefine := Copy(LParams, 9, Pos(')', LParams) - 9); +// LParams := TrimLeft(Copy(LParams, 10 + Length(LDefine), Length(AParams) - (9 + Length(LDefine)))); +// case LEvaluation of +// leeNone: Result := IsDefined(LDefine); +// leeAnd: Result := Result and IsDefined(LDefine); +// leeOr: Result := Result or IsDefined(LDefine); +// leeXor: Result:= Result xor IsDefined(LDefine); +// end; +// end +// else if Pos('NOT DEFINED(', LParams) = 1 then +// begin +// LDefine := Copy(LParams, 13, Pos(')', LParams) - 13); +// LParams := TrimLeft(Copy(LParams, 14 + Length(LDefine), Length(AParams) - (13 + Length(LDefine)))); +// case LEvaluation of +// leeNone: Result := (not IsDefined(LDefine)); +// leeAnd: Result := Result and (not IsDefined(LDefine)); +// leeOr: Result := Result or (not IsDefined(LDefine)); +// leeXor: Result:= Result xor (not IsDefined(LDefine)); +// end; +// end; +// // Determine next Evaluation +// if Pos('AND ', LParams) = 1 then +// begin +// LEvaluation := leeAnd; +// LParams := TrimLeft(Copy(LParams, 4, Length(LParams) - 3)); +// end +// else if Pos('OR ', LParams) = 1 then +// begin +// LEvaluation := leeOr; +// LParams := TrimLeft(Copy(LParams, 3, Length(LParams) - 2)); +// end +// else if Pos('XOR ', LParams) = 1 then +// begin +// LEvaluation := leeXor; +// LParams := TrimLeft(Copy(LParams, 3, Length(LParams) - 2)); +// end; +// end; +// end else +// Result := False; +//end; procedure TmwBasePasLex.ColonProc; begin @@ -2394,6 +2561,7 @@ function TmwBasePasLex.GetDirectiveKind: TptTokenKind; FDirectiveParamOrigin := FBuffer.Buf + FTokenPos; TempPos := FTokenPos; FTokenPos := FBuffer.Run; + FExId:= ptCompDirect; //Always register the fact that we are in a directive. case KeyHash of 9: if KeyComp('I') and (not CharInSet(FBuffer.Buf[FBuffer.Run], ['+', '-'])) then diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 1b956fe0..71f6eac1 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -917,9 +917,10 @@ procedure TmwSimplePasPar.HandlePtIfOptDirect(Sender: TmwBasePasLex); procedure TmwSimplePasPar.HandlePtResourceDirect(Sender: TmwBasePasLex); begin + CompilerDirective; if Assigned(FOnMessage) then FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); - Sender.Next; + //Sender.Next; end; procedure TmwSimplePasPar.HandlePtUndefDirect(Sender: TmwBasePasLex); From e89593a7f8268ea51f543b3f9731dc5ed32fd03a Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 17 Oct 2017 11:18:41 +0200 Subject: [PATCH 29/42] #252 do not register compiler directives, unless the compiler can see them --- Source/SimpleParser/SimpleParser.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 71f6eac1..4978bbf9 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -841,7 +841,7 @@ procedure TmwSimplePasPar.ExpectedFatal(Sym: TptTokenKind); procedure TmwSimplePasPar.HandlePtCompDirect(Sender: TmwBasePasLex); begin - CompilerDirective; + if (not Lexer.IsJunk) then CompilerDirective; //if Assigned(FOnMessage) then // FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); //Sender.Next; From 23637da7a492ee96114355725a0b83c42dc82d5b Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 17 Oct 2017 14:52:42 +0200 Subject: [PATCH 30/42] #253 support `absolute` and #252 part2 --- Source/DelphiAST.Consts.pas | 2 +- Source/DelphiAST.pas | 49 +++++++++++++++++++++++++++++++++---- 2 files changed, 45 insertions(+), 6 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index b2a27826..ec12aab6 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -111,7 +111,7 @@ interface ntPackage, ntParameter, ntParameters, - ntPath, + {ntPath,} ntPlatform, ntPositionalArgument, ntProgram, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 75b00cbb..2acbe2ef 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -265,6 +265,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure UnitId; override; procedure UsesClause; override; procedure UsedUnitName; override; + procedure VarAbsolute; override; procedure VarDeclaration; override; procedure VarName; override; procedure VarParameter; override; @@ -305,7 +306,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) implementation uses - TypInfo; + TypInfo, StrUtils; {$IFDEF FPC} type @@ -343,7 +344,7 @@ TStringStreamHelper = class helper for TStringStream atOut, atPointer, atName, atString, atSubRange, atVar, atType{ExplicitType}, atObject, atSealed, atAbstract, atBegin, atOf_Object{procedure of object}, atVarargs, atExternal{Varargs and external are mutually exclusive}, - atStatic); + atStatic, atAbsolute); var AttributeValues: array[TAttributeValue] of string; @@ -1053,9 +1054,29 @@ procedure TPasSyntaxTreeBuilder.ConstructorName; end; procedure TPasSyntaxTreeBuilder.CompilerDirective; -begin - FStack.AddValuedChild(ntCompilerDirective, Lexer.Token); - +var + Directive: string; + Node: TSyntaxNode; + Part2: integer; +begin + Directive:= Uppercase(Lexer.Token); + Node:= FStack.AddValuedChild(ntCompilerDirective, Directive); + //Parse the directive + if (Directive.StartsWith('(*$')) then begin + Delete(Directive, 1, 3); + StringReplace(Directive,'*)','}',[]); + end else begin + Delete(Directive, 1, 2); + end; + Part2:= 1; + while not CharInSet(Directive[Part2],[' ', '+', '-', '}']) do begin + Inc(Part2); + end; + Node.Attribute[anType]:= LeftStr(Directive, Part2-1); + Delete(Directive, 1, Part2-1); + Delete(Directive, Length(Directive), 1); + Directive:= Trim(Directive); + Node.Attribute[anKind]:= Directive; inherited; end; @@ -2920,6 +2941,24 @@ procedure TPasSyntaxTreeBuilder.UsesClause; end; end; +procedure TPasSyntaxTreeBuilder.VarAbsolute; +var + AbsoluteNode: TSyntaxNode; + ValueNode: TSyntaxNode; +begin + AbsoluteNode:= TSyntaxNode.Create(ntUnknown); + FStack.Push(AbsoluteNode); + try + inherited; + finally + FStack.Pop; + ValueNode:= AbsoluteNode.ExtractChild(AbsoluteNode.ChildNode[0]); + ValueNode.Attribute[anKind]:= AttributeValues[atAbsolute]; + AbsoluteNode.Free; + FStack.Peek.AddChild(ValueNode); + end; +end; + procedure TPasSyntaxTreeBuilder.VarDeclaration; begin FStack.Push(ntVariables); From 0f89a6248293ab833cd25af69229c7294159028c Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 17 Oct 2017 15:58:37 +0200 Subject: [PATCH 31/42] #252 always put compiler directive underneigh the root --- Source/DelphiAST.pas | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 2acbe2ef..40e48af6 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -78,6 +78,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure SetCurrentCompoundNodesEndPosition; inline; procedure DoOnComment(Sender: TObject; const Text: string); procedure DoHandleString(var s: string); inline; + function GetMainSection(Node: TSyntaxNode): TSyntaxNode; protected FStack: TNodeStack; FComments: TObjectList; @@ -1053,14 +1054,36 @@ procedure TPasSyntaxTreeBuilder.ConstructorName; inherited; end; +function TPasSyntaxTreeBuilder.GetMainSection(Node: TSyntaxNode): TSyntaxNode; +var + Temp: TSyntaxNode; +begin + If Node.Typ = ntUnknown then begin + //Get the next item on the stack. + Temp:= FStack.Pop; + Node:= FStack.Peek; + FStack.Push(Temp); + end; + if not(Assigned(Node.ParentNode)) then Exit(Node); //return the root node. + while Assigned(Node.ParentNode.ParentNode) do Node:= Node.ParentNode; + if (Node.ParentNode.Typ in [ntProgram, ntLibrary, ntPackage]) then Exit(Node.ParentNode); + Result:= Node; +end; + procedure TPasSyntaxTreeBuilder.CompilerDirective; var Directive: string; - Node: TSyntaxNode; + Node: TValuedSyntaxNode; Part2: integer; + Root: TSyntaxNode; begin Directive:= Uppercase(Lexer.Token); - Node:= FStack.AddValuedChild(ntCompilerDirective, Directive); + //Always place the compiler directive directly under the `ntInterface` or `ntImplementation` node + //or in the main section in a library, program or package. + Root:= GetMainSection(FStack.Peek); + Node:= TValuedSyntaxNode.Create(ntCompilerDirective); + Node.Value:= Directive; + Root.AddChild(Node); //Parse the directive if (Directive.StartsWith('(*$')) then begin Delete(Directive, 1, 3); From 5fcd93f86ba74a91d984f5c8381b689884983bc4 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 17 Oct 2017 16:17:51 +0200 Subject: [PATCH 32/42] #254 Error in parsing anonymous methods --- Source/SimpleParser/SimpleParser.pas | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 4978bbf9..b1c728db 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -917,10 +917,11 @@ procedure TmwSimplePasPar.HandlePtIfOptDirect(Sender: TmwBasePasLex); procedure TmwSimplePasPar.HandlePtResourceDirect(Sender: TmwBasePasLex); begin - CompilerDirective; - if Assigned(FOnMessage) then - FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); - //Sender.Next; + //{$R *.dfm} + if (not Lexer.IsJunk) then CompilerDirective; +// if Assigned(FOnMessage) then +// FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); +// Sender.Next; end; procedure TmwSimplePasPar.HandlePtUndefDirect(Sender: TmwBasePasLex); @@ -5049,7 +5050,7 @@ procedure TmwSimplePasPar.Resident; procedure TmwSimplePasPar.CompilerDirective; begin - Expected(ptCompDirect); + ExpectedEx(ptCompDirect); end; procedure TmwSimplePasPar.CompoundStatement; @@ -5425,18 +5426,16 @@ procedure TmwSimplePasPar.AnonymousMethod; begin NextToken; if TokenID = ptRoundOpen then begin - RoundOpen; - ExpressionList; - RoundClose; + FormalParameterList; end; + Expected(ptColon); + ReturnType; end; ptProcedure: begin NextToken; - if TokenId = ptRoundOpen then begin - RoundOpen; - ExpressionList; - RoundClose; + if TokenID = ptRoundOpen then begin + FormalParameterList; end; end; end; From bbbe2e2a7a7e7e64382e73529cb108630b8daeb0 Mon Sep 17 00:00:00 2001 From: jbontes Date: Tue, 17 Oct 2017 17:47:40 +0200 Subject: [PATCH 33/42] #255 Treat `array of const` correctly array of const is a special construct. `const` here is not an identifier. --- Source/DelphiAST.pas | 12 +++++++ Source/SimpleParser/SimpleParser.pas | 47 +++++++++++++++++++--------- 2 files changed, 44 insertions(+), 15 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 40e48af6..b2721e26 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -96,6 +96,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ArrayBounds; override; procedure ArrayConstant; override; procedure ArrayDimension; override; + procedure ArrayOfConst; override; procedure AsmStatement; override; procedure AsOp; override; procedure AssignOp; override; @@ -584,6 +585,17 @@ procedure TPasSyntaxTreeBuilder.ArrayDimension; end; end; +procedure TPasSyntaxTreeBuilder.ArrayOfConst; +begin + //do not fill the name attribute. const is a keyword, not a type. + FStack.Push(ntType).Attribute[anKind]:= AttributeValues[atConst]; + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.AsmStatement; begin FStack.PushCompoundSyntaxNode(ntStatements).Attribute[anType]:= AttributeValues[atAsm]; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index b1c728db..6ac64947 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -249,6 +249,8 @@ TmwSimplePasPar = class(TObject) procedure ArrayConstant; virtual; procedure ArrayBounds; virtual; procedure ArrayDimension; virtual; + procedure ArrayOfConst; virtual; + procedure ArraySubType; virtual; procedure ArrayType; virtual; procedure AsmStatement; virtual; procedure AssignOp; virtual; @@ -795,7 +797,7 @@ procedure TmwSimplePasPar.ExpectedEx(const Syms: TptTokenKinds); for Sym in Syms do begin Symbols:= Symbols + Optional + TokenName(Sym); Optional:= ' or '; - end; + end; if (Lexer.TokenID = ptNull) then raise ESyntaxError.CreatePos(Format(rsExpected, [Symbols, rsEndOfFile]), FLexer.PosXY) else if Assigned(FOnMessage) then begin @@ -1015,7 +1017,7 @@ procedure TmwSimplePasPar.ThenStatement; procedure TmwSimplePasPar.Semicolon; begin case Lexer.TokenID of - ptElse, ptEnd, ptExcept, ptfinally, ptFinalization, ptRoundClose, ptUntil: ; + ptElse, ptEnd, ptExcept, ptFinally, ptFinalization, ptRoundClose, ptUntil: ; else Expected(ptSemiColon); end; @@ -1438,12 +1440,12 @@ procedure TmwSimplePasPar.AccessSpecifier; procedure TmwSimplePasPar.ReadAccessIdentifier; begin - variable; + Variable; end; procedure TmwSimplePasPar.WriteAccessIdentifier; begin - variable; + Variable; end; procedure TmwSimplePasPar.StorageSpecifier; @@ -3304,7 +3306,7 @@ procedure TmwSimplePasPar.ArrayType; Expected(ptArray); ArrayBounds; Expected(ptOf); - TypeKind; + ArraySubType; end; procedure TmwSimplePasPar.EnumeratedType; @@ -4261,6 +4263,19 @@ procedure TmwSimplePasPar.ArrayDimension; OrdinalType; end; +procedure TmwSimplePasPar.ArrayOfConst; +begin + Expected(ptConst); +end; + +procedure TmwSimplePasPar.ArraySubType; +begin + case TokenID of + ptConst: ArrayOfConst; + else TypeKind; + end; +end; + procedure TmwSimplePasPar.ClassForward; begin Expected(ptClass); @@ -4867,16 +4882,16 @@ procedure TmwSimplePasPar.TypeSimple; begin NextToken; Expected(ptOf); - case TokenID of - ptConst: (*new in ObjectPascal80*) - begin - NextToken; - end; - else - begin - TypeID; - end; - end; +// case TokenID of +// ptConst: (*new in ObjectPascal80*) +// begin +// NextToken; +// end; +// else + // begin + TypeID; +// end; +// end; end; else Expected(ptIdentifier); @@ -5465,10 +5480,12 @@ procedure TmwSimplePasPar.AnonymousMethodType; end; end; end; + procedure TmwSimplePasPar.AnonymousMethodTypeProcedure; begin Expected(ptProcedure); end; + procedure TmwSimplePasPar.AnonymousMethodTypeFunction; begin Expected(ptFunction); From 793b098006a81df9237cfe71f976d5c1c37617cc Mon Sep 17 00:00:00 2001 From: jbontes Date: Wed, 18 Oct 2017 09:59:40 +0200 Subject: [PATCH 34/42] #35 add processing for isdeclared and fix endless loop --- Source/SimpleParser/SimpleParser.Lexer.pas | 34 +++++++++++++++------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index 2afd6bfb..0ca8bb88 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -308,6 +308,7 @@ TmwBasePasLex = class(TObject) procedure AddDefine(const ADefine: string); procedure RemoveDefine(const ADefine: string); function IsDefined(const ADefine: string): Boolean; + function IsDeclared(const ADefine: string): Boolean; procedure ClearDefines; procedure InitDefinesDefinedByCompiler; @@ -393,7 +394,7 @@ procedure MakeIdentTable; begin for I := #0 to #127 do begin - Identifiers[I]:= I in ['_', '0'..'9', 'a'..'z', 'A'..'Z']; + Identifiers[I]:= CharInSet(I,['_', '0'..'9', 'a'..'z', 'A'..'Z']); J := UpCase(I); case J of 'A'..'Z', '_': mHashTable[I] := Ord(J) - 64; @@ -1203,6 +1204,7 @@ function TmwBasePasLex.Func158: TptTokenKind; FExID:= ptUnicodeString; end; end; + function TmwBasePasLex.Func166: TptTokenKind; begin Result := ptIdentifier; @@ -1692,7 +1694,7 @@ function ExtractNumber: string; begin i:= 1; while i <= Length(LParams) do begin - if (LParams[i] in ['0'..'9','-','.']) then Inc(i) + if CharInSet(LParams[i], ['0'..'9','-','.']) then Inc(i) else begin Dec(i); Break; @@ -1730,7 +1732,7 @@ function ExtractNumber: string; if not(Result) then Result:= Result or EvaluateConditionalExpression(NextPart, Result); Delete(LParams, 1, Length(NextPart)); LParams:= TrimLeft(LParams); - end; + end else exit(false); 'A':if Pos('AND ',LParams) = 1 then begin Delete(LParams,1,3); LParams:= TrimLeft(LParams); @@ -1738,7 +1740,7 @@ function ExtractNumber: string; if(Result) then Result:= Result and EvaluateConditionalExpression(NextPart, Result); Delete(LParams, 1, Length(NextPart)); LParams:= TrimLeft(LParams); - end; + end else exit(false); 'X':if Pos('XOR',LParams) = 1 then begin Delete(LParams,1,3); LParams:= TrimLeft(LParams); @@ -1746,13 +1748,18 @@ function ExtractNumber: string; Result:= Result xor EvaluateConditionalExpression(NextPart, Result); Delete(LParams, 1, Length(NextPart)); LParams:= TrimLeft(LParams); - end; + end else exit(false); 'D': if Pos('DEFINED(',LParams) = 1 then begin LDefine := Copy(LParams, 9, Pos(')', LParams) - 9); Result:= IsDefined(LDefine); Delete(LParams, 1, Length(LDefine)+9); LParams:= TrimLeft(LParams); - end; + end else if Pos('DECLARED(',LParams) = 1 then begin + LDefine := Copy(LParams, 10, Pos(')', LParams) - 10); + Result:= IsDeclared(LDefine); + Delete(LParams, 1, Length(LDefine)+9); + LParams:= TrimLeft(LParams); + end else exit(false); 'N': if (Pos('NOT',LParams) = 1) then begin Delete(LParams,1,3); LParams:= TrimLeft(LParams); @@ -1760,18 +1767,17 @@ function ExtractNumber: string; Result:= not EvaluateConditionalExpression(NextPart, Result); Delete(LParams, 1, Length(NextPart)); LParams:= TrimLeft(LParams); - end; + end else exit(false); 'C': if (Pos('COMPILERVERSION',LParams) = 1) then begin IsComVer := true; Delete(LParams, 1, Length('COMPILERVERSION')); LParams:= TrimLeft(LParams); - - end; + end else exit(false); 'R': if (Pos('RTLVERSION',LParams) = 1) then begin IsRTLVer:= true; Delete(LParams, 1, Length('RTLVERSION')); LParams:= TrimLeft(LParams); - end; + end else exit(false); '<','=','>': begin if (Pos('>=',LParams) = 1) then LOper:= '>=' else if (Pos('<=',LParams) = 1) then LOper:= '<=' @@ -2034,6 +2040,14 @@ function TmwBasePasLex.IsDefined(const ADefine: string): Boolean; Result := False; end; +function TmwBasePasLex.IsDeclared(const ADefine: string): Boolean; +var + i: Integer; +begin + Result:= true; + {TODO -oJB -cTmwBasePasLex.IsDeclared : Implement} +end; + function TmwBasePasLex.IsIdentifiers(AChar: Char): Boolean; begin {$IFDEF SUPPORTS_INTRINSIC_HELPERS} From 1a15887af0c1499d52a62e2962f656a3d913f6ad Mon Sep 17 00:00:00 2001 From: jbontes Date: Wed, 18 Oct 2017 11:07:04 +0200 Subject: [PATCH 35/42] #217 Record const [ref] atrtribute --- Source/DelphiAST.pas | 34 ++++++++++++++++------ Source/SimpleParser/SimpleParser.Lexer.pas | 2 -- 2 files changed, 25 insertions(+), 11 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index b2721e26..27ac54ee 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -29,7 +29,7 @@ TPasLexer = class function GetPosXY: TTokenPoint; inline; function GetFileName: string; inline; public - constructor Create(const ALexer: TmwPasLex; AOnHandleString: TStringEvent); + constructor Create(const Lexer: TmwPasLex; OnHandleString: TStringEvent); property FileName: string read GetFileName; property PosXY: TTokenPoint read GetPosXY; @@ -372,11 +372,11 @@ procedure AssignLexerPositionToNode(const Lexer: TPasLexer; const Node: TSyntaxN { TPasLexer } -constructor TPasLexer.Create(const ALexer: TmwPasLex; AOnHandleString: TStringEvent); +constructor TPasLexer.Create(const Lexer: TmwPasLex; OnHandleString: TStringEvent); begin inherited Create; - FLexer := ALexer; - FOnHandleString := AOnHandleString; + FLexer := Lexer; + FOnHandleString := OnHandleString; end; function TPasLexer.GetFileName: string; @@ -736,6 +736,7 @@ procedure TPasSyntaxTreeBuilder.BuildParametersList( ParametersListMethod: TTreeBuilderMethod); var Params, Temp: TSyntaxNode; + Attributes: TSyntaxNode; ParamList, Param, TypeInfo, ParamExpr: TSyntaxNode; ParamKind: string; begin @@ -752,9 +753,10 @@ procedure TPasSyntaxTreeBuilder.BuildParametersList( for ParamList in Params.ChildNodes do begin - TypeInfo := ParamList.FindNode(ntType); + TypeInfo := ParamList.ExtractChild(ntType); ParamKind := ParamList.Attribute[anKind]; - ParamExpr := ParamList.FindNode(ntExpression); + ParamExpr := ParamList.ExtractChild(ntExpression); + Attributes:= ParamList.ExtractChild(ntAttributes); for Param in ParamList.ChildNodes do begin @@ -768,12 +770,15 @@ procedure TPasSyntaxTreeBuilder.BuildParametersList( Temp.Col := Param.Col; Temp.Line := Param.Line; + if Assigned(Attributes) then + FStack.AddChild(Attributes); + FStack.AddChild(Param.Clone); if Assigned(TypeInfo) then - FStack.AddChild(TypeInfo.Clone); + FStack.AddChild(TypeInfo); if Assigned(ParamExpr) then - FStack.AddChild(ParamExpr.Clone); + FStack.AddChild(ParamExpr); FStack.Pop; end; @@ -891,6 +896,7 @@ procedure TPasSyntaxTreeBuilder.ClassField; Fields.Free; end; end; + procedure TPasSyntaxTreeBuilder.ObjectField; var Fields, Temp: TSyntaxNode; @@ -906,16 +912,19 @@ procedure TPasSyntaxTreeBuilder.ObjectField; finally FStack.Pop; end; + TypeInfo := Fields.FindNode(ntType); TypeArgs := Fields.FindNode(ntTypeArgs); for Field in Fields.ChildNodes do begin if Field.Typ <> ntName then Continue; + Temp := FStack.Push(ntField); if (IsClassVarSection) then Temp.Attribute[anClass]:= AttributeValues[atTrue]; try Temp.AssignPositionFrom(Field); + FStack.AddChild(Field.Clone); TypeInfo := TypeInfo.Clone; if Assigned(TypeArgs) then @@ -1094,6 +1103,7 @@ procedure TPasSyntaxTreeBuilder.CompilerDirective; //or in the main section in a library, program or package. Root:= GetMainSection(FStack.Peek); Node:= TValuedSyntaxNode.Create(ntCompilerDirective); + AssignLexerPositionToNode(Lexer, Node); Node.Value:= Directive; Root.AddChild(Node); //Parse the directive @@ -1220,6 +1230,7 @@ procedure TPasSyntaxTreeBuilder.RecordConstant; FStack.Pop; end; end; + procedure TPasSyntaxTreeBuilder.RecordConstraint; begin FStack.Push(ntRecordConstraint); @@ -1342,6 +1353,7 @@ procedure TPasSyntaxTreeBuilder.DirectiveBinding; FStack.Peek.Attribute[anOverload]:= AttributeValues[atTrue] else if SameText(Token, 'abstract') or SameText(Token, 'final') then FStack.Peek.Attribute[anAbstract]:= Token; + inherited; end; @@ -1652,16 +1664,19 @@ procedure TPasSyntaxTreeBuilder.FieldList; finally FStack.Pop; end; + TypeInfo := Fields.FindNode(ntType); TypeArgs := Fields.FindNode(ntTypeArgs); for Field in Fields.ChildNodes do begin if Field.Typ <> ntName then Continue; + Temp := FStack.Push(ntField); if (IsClassVarSection) then Temp.Attribute[anClass]:= AttributeValues[atTrue]; try Temp.AssignPositionFrom(Field); + FStack.AddChild(Field.Clone); TypeInfo := TypeInfo.Clone; if Assigned(TypeArgs) then @@ -2251,7 +2266,7 @@ procedure TPasSyntaxTreeBuilder.ProcedureHeading; procedure TPasSyntaxTreeBuilder.ProcedureProcedureName; begin - //FStack.Peek.SetAttribute(anName, Lexer.Token); + //FStack.Peek.Attribute[anName, Lexer.Token); inherited; end; @@ -2495,6 +2510,7 @@ function TPasSyntaxTreeBuilder.NodeListToString(NamesNode: TSyntaxNode): string; Result := ''; for NamePartNode in NamesNode.ChildNodes do begin + //do not add empty parts (in case non-name and name node are mixed. if (Result <> '') then Result := Result + '.'; Result:= Result + NamePartNode.Attribute[anName]; diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index 0ca8bb88..b67df3a4 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -2041,8 +2041,6 @@ function TmwBasePasLex.IsDefined(const ADefine: string): Boolean; end; function TmwBasePasLex.IsDeclared(const ADefine: string): Boolean; -var - i: Integer; begin Result:= true; {TODO -oJB -cTmwBasePasLex.IsDeclared : Implement} From a8ad741743fed48666d06ad814c309805f763e4a Mon Sep 17 00:00:00 2001 From: jbontes Date: Wed, 18 Oct 2017 14:35:29 +0200 Subject: [PATCH 36/42] #256 Record `@@` casting (for procedural variables) Added `@@` as a distinct operator. --- Source/DelphiAST.Classes.pas | 3 ++- Source/DelphiAST.Consts.pas | 1 + Source/DelphiAST.pas | 11 +++++++++++ Source/SimpleParser/SimpleParser.pas | 12 +++++++++--- 4 files changed, 23 insertions(+), 4 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index e4284a09..3d3f11db 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -136,8 +136,9 @@ TOperators = class end; const - OperatorsInfo: array [0..27] of TOperatorInfo = + OperatorsInfo: array [0..28] of TOperatorInfo = ((Typ: ntAddr; Priority: 1; Kind: okUnary; AssocType: atRight), + (Typ: ntDoubleAddr; Priority: 1; Kind: okUnary; AssocType: atRight), (Typ: ntDeref; Priority: 1; Kind: okUnary; AssocType: atLeft), (Typ: ntGeneric; Priority: 1; Kind: okBinary; AssocType: atRight), (Typ: ntIndexed; Priority: 1; Kind: okUnary; AssocType: atLeft), diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index ec12aab6..793729e4 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -5,6 +5,7 @@ interface type TSyntaxNodeType = ( ntAddr, + ntDoubleAddr, ntDeref, ntGeneric, ntIndexed, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 27ac54ee..7b895c3e 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -145,6 +145,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure DirectiveSealed; override; procedure DirectiveVarargs; override; procedure DispInterfaceForward; override; + procedure DoubleAddressOp; override; procedure DotOp; override; procedure ElseStatement; override; procedure EmptyStatement; override; @@ -1452,6 +1453,16 @@ procedure TPasSyntaxTreeBuilder.DotOp; inherited; end; +procedure TPasSyntaxTreeBuilder.DoubleAddressOp; +begin + FStack.Push(ntDoubleAddr); + try + inherited; + finally + FStack.Pop; + end; +end; + procedure TPasSyntaxTreeBuilder.ElseStatement; begin FStack.Push(ntElse); diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 6ac64947..652e83fd 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -274,7 +274,7 @@ TmwSimplePasPar = class(TObject) procedure ClassMethodResolution; virtual; procedure ClassProcedureHeading; virtual; procedure ClassClass; virtual; - procedure ClassConstraint; virtual; + procedure ClassConstraint; virtual; procedure ClassMethod; virtual; procedure ClassProperty; virtual; procedure ClassReferenceType; virtual; @@ -292,7 +292,7 @@ TmwSimplePasPar = class(TObject) procedure ConstantValue; virtual; procedure ConstantValueTyped; virtual; procedure ConstParameter; virtual; - procedure ConstructorConstraint; virtual; + procedure ConstructorConstraint; virtual; procedure ConstructorHeading; virtual; procedure ConstructorName; virtual; procedure ConstSection; virtual; @@ -321,6 +321,7 @@ TmwSimplePasPar = class(TObject) procedure DirectiveStatic; virtual; procedure DispInterfaceForward; virtual; procedure DispIDSpecifier; virtual; + procedure DoubleAddressOp; virtual; procedure DotOp; virtual; procedure ElseStatement; virtual; procedure EmptyStatement; virtual; @@ -3469,7 +3470,7 @@ procedure TmwSimplePasPar.VariableReference; end; ptDoubleAddressOp: begin - NextToken; + DoubleAddressOp; VariableReference; end; ptInherited: @@ -4291,6 +4292,11 @@ procedure TmwSimplePasPar.DotOp; Expected(ptPoint); end; +procedure TmwSimplePasPar.DoubleAddressOp; +begin + Expected(ptDoubleAddressOp); +end; + procedure TmwSimplePasPar.InterfaceForward; begin Expected(ptInterface); From 0679a5f465576cfe63d372c619f3d1b71413a034 Mon Sep 17 00:00:00 2001 From: jbontes Date: Wed, 18 Oct 2017 15:28:20 +0200 Subject: [PATCH 37/42] #257 inline asm statements are not recorded --- Source/DelphiAST.Consts.pas | 2 + Source/DelphiAST.pas | 34 ++++++++++++++ Source/SimpleParser/SimpleParser.Lexer.pas | 17 +++++++ Source/SimpleParser/SimpleParser.pas | 52 ++++++++++++++++------ 4 files changed, 92 insertions(+), 13 deletions(-) diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index 793729e4..fbc86a13 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -21,6 +21,8 @@ interface ntShl, ntShr, ntAs, + ntAsmFragment, + ntAsmStatement, ntAdd, ntSub, ntOr, diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 7b895c3e..2d8a5334 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -97,7 +97,9 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ArrayConstant; override; procedure ArrayDimension; override; procedure ArrayOfConst; override; + procedure AsmFragment; override; procedure AsmStatement; override; + procedure AsmStatements; override; procedure AsOp; override; procedure AssignOp; override; procedure AtExpression; override; @@ -597,7 +599,39 @@ procedure TPasSyntaxTreeBuilder.ArrayOfConst; end; end; +procedure TPasSyntaxTreeBuilder.AsmFragment; +begin + FStack.AddValuedChild(ntAsmFragment, Lexer.Token); + inherited; + +end; + procedure TPasSyntaxTreeBuilder.AsmStatement; +var + Node, Child: TSyntaxNode; + ValuedNode: TValuedSyntaxNode absolute Node; + ValuedChild: TValuedSyntaxNode absolute Child; + Optional: string; + Previous: char; +begin + Node:= FStack.PushValuedNode(ntAsmStatement,''); + try + inherited; + Optional:= ''; + Previous:= ' '; + for Child in Node.ChildNodes do begin + //Store the whole statement as well as the parts. + if (ValuedChild.Value[1] in [',', '+', '*', ']', ')', ' ','-']) or (Previous in ['(','[',',','+','*','-']) then Optional:= ''; + Previous:= ValuedChild.Value[1]; + ValuedNode.Value:= ValuedNode.Value + Optional + ValuedChild.Value; + Optional:= ' '; + end; + finally + FStack.Pop; + end; +end; + +procedure TPasSyntaxTreeBuilder.AsmStatements; begin FStack.PushCompoundSyntaxNode(ntStatements).Attribute[anType]:= AttributeValues[atAsm]; try diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index b67df3a4..06e5652a 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -292,6 +292,7 @@ TmwBasePasLex = class(TObject) procedure DisposeBuffer(Buf: PBufferRec); function GetFileName: string; procedure UpdateScopedEnums; + function GetIsJunkAssembly: Boolean; protected procedure SetOrigin(const NewValue: string); virtual; public @@ -300,6 +301,7 @@ TmwBasePasLex = class(TObject) function CharAhead: Char; procedure Next; procedure NextNoJunk; + procedure NextNoJunkAssembly; procedure NextNoSpace; procedure Init; procedure InitFrom(ALexer: TmwBasePasLex); @@ -316,6 +318,7 @@ TmwBasePasLex = class(TObject) property CompilerDirective: string read GetCompilerDirective; property DirectiveParam: string read GetDirectiveParam; property IsJunk: Boolean read GetIsJunk; + property IsJunkAssembly: Boolean read GetIsJunkAssembly; property IsSpace: Boolean read GetIsSpace; property Origin: string read GetOrigin write SetOrigin; property PosXY: TTokenPoint read GetPosXY; @@ -2489,6 +2492,13 @@ function TmwBasePasLex.GetIsJunk: Boolean; Result := IsTokenIDJunk(FTokenID) or (FUseDefines and (FDefineStack > 0) and (TokenID <> ptNull)); end; +function TmwBasePasLex.GetIsJunkAssembly: Boolean; +begin + Result := not(FTokenID in [ptCRLF]) and ( + IsTokenIDJunk(FTokenID) or (FUseDefines and (FDefineStack > 0) and (TokenID <> ptNull)) + ); +end; + function TmwBasePasLex.GetIsSpace: Boolean; begin Result := FTokenID in [ptCRLF, ptSpace]; @@ -2511,6 +2521,13 @@ procedure TmwBasePasLex.NextNoJunk; until not IsJunk; end; +procedure TmwBasePasLex.NextNoJunkAssembly; +begin + repeat + Next + until not IsJunkAssembly; +end; + procedure TmwBasePasLex.NextNoSpace; begin repeat diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 652e83fd..0a835e0b 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -230,6 +230,7 @@ TmwSimplePasPar = class(TObject) procedure HandlePtIfEndDirect(Sender: TmwBasePasLex); virtual; procedure HandlePtElseIfDirect(Sender: TmwBasePasLex); virtual; procedure NextToken; virtual; + procedure NextTokenAssembly; virtual; procedure SkipJunk; virtual; procedure Semicolon; virtual; function GetExID: TptTokenKind; virtual; @@ -252,7 +253,9 @@ TmwSimplePasPar = class(TObject) procedure ArrayOfConst; virtual; procedure ArraySubType; virtual; procedure ArrayType; virtual; + procedure AsmFragment; virtual; procedure AsmStatement; virtual; + procedure AsmStatements; virtual; procedure AssignOp; virtual; procedure AtExpression; virtual; procedure Block; virtual; @@ -937,6 +940,11 @@ procedure TmwSimplePasPar.NextToken; FLexer.NextNoJunk; end; +procedure TmwSimplePasPar.NextTokenAssembly; +begin + FLexer.NextNoJunkAssembly; +end; + procedure TmwSimplePasPar.NilToken; begin Expected(ptNil); @@ -1301,7 +1309,7 @@ procedure TmwSimplePasPar.Block; case TokenID of ptAsm: begin - AsmStatement; + AsmStatements; end; else begin @@ -2139,7 +2147,7 @@ procedure TmwSimplePasPar.FunctionProcedureBlock; case TokenID of ptAsm: begin - AsmStatement; + AsmStatements; end; else begin @@ -2494,36 +2502,54 @@ procedure TmwSimplePasPar.InParameter; end; end; -procedure TmwSimplePasPar.AsmStatement; +procedure TmwSimplePasPar.AsmStatements; begin Lexer.AsmCode := True; Expected(ptAsm); { should be replaced with a Assembler lexer } - while TokenID <> ptEnd do + while TokenID <> ptEnd do begin case FLexer.TokenID of - ptBegin, ptCase, ptEnd, ptIf, ptFunction, ptProcedure, ptRepeat, ptwhile: Break; + ptBegin, ptCase, ptEnd, ptIf, ptFunction, ptProcedure, ptRepeat, ptWhile: Break; ptAddressOp: begin - NextToken; - NextToken; + NextTokenAssembly; + NextTokenAssembly; end; ptDoubleAddressOp: begin - NextToken; - NextToken; + NextTokenAssembly; + NextTokenAssembly; end; ptNull: begin Expected(ptEnd); Exit; end; - else - NextToken; - end; + ptCRLF: //empty line + NextTokenAssembly; + else begin + AsmStatement; + Expected(ptCRLF); + end; + end; {case} + end; {while} Lexer.AsmCode := False; Expected(ptEnd); end; +procedure TmwSimplePasPar.AsmStatement; +begin + while not(Lexer.TokenID in [ptCRLF]) do begin + AsmFragment; + end; +end; + +procedure TmwSimplePasPar.AsmFragment; +begin + NextTokenAssembly; +end; + + procedure TmwSimplePasPar.AsOp; begin Expected(ptAs); @@ -2652,7 +2678,7 @@ procedure TmwSimplePasPar.Statement; case TokenID of ptAsm: begin - AsmStatement; + AsmStatements; end; ptBegin: begin From 644161aa41108f16fa6d7a5080ab18ed0a34658c Mon Sep 17 00:00:00 2001 From: jbontes Date: Wed, 18 Oct 2017 16:12:14 +0200 Subject: [PATCH 38/42] #257 small refinements. --- Source/DelphiAST.pas | 28 +++++++++++++++------- Source/SimpleParser/SimpleParser.Lexer.pas | 20 ++++++++-------- Source/SimpleParser/SimpleParser.pas | 16 +++++++++---- 3 files changed, 40 insertions(+), 24 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 2d8a5334..03a2f1d4 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -98,6 +98,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ArrayDimension; override; procedure ArrayOfConst; override; procedure AsmFragment; override; + procedure AsmLabelAt; override; procedure AsmStatement; override; procedure AsmStatements; override; procedure AsOp; override; @@ -156,7 +157,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure ExceptionBlockElseBranch; override; procedure ExceptionHandler; override; procedure ExceptionVariable; override; - procedure ExplicitType; override; //#220+#181 + procedure ExplicitType; override; procedure ExportedHeading; override; procedure ExportsClause; override; procedure ExportsElement; override; @@ -281,7 +282,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure VisibilityPublic; override; procedure VisibilityPublished; override; procedure VisibilityStrictPrivate; override; - procedure VisibilityStrictProtected; override; + procedure VisibilityStrictProtected; override; procedure WhileStatement; override; procedure WithExpressionList; override; procedure WithStatement; override; @@ -530,7 +531,7 @@ procedure TPasSyntaxTreeBuilder.AlignmentParameter; procedure TPasSyntaxTreeBuilder.AnonymousMethod; begin - FStack.Push(ntAnonymousMethod).Attribute[anKind]:= Lexer.Token; + FStack.Push(ntAnonymousMethod).Attribute[anKind]:= Lexer.Token; //function or procedure try inherited; finally @@ -550,12 +551,12 @@ procedure TPasSyntaxTreeBuilder.AnonymousMethodType; procedure TPasSyntaxTreeBuilder.AnonymousMethodTypeProcedure; begin - FStack.Peek.Attribute[anKind]:= Lexer.Token; + FStack.Peek.Attribute[anKind]:= Lexer.Token; //procedure end; procedure TPasSyntaxTreeBuilder.AnonymousMethodTypeFunction; begin - FStack.Peek.Attribute[anKind]:= Lexer.Token; + FStack.Peek.Attribute[anKind]:= Lexer.Token; //function end; procedure TPasSyntaxTreeBuilder.ArrayBounds; @@ -603,7 +604,12 @@ procedure TPasSyntaxTreeBuilder.AsmFragment; begin FStack.AddValuedChild(ntAsmFragment, Lexer.Token); inherited; +end; +procedure TPasSyntaxTreeBuilder.AsmLabelAt; +begin + FStack.AddValuedChild(ntAsmFragment, Lexer.Token); + inherited; end; procedure TPasSyntaxTreeBuilder.AsmStatement; @@ -621,7 +627,7 @@ procedure TPasSyntaxTreeBuilder.AsmStatement; Previous:= ' '; for Child in Node.ChildNodes do begin //Store the whole statement as well as the parts. - if (ValuedChild.Value[1] in [',', '+', '*', ']', ')', ' ','-']) or (Previous in ['(','[',',','+','*','-']) then Optional:= ''; + if (ValuedChild.Value[1] in [',', '+', '*', ']', ')', ' ','-',':']) or (Previous in ['(','[',',','+','*','-','@']) then Optional:= ''; Previous:= ValuedChild.Value[1]; ValuedNode.Value:= ValuedNode.Value + Optional + ValuedChild.Value; Optional:= ' '; @@ -633,7 +639,7 @@ procedure TPasSyntaxTreeBuilder.AsmStatement; procedure TPasSyntaxTreeBuilder.AsmStatements; begin - FStack.PushCompoundSyntaxNode(ntStatements).Attribute[anType]:= AttributeValues[atAsm]; + FStack.PushCompoundSyntaxNode(ntStatements).Attribute[anKind]:= AttributeValues[atAsm]; try inherited; SetCurrentCompoundNodesEndPosition; @@ -2538,8 +2544,8 @@ function TPasSyntaxTreeBuilder.Run(SourceStream: TStream): TSyntaxNode; except on E: EParserException do raise ESyntaxTreeException.Create(E.Line, E.Col, Lexer.FileName, E.Message, Result); - on E: ESyntaxError do - raise ESyntaxTreeException.Create(E.PosXY.X, E.PosXY.Y, Lexer.FileName, E.Message, Result); + on E: ESyntaxError do + raise ESyntaxTreeException.Create(E.PosXY.X, E.PosXY.Y, Lexer.FileName, E.Message, Result); else FreeAndNil(Result); raise; @@ -2768,6 +2774,7 @@ procedure TPasSyntaxTreeBuilder.SubrangeType; FStack.Pop; end; end; + procedure TPasSyntaxTreeBuilder.TagField; var TagNode: TSyntaxNode; @@ -2779,7 +2786,9 @@ procedure TPasSyntaxTreeBuilder.TagField; inherited; TypeNode:= FStack.Peek.FindNode(ntIdentifier); if (Assigned(TypeNode)) then begin + //move the name to the correct pos. TagNode.Attribute[anName]:= TagNode.Attribute[anKind]; + //Fill in the type of te node TagNode.Attribute[anKind]:= TypeNode.Attribute[anKind]; TagNode.DeleteChild(TypeNode); end; @@ -2787,6 +2796,7 @@ procedure TPasSyntaxTreeBuilder.TagField; FStack.Pop; end; end; + procedure TPasSyntaxTreeBuilder.TagFieldTypeName; begin FStack.Push(ntIdentifier).Attribute[anKind]:= Lexer.Token; diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index 06e5652a..5852d858 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -619,8 +619,8 @@ function TmwBasePasLex.Func15: TptTokenKind; function TmwBasePasLex.Func19: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Do') then Result := ptDo else - if KeyComp('And') then Result := ptAnd; + if KeyComp('Do') then Result := ptDo + else if KeyComp('And') then Result := ptAnd; end; function TmwBasePasLex.Func20: TptTokenKind; @@ -686,9 +686,9 @@ function TmwBasePasLex.Func32: TptTokenKind; function TmwBasePasLex.Func33: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('Or') then Result := ptOr else - if KeyComp('Name') then FExID := ptName else - if KeyComp('Asm') then Result := ptAsm; + if KeyComp('Or') then Result := ptOr + else if KeyComp('Name') then FExID := ptName + else if KeyComp('Asm') then Result := ptAsm; end; function TmwBasePasLex.Func35: TptTokenKind; @@ -722,8 +722,8 @@ function TmwBasePasLex.Func38: TptTokenKind; function TmwBasePasLex.Func39: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('For') then Result := ptFor else - if KeyComp('Shl') then Result := ptShl; + if KeyComp('For') then Result := ptFor + else if KeyComp('Shl') then Result := ptShl; end; function TmwBasePasLex.Func40: TptTokenKind; @@ -819,9 +819,9 @@ function TmwBasePasLex.Func56: TptTokenKind; function TmwBasePasLex.Func57: TptTokenKind; begin Result := ptIdentifier; - if KeyComp('While') then Result := ptWhile else - if KeyComp('Xor') then Result := ptXor else - if KeyComp('Goto') then Result := ptGoto; + if KeyComp('While') then Result := ptWhile + else if KeyComp('Xor') then Result := ptXor + else if KeyComp('Goto') then Result := ptGoto; end; function TmwBasePasLex.Func58: TptTokenKind; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 0a835e0b..a57f965e 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -254,6 +254,7 @@ TmwSimplePasPar = class(TObject) procedure ArraySubType; virtual; procedure ArrayType; virtual; procedure AsmFragment; virtual; + procedure AsmLabelAt; virtual; procedure AsmStatement; virtual; procedure AsmStatements; virtual; procedure AssignOp; virtual; @@ -2512,13 +2513,11 @@ procedure TmwSimplePasPar.AsmStatements; ptBegin, ptCase, ptEnd, ptIf, ptFunction, ptProcedure, ptRepeat, ptWhile: Break; ptAddressOp: begin - NextTokenAssembly; - NextTokenAssembly; + AsmStatement; end; ptDoubleAddressOp: begin - NextTokenAssembly; - NextTokenAssembly; + AsmStatement; end; ptNull: begin @@ -2540,7 +2539,10 @@ procedure TmwSimplePasPar.AsmStatements; procedure TmwSimplePasPar.AsmStatement; begin while not(Lexer.TokenID in [ptCRLF]) do begin - AsmFragment; + case TokenID of + ptAddressOp, ptDoubleAddressOp: AsmLabelAt; + else AsmFragment; + end; end; end; @@ -2549,6 +2551,10 @@ procedure TmwSimplePasPar.AsmFragment; NextTokenAssembly; end; +procedure TmwSimplePasPar.AsmLabelAt; +begin + NextTokenAssembly; +end; procedure TmwSimplePasPar.AsOp; begin From 1e3101d0f2f74cbde05139fdf57ae034e8e93e74 Mon Sep 17 00:00:00 2001 From: jbontes Date: Thu, 19 Oct 2017 12:51:22 +0200 Subject: [PATCH 39/42] #258 type safe `TOperators`. #217 fix corruption of childnode list. --- Source/DelphiAST.Classes.pas | 11 +++--- Source/DelphiAST.Consts.pas | 16 ++++---- Source/DelphiAST.pas | 75 +++++++++++++++++++++++++++++++----- 3 files changed, 79 insertions(+), 23 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 3d3f11db..3614bdc9 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -19,7 +19,7 @@ EParserException = class(Exception) property Line: Integer read FLine; property Col: Integer read FCol; end; - + TAttributeEntry = TPair; PAttributeEntry = ^TAttributeEntry; @@ -136,7 +136,7 @@ TOperators = class end; const - OperatorsInfo: array [0..28] of TOperatorInfo = + OperatorsInfo: array [ntAddr..ntIs] of TOperatorInfo = ((Typ: ntAddr; Priority: 1; Kind: okUnary; AssocType: atRight), (Typ: ntDoubleAddr; Priority: 1; Kind: okUnary; AssocType: atRight), (Typ: ntDeref; Priority: 1; Kind: okUnary; AssocType: atLeft), @@ -171,7 +171,9 @@ TOperators = class class function TOperators.GetItem(Typ: TSyntaxNodeType): TOperatorInfo; begin - if (Typ in [ntAddr..ntIs]) then Exit(OperatorsInfo[Ord(Typ) - Ord(ntAddr)]); //#224 + Assert(Typ = OperatorsInfo[Typ].Typ); + if (Typ in [ntAddr..ntIs]) then Exit(OperatorsInfo[Typ]) + else Assert(false); end; class function TOperators.IsOpName(Typ: TSyntaxNodeType): Boolean; @@ -397,11 +399,9 @@ function TSyntaxNode.TryGetAttributeEntry(const Key: TAttributeName; out Attribu end; end; - function TSyntaxNode.AddChild(Node: TSyntaxNode): TSyntaxNode; begin Assert(Assigned(Node)); - SetLength(FChildNodes, Length(FChildNodes) + 1); FChildNodes[Length(FChildNodes) - 1] := Node; @@ -593,4 +593,5 @@ constructor EParserException.Create(Line, Col: Integer; const FileName, Msg: str FCol := Col; end; + end. \ No newline at end of file diff --git a/Source/DelphiAST.Consts.pas b/Source/DelphiAST.Consts.pas index fbc86a13..d500535d 100644 --- a/Source/DelphiAST.Consts.pas +++ b/Source/DelphiAST.Consts.pas @@ -21,8 +21,6 @@ interface ntShl, ntShr, ntAs, - ntAsmFragment, - ntAsmStatement, ntAdd, ntSub, ntOr, @@ -50,6 +48,8 @@ interface ntAnonymousMethod, ntAnonymousMethodType, ntArguments, + ntAsmFragment, + ntAsmStatement, ntAssign, ntAt, ntAttribute, @@ -183,17 +183,15 @@ interface TAttributeNames = set of TAttributeName; type - TSyntaxNodeNames = record + SyntaxNodeNames = class strict private class var FData: array[TSyntaxNodeType] of string; - function GetItem(const index: TSyntaxNodeType): string; inline; + class function GetItem(const index: TSyntaxNodeType): string; static; inline; class constructor Init; public - property Items[const index: TSyntaxNodeType]: string read GetItem; default; + class property Items[const index: TSyntaxNodeType]: string read GetItem; default; end; -var - SyntaxNodeNames: TSyntaxNodeNames; //for some reason default does not work on class properties. //const @@ -361,12 +359,12 @@ implementation { TSyntaxNodeNames } -function TSyntaxNodeNames.GetItem(const index: TSyntaxNodeType): string; +class function SyntaxNodeNames.GetItem(const index: TSyntaxNodeType): string; begin Result:= FData[index]; end; -class constructor TSyntaxNodeNames.Init; +class constructor SyntaxNodeNames.Init; var value: TSyntaxNodeType; begin diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 03a2f1d4..75ac955b 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -773,11 +773,68 @@ procedure TPasSyntaxTreeBuilder.BuildExpressionTree( end; end; +//ExtractChild causes corruption of the childlist. need to investigate why. +//procedure TPasSyntaxTreeBuilder.BuildParametersList( +// ParametersListMethod: TTreeBuilderMethod); +//var +// Params, Temp: TSyntaxNode; +// Attributes: TSyntaxNode; +// ParamList, Param, TypeInfo, ParamExpr: TSyntaxNode; +// ParamKind: string; +//begin +// Params := TSyntaxNode.Create(ntUnknown); +// try +// FStack.Push(ntParameters); +// +// FStack.Push(Params); +// try +// ParametersListMethod; +// finally +// FStack.Pop; +// end; +// +// for ParamList in Params.ChildNodes do +// begin +// TypeInfo := ParamList.ExtractChild(ntType); +// ParamKind := ParamList.Attribute[anKind]; +// ParamExpr := ParamList.ExtractChild(ntExpression); +// Attributes:= ParamList.ExtractChild(ntAttributes); +// +// for Param in ParamList.ChildNodes do +// begin +// if Param.Typ <> ntName then +// Continue; +// +// Temp := FStack.Push(ntParameter); +// if ParamKind <> '' then +// Temp.Attribute[anKind] := ParamKind; +// +// Temp.Col := Param.Col; +// Temp.Line := Param.Line; +// +// if Assigned(Attributes) then +// FStack.AddChild(Attributes); +// +// FStack.AddChild(Param.Clone); +// if Assigned(TypeInfo) then +// FStack.AddChild(TypeInfo); +// +// if Assigned(ParamExpr) then +// FStack.AddChild(ParamExpr); +// +// FStack.Pop; +// end; +// end; +// FStack.Pop; +// finally +// Params.Free; +// end; +//end; + procedure TPasSyntaxTreeBuilder.BuildParametersList( ParametersListMethod: TTreeBuilderMethod); var - Params, Temp: TSyntaxNode; - Attributes: TSyntaxNode; + Params, Temp, Attributes: TSyntaxNode; ParamList, Param, TypeInfo, ParamExpr: TSyntaxNode; ParamKind: string; begin @@ -794,10 +851,10 @@ procedure TPasSyntaxTreeBuilder.BuildParametersList( for ParamList in Params.ChildNodes do begin - TypeInfo := ParamList.ExtractChild(ntType); + TypeInfo := ParamList.FindNode(ntType); ParamKind := ParamList.Attribute[anKind]; - ParamExpr := ParamList.ExtractChild(ntExpression); - Attributes:= ParamList.ExtractChild(ntAttributes); + ParamExpr := ParamList.FindNode(ntExpression); + Attributes:= ParamList.FindNode(ntAttributes); for Param in ParamList.ChildNodes do begin @@ -806,20 +863,20 @@ procedure TPasSyntaxTreeBuilder.BuildParametersList( Temp := FStack.Push(ntParameter); if ParamKind <> '' then - Temp.Attribute[anKind] := ParamKind; + Temp.Attribute[anKind]:= ParamKind; Temp.Col := Param.Col; Temp.Line := Param.Line; if Assigned(Attributes) then - FStack.AddChild(Attributes); + FStack.AddChild(Attributes.Clone); FStack.AddChild(Param.Clone); if Assigned(TypeInfo) then - FStack.AddChild(TypeInfo); + FStack.AddChild(TypeInfo.Clone); if Assigned(ParamExpr) then - FStack.AddChild(ParamExpr); + FStack.AddChild(ParamExpr.Clone); FStack.Pop; end; From 3f8415ec0426749fe7e50014543c61f051f1ca54 Mon Sep 17 00:00:00 2001 From: jbontes Date: Thu, 19 Oct 2017 13:07:40 +0200 Subject: [PATCH 40/42] #258 minor tweak --- Source/DelphiAST.Classes.pas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 3614bdc9..2d667d86 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -129,7 +129,7 @@ TOperatorInfo = record TOperators = class strict private - class function GetItem(Typ: TSyntaxNodeType): TOperatorInfo; static; + class function GetItem(Typ: TSyntaxNodeType): TOperatorInfo; inline; static; public class function IsOpName(Typ: TSyntaxNodeType): Boolean; class property Items[Typ: TSyntaxNodeType]: TOperatorInfo read GetItem; default; @@ -172,8 +172,8 @@ TOperators = class class function TOperators.GetItem(Typ: TSyntaxNodeType): TOperatorInfo; begin Assert(Typ = OperatorsInfo[Typ].Typ); - if (Typ in [ntAddr..ntIs]) then Exit(OperatorsInfo[Typ]) - else Assert(false); + Assert(Typ in [ntAddr..ntIs]); + Result:= OperatorsInfo[Typ]; //don't use exit in inline routines. end; class function TOperators.IsOpName(Typ: TSyntaxNodeType): Boolean; From 959fe23709e53f5676cdc5f833913174f9ad9e7c Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 20 Oct 2017 11:34:51 +0200 Subject: [PATCH 41/42] #227 correct label processing, #217 Fix bug in parameter processing introduced in the original 217 fix --- Source/DelphiAST.pas | 91 ++++++++++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 37 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 75ac955b..a5f2a159 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -195,6 +195,7 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasPar) procedure InterfaceGUID; override; procedure InterfaceSection; override; procedure InterfaceType; override; + procedure LabelDeclarationSection; override; procedure LabeledStatement; override; procedure LabelId; override; procedure LibraryFile; override; @@ -802,27 +803,23 @@ procedure TPasSyntaxTreeBuilder.BuildExpressionTree( // // for Param in ParamList.ChildNodes do // begin -// if Param.Typ <> ntName then -// Continue; +// if Param.Typ = ntName then begin // -// Temp := FStack.Push(ntParameter); -// if ParamKind <> '' then -// Temp.Attribute[anKind] := ParamKind; +// Temp:= FStack.Push(ntParameter); +// if ParamKind <> '' then Temp.Attribute[anKind]:= ParamKind; // -// Temp.Col := Param.Col; -// Temp.Line := Param.Line; +// Temp.Col:= Param.Col; +// Temp.Line:= Param.Line; // -// if Assigned(Attributes) then -// FStack.AddChild(Attributes); +// if Assigned(Attributes) then FStack.AddChild(Attributes); // -// FStack.AddChild(Param.Clone); -// if Assigned(TypeInfo) then -// FStack.AddChild(TypeInfo); +// FStack.AddChild(Param.Clone); +// if Assigned(TypeInfo) then FStack.AddChild(TypeInfo); // -// if Assigned(ParamExpr) then -// FStack.AddChild(ParamExpr); +// if Assigned(ParamExpr) then FStack.AddChild(ParamExpr); // -// FStack.Pop; +// FStack.Pop; +// end; // end; // end; // FStack.Pop; @@ -1306,7 +1303,7 @@ procedure TPasSyntaxTreeBuilder.ClassConstraint; inherited; finally FStack.Pop; - end; + end; end; procedure TPasSyntaxTreeBuilder.ConstructorConstraint; @@ -1316,7 +1313,7 @@ procedure TPasSyntaxTreeBuilder.ConstructorConstraint; inherited; finally FStack.Pop; - end; + end; end; procedure TPasSyntaxTreeBuilder.RecordConstant; @@ -1336,7 +1333,7 @@ procedure TPasSyntaxTreeBuilder.RecordConstraint; inherited; finally FStack.Pop; - end; + end; end; procedure TPasSyntaxTreeBuilder.ConstSection; @@ -1814,7 +1811,7 @@ procedure TPasSyntaxTreeBuilder.FinalizationSection; SetCurrentCompoundNodesEndPosition; finally FStack.Pop; - end; + end; end; procedure TPasSyntaxTreeBuilder.FinallyBlock; @@ -2035,7 +2032,7 @@ procedure TPasSyntaxTreeBuilder.InitializationSection; SetCurrentCompoundNodesEndPosition; finally FStack.Pop; - end; + end; end; procedure TPasSyntaxTreeBuilder.InterfaceForward; @@ -2076,8 +2073,22 @@ procedure TPasSyntaxTreeBuilder.InterfaceType; end; procedure TPasSyntaxTreeBuilder.LabeledStatement; +var + Node, Name: TSyntaxNode; +begin + Node:= FStack.Push(ntLabeledStatement); + Name:= Node.AddChild(ntName).AssignPositionFrom(Node); + Name.Attribute[anName]:= Lexer.Token; + try + inherited; + finally + FStack.Pop; + end; +end; + +procedure TPasSyntaxTreeBuilder.LabelDeclarationSection; begin - FStack.PushValuedNode(ntLabeledStatement, Lexer.Token); //#227 + FStack.Push(ntLabel); try inherited; finally @@ -2086,9 +2097,15 @@ procedure TPasSyntaxTreeBuilder.LabeledStatement; end; procedure TPasSyntaxTreeBuilder.LabelId; +var + Node, Name: TSyntaxNode; begin - FStack.AddValuedChild(ntLabel, Lexer.Token); - inherited; + FStack.Push(ntName).Attribute[anName]:= Lexer.Token; + try + inherited; + finally + FStack.Pop; + end; end; procedure TPasSyntaxTreeBuilder.LibraryFile; @@ -2902,7 +2919,7 @@ procedure TPasSyntaxTreeBuilder.TypeDeclaration; SetCurrentCompoundNodesEndPosition; finally FStack.Pop; - end; + end; end; procedure TPasSyntaxTreeBuilder.TypeId; @@ -2913,19 +2930,19 @@ procedure TPasSyntaxTreeBuilder.TypeId; begin TypeNode := FStack.Push(ntType); try - inherited; - + inherited; + InnerTypeName := ''; - InnerTypeNode := TypeNode.FindNode(ntType); + InnerTypeNode := TypeNode.FindNode(ntType); if Assigned(InnerTypeNode) then begin InnerTypeName := InnerTypeNode.Attribute[anName]; - for SubNode in InnerTypeNode.ChildNodes do + for SubNode in InnerTypeNode.ChildNodes do TypeNode.AddChild(SubNode.Clone); - + TypeNode.DeleteChild(InnerTypeNode); - end; - + end; + TypeName := ''; for i := Length(TypeNode.ChildNodes) - 1 downto 0 do begin @@ -2934,16 +2951,16 @@ procedure TPasSyntaxTreeBuilder.TypeId; begin if TypeName <> '' then TypeName := '.' + TypeName; - + TypeName := SubNode.Attribute[anName] + TypeName; TypeNode.DeleteChild(SubNode); - end; + end; end; - + if TypeName <> '' then - TypeName := '.' + TypeName; - TypeName := InnerTypeName + TypeName; - + TypeName := '.' + TypeName; + TypeName := InnerTypeName + TypeName; + DoHandleString(TypeName); TypeNode.Attribute[anName]:= TypeName; finally From c888a8970906a62c5abae608265cba0d2aad1ac9 Mon Sep 17 00:00:00 2001 From: jbontes Date: Fri, 20 Oct 2017 16:04:14 +0200 Subject: [PATCH 42/42] minor optimizations --- Source/DelphiAST.Classes.pas | 101 +++++++++++++++++++++-------------- Source/DelphiAST.pas | 2 +- 2 files changed, 62 insertions(+), 41 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 2d667d86..3f5d46a5 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -25,14 +25,17 @@ EParserException = class(Exception) TSyntaxNodeClass = class of TSyntaxNode; TSyntaxNode = class + public + function HasAttribute(const Key: TAttributeName): Boolean; inline; private FCol: Integer; FLine: Integer; FFileName: string; - function GetHasChildren: Boolean; + function GetHasChildren: Boolean; inline; function TryGetAttributeEntry(const Key: TAttributeName; out AttributeEntry: PAttributeEntry): boolean; - function GetChildCount: cardinal; - function GetChildNode(index: cardinal): TSyntaxNode; + function GetChildCount: cardinal; inline; + function GetChildNode(index: cardinal): TSyntaxNode; inline; + procedure RemoveAttribute(const Key: TAttributeName); protected FAttributes: TArray; FChildNodes: TArray; @@ -46,15 +49,14 @@ TSyntaxNode = class function Clone: TSyntaxNode; virtual; procedure AssignPositionFrom(const Node: TSyntaxNode); - function HasAttribute(const Key: TAttributeName): Boolean; inline; function GetAttribute(const Key: TAttributeName): string; procedure SetAttribute(const Key: TAttributeName; const Value: string); procedure ClearAttributes; + function AddChild(Typ: TSyntaxNodeType): TSyntaxNode; overload; inline; procedure AddChildren(Nodes: TArray); function AddChild(Node: TSyntaxNode): TSyntaxNode; overload; - function AddChild(Typ: TSyntaxNodeType): TSyntaxNode; overload; - procedure DeleteChild(Node: TSyntaxNode); + procedure DeleteChild(Node: TSyntaxNode); inline; function ExtractChild(Node: TSyntaxNode): TSyntaxNode; overload; function ExtractChild(Typ: TSyntaxNodeType): TSyntaxNode; overload; @@ -350,27 +352,76 @@ class procedure TExpressionTools.RawNodeListToTree(RawParentNode: TSyntaxNode; R { TSyntaxNode } + +function TSyntaxNode.HasAttribute(const Key: TAttributeName): Boolean; +begin + Result := Key in FAttributesInUse; +end; + procedure TSyntaxNode.ClearAttributes; begin SetLength(FAttributes, 0); FAttributesInUse:= []; end; +function TSyntaxNode.GetHasChildren: Boolean; +begin + Result := Length(FChildNodes) > 0; +end; + +function TSyntaxNode.GetChildCount: cardinal; +begin + Result:= Length(FChildNodes); +end; + +function TSyntaxNode.AddChild(Typ: TSyntaxNodeType): TSyntaxNode; +begin + Result := AddChild(TSyntaxNode.Create(Typ)); +end; + +function TSyntaxNode.GetChildNode(index: cardinal): TSyntaxNode; +begin + Assert(index < ChildCount); + Result:= FChildNodes[index]; +end; + +procedure TSyntaxNode.DeleteChild(Node: TSyntaxNode); +begin + ExtractChild(Node); + Node.Free; +end; + procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: string); var AttributeEntry: PAttributeEntry; len: Integer; begin - if not TryGetAttributeEntry(Key, AttributeEntry) then + if not HasAttribute(Key) then begin + if (Value = '') then Exit; //no action needed len := Length(FAttributes); SetLength(FAttributes, len + 1); AttributeEntry := @FAttributes[len]; AttributeEntry^.Key := Key; + Include(FAttributesInUse, Key); end; + if (Value = '') then RemoveAttribute(Key); AttributeEntry^.Value := Value; - if (Value = '') then Exclude(FAttributesInUse, Key) - else Include(FAttributesInUse, Key); +end; + +procedure TSyntaxNode.RemoveAttribute(const Key: TAttributeName); +const + Size = SizeOf(TAttributeEntry); +var + Entry: PAttributeEntry; + Index: integer; +begin + if HasAttribute(Key) then begin + TryGetAttributeEntry(Key, Entry); + Index:= (NativeUInt(Entry) - NativeUInt(@FAttributes[0])) + Size; + Move(Entry^, Pointer(NativeUInt(Entry)+Size)^, (High(FAttributes) * Size) - Index); + Exclude(FAttributesInUse, Key); + end; end; function SameText(const Needle: string; const HayStack: array of string): boolean; overload; @@ -382,6 +433,7 @@ function SameText(const Needle: string; const HayStack: array of string): boolea end; Result:= false; end; + function TSyntaxNode.TryGetAttributeEntry(const Key: TAttributeName; out AttributeEntry: PAttributeEntry): boolean; var i: integer; @@ -410,11 +462,6 @@ function TSyntaxNode.AddChild(Node: TSyntaxNode): TSyntaxNode; Result := Node; end; -function TSyntaxNode.AddChild(Typ: TSyntaxNodeType): TSyntaxNode; -begin - Result := AddChild(TSyntaxNode.Create(Typ)); -end; - procedure TSyntaxNode.AddChildren(Nodes: TArray); var Node: TSyntaxNode; @@ -453,10 +500,6 @@ constructor TSyntaxNode.Create(Typ: TSyntaxNodeType); FTyp := Typ; end; -function TSyntaxNode.HasAttribute(const Key: TAttributeName): Boolean; -begin - Result := Key in FAttributesInUse; -end; function TSyntaxNode.ExtractChild(Node: TSyntaxNode): TSyntaxNode; var @@ -474,12 +517,6 @@ function TSyntaxNode.ExtractChild(Node: TSyntaxNode): TSyntaxNode; end; end; -procedure TSyntaxNode.DeleteChild(Node: TSyntaxNode); -begin - ExtractChild(Node); - Node.Free; -end; - destructor TSyntaxNode.Destroy; var i: integer; @@ -532,22 +569,6 @@ function TSyntaxNode.GetAttribute(const Key: TAttributeName): string; Result := ''; end; -function TSyntaxNode.GetChildCount: cardinal; -begin - Result:= Length(FChildNodes); -end; - -function TSyntaxNode.GetChildNode(index: cardinal): TSyntaxNode; -begin - Assert(index < ChildCount); - Result:= FChildNodes[index]; -end; - -function TSyntaxNode.GetHasChildren: Boolean; -begin - Result := Length(FChildNodes) > 0; -end; - procedure TSyntaxNode.AssignPositionFrom(const Node: TSyntaxNode); begin FCol := Node.Col; diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index a5f2a159..85e78d2a 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -2077,7 +2077,7 @@ procedure TPasSyntaxTreeBuilder.LabeledStatement; Node, Name: TSyntaxNode; begin Node:= FStack.Push(ntLabeledStatement); - Name:= Node.AddChild(ntName).AssignPositionFrom(Node); + Name:= Node.AddChild(ntName); Name.Attribute[anName]:= Lexer.Token; try inherited;