diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 10b785b..a03af08 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -5,7 +5,7 @@ interface uses - SysUtils, Generics.Collections, SimpleParser.Lexer.Types, DelphiAST.Consts; + SysUtils, {$IFDEF FPC_DOTTEDUNITS}System.Generics.Collections{$ELSE}Generics.Collections{$ENDIF}, SimpleParser.Lexer.Types, DelphiAST.Consts; type EParserException = class(Exception) @@ -104,6 +104,8 @@ TCompoundSyntaxNode = class(TSyntaxNode) FEndLine: Integer; public function Clone: TSyntaxNode; override; + //counterpart to AssignPositionFrom, for a node rebuilt from a parsed one + procedure AssignEndPositionFrom(const Node: TCompoundSyntaxNode); property EndCol: Integer read FEndCol write FEndCol; property EndLine: Integer read FEndLine write FEndLine; @@ -419,32 +421,38 @@ procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: strin AttributeEntry: PAttributeEntry; len: Integer; begin - if not HasAttribute(Key) then + if (Value = '') then + begin + RemoveAttribute(Key); + Exit; + end; + if not TryGetAttributeEntry(Key, AttributeEntry) 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; 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; + i, Kept: Integer; +begin + if not HasAttribute(Key) then + Exit; + Kept := 0; + for i := 0 to High(FAttributes) do + if FAttributes[i].Key <> Key then + begin + if Kept <> i then + FAttributes[Kept] := FAttributes[i]; + Inc(Kept); + end; + SetLength(FAttributes, Kept); + Exclude(FAttributesInUse, Key); end; function SameText(const Needle: string; const HayStack: array of string): boolean; overload; @@ -629,6 +637,12 @@ procedure TSyntaxNode.AssignPositionFrom(const Node: TSyntaxNode); { TCompoundSyntaxNode } +procedure TCompoundSyntaxNode.AssignEndPositionFrom(const Node: TCompoundSyntaxNode); +begin + FEndCol := Node.EndCol; + FEndLine := Node.EndLine; +end; + function TCompoundSyntaxNode.Clone: TSyntaxNode; begin Result := inherited; diff --git a/Source/DelphiAST.ProjectIndexer.pas b/Source/DelphiAST.ProjectIndexer.pas index 77e217a..4655908 100644 --- a/Source/DelphiAST.ProjectIndexer.pas +++ b/Source/DelphiAST.ProjectIndexer.pas @@ -5,7 +5,12 @@ interface uses - Classes, Generics.Defaults, Generics.Collections, + Classes, + {$IFDEF FPC_DOTTEDUNITS} + System.Generics.Defaults, System.Generics.Collections, + {$ELSE} + Generics.Defaults, Generics.Collections, + {$ENDIF} SimpleParser.Lexer.Types, DelphiAST, DelphiAST.Classes, DelphiAST.Consts; diff --git a/Source/DelphiAST.Serialize.Binary.pas b/Source/DelphiAST.Serialize.Binary.pas index 04ac283..f4a820e 100644 --- a/Source/DelphiAST.Serialize.Binary.pas +++ b/Source/DelphiAST.Serialize.Binary.pas @@ -6,7 +6,7 @@ interface uses Classes, - Generics.Collections, + {$IFDEF FPC_DOTTEDUNITS}System.Generics.Collections{$ELSE}Generics.Collections{$ENDIF}, DelphiAST.Consts, DelphiAST.Classes; diff --git a/Source/DelphiAST.SimpleParserEx.pas b/Source/DelphiAST.SimpleParserEx.pas index 6afd710..6f015b2 100644 --- a/Source/DelphiAST.SimpleParserEx.pas +++ b/Source/DelphiAST.SimpleParserEx.pas @@ -3,7 +3,7 @@ interface uses - SysUtils, Generics.Collections, SimpleParser, SimpleParser.Lexer.Types, + SysUtils, {$IFDEF FPC_DOTTEDUNITS}System.Generics.Collections{$ELSE}Generics.Collections{$ENDIF}, SimpleParser, SimpleParser.Lexer.Types, SimpleParser.Lexer, Classes; type diff --git a/Source/DelphiAST.Writer.pas b/Source/DelphiAST.Writer.pas index e85b06e..d98fda2 100644 --- a/Source/DelphiAST.Writer.pas +++ b/Source/DelphiAST.Writer.pas @@ -26,7 +26,7 @@ TSyntaxTreeWriter = class implementation uses - Generics.Collections, + {$IFDEF FPC_DOTTEDUNITS}System.Generics.Collections{$ELSE}Generics.Collections{$ENDIF}, {$IFNDEF FPC} DelphiAST.Serialize.Binary, {$ENDIF} diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index 7a1dcb5..b812935 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -5,7 +5,7 @@ interface uses - SysUtils, Classes, Generics.Collections, SimpleParser, SimpleParser.Lexer, + SysUtils, Classes, {$IFDEF FPC_DOTTEDUNITS}System.Generics.Collections{$ELSE}Generics.Collections{$ENDIF}, SimpleParser, SimpleParser.Lexer, SimpleParser.Lexer.Types, DelphiAST.Classes, DelphiAST.Consts, DelphiAST.SimpleParserEx; type @@ -1195,9 +1195,11 @@ procedure TPasSyntaxTreeBuilder.CompoundStatement; procedure TPasSyntaxTreeBuilder.ConstantDeclaration; begin - FStack.Push(ntConstant); + //compound: a constant's value can span lines, so record where it ends. as TypeDeclaration. + FStack.PushCompoundSyntaxNode(ntConstant); try inherited; + SetCurrentCompoundNodesEndPosition; finally FStack.Pop; end; @@ -1329,9 +1331,12 @@ procedure TPasSyntaxTreeBuilder.ConstSection; if Constant.Typ <> ntName then Continue; - Temp := FStack.Push(ConstList.Typ); + //compound: start from the name, end from the ConstList that measured the value. + Temp := FStack.PushCompoundSyntaxNode(ConstList.Typ); try Temp.AssignPositionFrom(Constant); + if ConstList is TCompoundSyntaxNode then + TCompoundSyntaxNode(Temp).AssignEndPositionFrom(TCompoundSyntaxNode(ConstList)); FStack.AddChild(Constant.Clone); if Assigned(TypeInfo) then @@ -2667,7 +2672,7 @@ function TPasSyntaxTreeBuilder.Run(SourceStream: TStream): TSyntaxNode; 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); + raise ESyntaxTreeException.Create(E.PosXY.Y, E.PosXY.X, Lexer.FileName, E.Message, Result); else FreeAndNil(Result); raise; @@ -3205,9 +3210,11 @@ procedure TPasSyntaxTreeBuilder.VarAbsolute; procedure TPasSyntaxTreeBuilder.VarDeclaration; begin - FStack.Push(ntVariables); + //compound: a variable's type or initialiser can span lines, so record where it ends. + FStack.PushCompoundSyntaxNode(ntVariables); try inherited; + SetCurrentCompoundNodesEndPosition; finally FStack.Pop; end; @@ -3298,9 +3305,12 @@ procedure TPasSyntaxTreeBuilder.RearrangeVarSection(const VarSect: TSyntaxNode); begin if Variable.Typ <> ntName then Continue; - Temp := FStack.Push(ntVariable); + //compound: start from the name, end from the VarList that measured the declaration. + Temp := FStack.PushCompoundSyntaxNode(ntVariable); try Temp.AssignPositionFrom(Variable); + if VarList is TCompoundSyntaxNode then + TCompoundSyntaxNode(Temp).AssignEndPositionFrom(TCompoundSyntaxNode(VarList)); FStack.AddChild(Variable.Clone); if Assigned(TypeInfo) then FStack.AddChild(TypeInfo.Clone); diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index ef8428f..2257785 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -56,7 +56,7 @@ interface uses SysUtils, Classes, Character, {$IFDEF FPC} - Generics.Collections, + {$IFDEF FPC_DOTTEDUNITS}System.Generics.Collections{$ELSE}Generics.Collections{$ENDIF}, {$ENDIF} SimpleParser.Lexer.Types; diff --git a/Source/SimpleParser/SimpleParser.pas b/Source/SimpleParser/SimpleParser.pas index 06caf50..f632596 100644 --- a/Source/SimpleParser/SimpleParser.pas +++ b/Source/SimpleParser/SimpleParser.pas @@ -3648,6 +3648,16 @@ procedure TmwSimplePasPar.OrdinalType; begin ConstantExpression; end; + { An operator after the identifier means the bound is a constant + expression, not a type name: array[mlab + 1..mlog]. Reading it as a + type name consumes the identifier alone and leaves the caller at the + operator, where it can only report an error. These are the operators + SimpleExpression and Term accept. } + ptAnd, ptDiv, ptMinus, ptMod, ptOr, ptPlus, ptShl, ptShr, ptSlash, + ptStar, ptXor: + begin + ConstantExpression; + end; else begin TypeID; diff --git a/Test/Snippets/arrayboundexpression.pas b/Test/Snippets/arrayboundexpression.pas new file mode 100644 index 0000000..1d695d1 --- /dev/null +++ b/Test/Snippets/arrayboundexpression.pas @@ -0,0 +1,22 @@ +unit arrayboundexpression; + +interface + +const + mlab = 4; + mlog = 12; + +type + { An array bound is a constant EXPRESSION, not just a constant or a type name. + OrdinalType decided on one token of lookahead and read `mlab` as a type name, + so the whole unit failed to parse at the `+`. } + TRanges = record + iu: array[mlab + 1..mlog] of Integer; + du: array[mlab * 2..mlog - 1, 0..mlab shl 1] of Byte; + end; + + TSetOfExpression = set of mlab + 1..mlog; + +implementation + +end. diff --git a/Test/UnitTests/DelphiAST.Tests.pas b/Test/UnitTests/DelphiAST.Tests.pas index 6d15948..9053210 100644 --- a/Test/UnitTests/DelphiAST.Tests.pas +++ b/Test/UnitTests/DelphiAST.Tests.pas @@ -177,6 +177,129 @@ procedure TestSourcePositions; end; end; +procedure TestConstantEndPosition; +var + Root, ConstsNode, Node, Spanning, Single: TSyntaxNode; +begin + Root := ParseSource('unit Consts;' + sLineBreak + 'interface' + sLineBreak + 'const' + + sLineBreak + ' Spanning = ''first part '' +' + sLineBreak + ' ''second part'';' + + sLineBreak + ' Single = 42;' + sLineBreak + 'implementation' + sLineBreak + 'end.'); + try + ConstsNode := FindDescendant(Root, ntConstants); + AssertNotNil(ConstsNode, 'No const section was produced'); + Spanning := nil; + Single := nil; + for Node in ConstsNode.ChildNodes do + if Node.Typ = ntConstant then + if Node.Line = 4 then + Spanning := Node + else if Node.Line = 6 then + Single := Node; + + AssertNotNil(Spanning, 'No constant starting on line 4'); + AssertTrue(Spanning is TCompoundSyntaxNode, + 'Constant node must be compound so it can carry an end position'); + AssertEquals(5, TCompoundSyntaxNode(Spanning).EndLine, + 'A multi-line constant must reach the last line of its value'); + + AssertNotNil(Single, 'No constant starting on line 6'); + AssertEquals(6, TCompoundSyntaxNode(Single).EndLine, + 'A single-line constant must end on its own line, not run on to what follows'); + finally + Root.Free; + end; +end; + +procedure TestVariableEndPosition; +var + Root, Node, Spanning, Single: TSyntaxNode; +begin + Root := ParseSource('unit Vars;' + sLineBreak + 'interface' + sLineBreak + 'var' + + sLineBreak + ' Spanning: array[0..1] of' + sLineBreak + ' Integer;' + sLineBreak + + ' Single: Integer;' + sLineBreak + 'implementation' + sLineBreak + 'end.'); + try + Spanning := nil; + Single := nil; + for Node in FindDescendant(Root, ntVariables).ChildNodes do + if Node.Typ = ntVariable then + if Node.Line = 4 then + Spanning := Node + else if Node.Line = 6 then + Single := Node; + + AssertNotNil(Spanning, 'No variable starting on line 4'); + AssertTrue(Spanning is TCompoundSyntaxNode, + 'Variable node must be compound so it can carry an end position'); + AssertEquals(5, TCompoundSyntaxNode(Spanning).EndLine, + 'A variable whose declaration spans lines must reach its last line'); + + AssertNotNil(Single, 'No variable starting on line 6'); + AssertEquals(6, TCompoundSyntaxNode(Single).EndLine, + 'A single-line variable must end on its own line, not run on to what follows'); + finally + Root.Free; + end; +end; + +procedure TestAttributeOverwrite; +var + Node: TSyntaxNode; +begin + Node := TSyntaxNode.Create(ntMethod); + try + Node.SetAttribute(anName, 'First'); + Node.SetAttribute(anType, 'Kept'); + Node.SetAttribute(anName, 'Second'); + AssertEquals('Second', Node.GetAttribute(anName), 'Overwritten attribute.'); + AssertEquals('Kept', Node.GetAttribute(anType), 'Other attribute.'); + AssertEquals(2, Length(Node.Attributes), 'Overwriting must not add an entry.'); + finally + Node.Free; + end; +end; + +procedure TestAttributeRemove; +var + Node: TSyntaxNode; +begin + Node := TSyntaxNode.Create(ntMethod); + try + Node.SetAttribute(anName, 'Name'); + Node.SetAttribute(anType, 'Type'); + Node.SetAttribute(anKind, 'Kind'); + Node.SetAttribute(anName, ''); + AssertFalse(Node.HasAttribute(anName), 'An empty value removes the attribute.'); + AssertEquals(2, Length(Node.Attributes), 'Removing must drop the entry.'); + AssertEquals('Type', Node.GetAttribute(anType), 'First remaining attribute.'); + AssertEquals('Kind', Node.GetAttribute(anKind), 'Second remaining attribute.'); + Node.SetAttribute(anName, 'Again'); + AssertEquals('Again', Node.GetAttribute(anName), 'A removed attribute can be set again.'); + AssertEquals(3, Length(Node.Attributes), 'Setting it again adds one entry.'); + finally + Node.Free; + end; +end; + +procedure TestRepeatedCallingConvention; +var + Root, IntfNode: TSyntaxNode; +begin + Root := ParseSource('unit Example; interface ' + + 'procedure Same(A: Integer); stdcall; stdcall; external ''a.dll'' index 93; ' + + 'procedure Other; stdcall; cdecl; external ''a.dll''; implementation end.'); + try + IntfNode := FindDescendant(Root, ntInterface); + AssertNotNil(IntfNode, 'Missing interface'); + AssertEquals(2, CountDescendants(IntfNode, ntMethod), 'Method count.'); + AssertEquals('stdcall', IntfNode.ChildNodes[0].GetAttribute(anCallingConvention), + 'A repeated calling convention.'); + AssertEquals('cdecl', IntfNode.ChildNodes[1].GetAttribute(anCallingConvention), + 'The last of two calling conventions.'); + finally + Root.Free; + end; +end; + procedure TestInvalidSyntax; var Root: TSyntaxNode; @@ -194,6 +317,28 @@ procedure TestInvalidSyntax; AssertTrue(Raised, 'Invalid syntax did not raise ESyntaxTreeException'); end; +procedure TestUnexpectedEndOfFilePosition; +var + Root: TSyntaxNode; + Raised: Boolean; +begin + Root := nil; + Raised := False; + try + Root := ParseSource('unit Broken;' + sLineBreak + 'interface' + sLineBreak + + 'implementation' + sLineBreak + 'procedure Run;' + sLineBreak + 'begin'); + except + on E: ESyntaxTreeException do + begin + Raised := True; + AssertEquals(5, E.Line, 'The end of file is on line 5.'); + AssertEquals(6, E.Col, 'The end of file is after the 5 characters of "begin".'); + end; + end; + Root.Free; + AssertTrue(Raised, 'An unexpected end of file did not raise ESyntaxTreeException'); +end; + {$IFNDEF FPC} procedure TestBinarySerializationRoundTrip; var @@ -229,7 +374,13 @@ procedure RunAllTests; RunTest('AST.GenericRecordAndProperty', TestGenericRecordAndProperty); RunTest('Writer.LiteralsUnicodeAndXmlEscaping', TestLiteralsAndUnicode); RunTest('AST.SourcePositions', TestSourcePositions); + RunTest('AST.ConstantEndPosition', TestConstantEndPosition); + RunTest('AST.VariableEndPosition', TestVariableEndPosition); + RunTest('Node.AttributeOverwrite', TestAttributeOverwrite); + RunTest('Node.AttributeRemove', TestAttributeRemove); + RunTest('AST.RepeatedCallingConvention', TestRepeatedCallingConvention); RunTest('Parser.InvalidSyntax', TestInvalidSyntax); + RunTest('Parser.UnexpectedEndOfFilePosition', TestUnexpectedEndOfFilePosition); {$IFNDEF FPC} RunTest('Serialization.BinaryRoundTrip', TestBinarySerializationRoundTrip); {$ENDIF}