From 6964589dc9e219f9a2261e24d7d95be41844f3e6 Mon Sep 17 00:00:00 2001 From: Patrick Quist Date: Thu, 8 Oct 2026 17:42:25 +0200 Subject: [PATCH 1/2] Overwrite an attribute the node already carries TSyntaxNode.SetAttribute pointed its entry pointer at a slot only when it added the key. For a key the node already carried the pointer was left uninitialised and the value was written through it anyway; dcc32 says so with W1036 on AttributeEntry. Any directive stored twice reaches it: procedure x(a: Integer); stdcall; stdcall; external 'a.dll' index 93; is legal Delphi, stores anCallingConvention twice and ends in an access violation, or in a silent write to whatever address the stack held. SetAttribute now looks the existing entry up with TryGetAttributeEntry and overwrites its value, and adds an entry only for a new key. An empty value removes the attribute and returns, instead of falling through to the same uninitialised pointer after RemoveAttribute. The last value stored wins, so `stdcall; cdecl;` records cdecl. --- Source/DelphiAST.Classes.pas | 9 ++++--- Test/UnitTests/DelphiAST.Tests.pas | 39 ++++++++++++++++++++++++++++++ 2 files changed, 45 insertions(+), 3 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 8752255..4d4dad3 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -421,16 +421,19 @@ 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; diff --git a/Test/UnitTests/DelphiAST.Tests.pas b/Test/UnitTests/DelphiAST.Tests.pas index c46a2bb..f4cd81b 100644 --- a/Test/UnitTests/DelphiAST.Tests.pas +++ b/Test/UnitTests/DelphiAST.Tests.pas @@ -241,6 +241,43 @@ procedure TestVariableEndPosition; 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 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; @@ -295,6 +332,8 @@ procedure RunAllTests; RunTest('AST.SourcePositions', TestSourcePositions); RunTest('AST.ConstantEndPosition', TestConstantEndPosition); RunTest('AST.VariableEndPosition', TestVariableEndPosition); + RunTest('Node.AttributeOverwrite', TestAttributeOverwrite); + RunTest('AST.RepeatedCallingConvention', TestRepeatedCallingConvention); RunTest('Parser.InvalidSyntax', TestInvalidSyntax); {$IFNDEF FPC} RunTest('Serialization.BinaryRoundTrip', TestBinarySerializationRoundTrip); From 6b0d0bac7fbea7762aa03aefb233a7aaacdfa9dc Mon Sep 17 00:00:00 2001 From: Patrick Quist Date: Thu, 8 Oct 2026 17:42:53 +0200 Subject: [PATCH 2/2] Remove an attribute by dropping its entry SetAttribute with an empty value goes through RemoveAttribute, which did not remove anything. It computed the byte offset of the entry past the one being removed and then moved the entries one slot further along rather than back, so the removed entry stayed, the one before the last was overwritten, and the array kept its length. Only the key's bit in FAttributesInUse was cleared, which hid the stale entry from HasAttribute but not from Attributes, so the writers and the binary serializer still saw it. The Move also copied the string values bit for bit, leaving two entries owning one reference. RemoveAttribute now shifts the entries after the removed one back by assignment, which keeps the string reference counts right, and shortens the array by one. --- Source/DelphiAST.Classes.pas | 25 ++++++++++++++----------- Test/UnitTests/DelphiAST.Tests.pas | 23 +++++++++++++++++++++++ 2 files changed, 37 insertions(+), 11 deletions(-) diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 4d4dad3..869d614 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -438,18 +438,21 @@ procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: strin 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; diff --git a/Test/UnitTests/DelphiAST.Tests.pas b/Test/UnitTests/DelphiAST.Tests.pas index f4cd81b..ffdf85b 100644 --- a/Test/UnitTests/DelphiAST.Tests.pas +++ b/Test/UnitTests/DelphiAST.Tests.pas @@ -258,6 +258,28 @@ procedure TestAttributeOverwrite; 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; @@ -333,6 +355,7 @@ procedure RunAllTests; RunTest('AST.ConstantEndPosition', TestConstantEndPosition); RunTest('AST.VariableEndPosition', TestVariableEndPosition); RunTest('Node.AttributeOverwrite', TestAttributeOverwrite); + RunTest('Node.AttributeRemove', TestAttributeRemove); RunTest('AST.RepeatedCallingConvention', TestRepeatedCallingConvention); RunTest('Parser.InvalidSyntax', TestInvalidSyntax); {$IFNDEF FPC}