From 54a0fd2f1c4c5a58523346f3334e3aafd5035dcd Mon Sep 17 00:00:00 2001 From: Partouf Date: Thu, 8 Oct 2026 19:41:24 +0200 Subject: [PATCH 1/2] Keep a compiler directive that comes before the unit keyword A switch directive before `unit` - {$WARN UNIT_PLATFORM OFF}, {$D+}, {$APPTYPE GUI}, all accepted by Delphi - failed the whole parse with EListError "Unbalanced stack or queue operation". The parser reads the first token before UnitFile pushes the root node, so CompilerDirective ran with an empty stack and its FStack.Peek raised. Conditional directives never reach CompilerDirective, which is why {$IFNDEF X} unit Y; {$ENDIF} was fine. Hold such a directive until the root exists. PushRootNode, now shared by UnitFile, ProgramFile, LibraryFile and PackageFile, creates the root and adopts them, so they sit first under it in source order - where a directive right after `unit X;` already goes, since GetMainSection returns the root for a node without a parent. Run frees any left over from a parse that failed before reaching the keyword. Co-Authored-By: Claude Opus 5.5 --- Source/DelphiAST.pas | 51 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 10 deletions(-) diff --git a/Source/DelphiAST.pas b/Source/DelphiAST.pas index a451163..4f8bd86 100644 --- a/Source/DelphiAST.pas +++ b/Source/DelphiAST.pas @@ -63,8 +63,12 @@ TPasSyntaxTreeBuilder = class(TmwSimplePasParEx) procedure DoOnComment(Sender: TObject; const Text: string); function DequoteString(const S: string): string; function GetMainSection(Node: TSyntaxNode): TSyntaxNode; + procedure PushRootNode(Typ: TSyntaxNodeType); protected FStack: TNodeStack; + //Compiler directives that come before the `unit`/`program`/`library`/`package` keyword, + //when there is no root node yet to put them under. PushRootNode adopts them. + FLeadingDirectives: TList; FComments: TObjectList; procedure AccessSpecifier; override; procedure AdditiveOperator; override; @@ -1148,6 +1152,18 @@ function TPasSyntaxTreeBuilder.GetMainSection(Node: TSyntaxNode): TSyntaxNode; Result:= Node; end; +procedure TPasSyntaxTreeBuilder.PushRootNode(Typ: TSyntaxNodeType); +var + Node: TSyntaxNode; +begin + FStack.Push(TSyntaxNode.Create(Typ)); + AssignLexerPositionToNode(Lexer, FStack.Peek); + //A directive before the keyword goes where one right after it would: under the root. + for Node in FLeadingDirectives do + FStack.Peek.AddChild(Node); + FLeadingDirectives.Clear; +end; + procedure TPasSyntaxTreeBuilder.CompilerDirective; var Directive: string; @@ -1158,11 +1174,19 @@ procedure TPasSyntaxTreeBuilder.CompilerDirective; Directive:= Uppercase(Lexer.Token); //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); + //A directive before the `unit` keyword comes before any node exists; hold on to it until + //PushRootNode creates the root. + if FStack.Count = 0 then + Root:= nil + else + Root:= GetMainSection(FStack.Peek); Node:= TValuedSyntaxNode.Create(ntCompilerDirective); AssignLexerPositionToNode(Lexer, Node); Node.Value:= Directive; - Root.AddChild(Node); + if Assigned(Root) then + Root.AddChild(Node) + else + FLeadingDirectives.Add(Node); //Parse the directive if (Directive.StartsWith('(*$')) then begin Delete(Directive, 1, 3); @@ -1367,6 +1391,7 @@ constructor TPasSyntaxTreeBuilder.Create; begin inherited; FStack := TNodeStack.Create(Lexer); + FLeadingDirectives := TList.Create; FComments := TObjectList.Create(True); OnComment := DoOnComment; end; @@ -1392,8 +1417,13 @@ function TPasSyntaxTreeBuilder.DequoteString(const S: string): string; end; destructor TPasSyntaxTreeBuilder.Destroy; +var + Node: TSyntaxNode; begin FStack.Free; + for Node in FLeadingDirectives do + Node.Free; + FLeadingDirectives.Free; FComments.Free; inherited; end; @@ -2158,8 +2188,7 @@ procedure TPasSyntaxTreeBuilder.LabelId; procedure TPasSyntaxTreeBuilder.LibraryFile; begin //Assert(FStack.Peek.ParentNode = nil); - FStack.Push(TSyntaxNode.Create(ntLibrary)); - AssignLexerPositionToNode(Lexer, FStack.Peek); + PushRootNode(ntLibrary); inherited; //Stack.pop is done in `Run` end; @@ -2355,8 +2384,7 @@ procedure TPasSyntaxTreeBuilder.OutParameter; procedure TPasSyntaxTreeBuilder.PackageFile; begin //Assert(FStack.Peek.ParentNode = nil); - FStack.Push(TSyntaxNode.Create(ntPackage)); - AssignLexerPositionToNode(Lexer, FStack.Peek); + PushRootNode(ntPackage); inherited; //Stack.pop is done in `Run` end; @@ -2451,8 +2479,7 @@ procedure TPasSyntaxTreeBuilder.ProcedureProcedureName; procedure TPasSyntaxTreeBuilder.ProgramFile; begin //Assert(FStack.Peek.ParentNode = nil); - FStack.Push(TSyntaxNode.Create(ntProgram)); - AssignLexerPositionToNode(Lexer, FStack.Peek); + PushRootNode(ntProgram); inherited; //Stack.pop is done in `Run` end; @@ -2657,10 +2684,15 @@ class function TPasSyntaxTreeBuilder.Run(const FileName: string; end; function TPasSyntaxTreeBuilder.Run(SourceStream: TStream): TSyntaxNode; +var + Node: TSyntaxNode; begin Result:= nil; try FStack.Clear; + for Node in FLeadingDirectives do + Node.Free; + FLeadingDirectives.Clear; try self.OnMessage := ParserMessage; inherited Run('', SourceStream); @@ -3117,8 +3149,7 @@ procedure TPasSyntaxTreeBuilder.UnaryMinus; procedure TPasSyntaxTreeBuilder.UnitFile; begin //Assert(FStack.Peek.ParentNode = nil); - FStack.Push(TSyntaxNode.Create(ntUnit)); - AssignLexerPositionToNode(Lexer, FStack.Peek); + PushRootNode(ntUnit); inherited; //Stack.pop is done in `Run` end; From 454450551e1410a2aad2fdf25f4787a7fc6612a5 Mon Sep 17 00:00:00 2001 From: Partouf Date: Thu, 8 Oct 2026 19:41:24 +0200 Subject: [PATCH 2/2] Test directives that come before the unit keyword AST.DirectiveBeforeUnit parses a unit that starts with {$WARN ...} and {$D+} and checks that both end up first under the ntUnit root, in source order, and that the rest of the unit still parses. It fails on main and passes with the fix. Co-Authored-By: Claude Opus 5.5 --- Test/UnitTests/DelphiAST.Tests.pas | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/Test/UnitTests/DelphiAST.Tests.pas b/Test/UnitTests/DelphiAST.Tests.pas index b69a872..910fb4f 100644 --- a/Test/UnitTests/DelphiAST.Tests.pas +++ b/Test/UnitTests/DelphiAST.Tests.pas @@ -317,6 +317,26 @@ procedure TestUnicodeStringTypecast; end; end; +procedure TestDirectiveBeforeUnit; +var + Root: TSyntaxNode; +begin + Root := ParseSource('{$WARN UNIT_PLATFORM OFF}' + sLineBreak + '{$D+}' + sLineBreak + + 'unit Example; interface implementation end.'); + try + AssertNotNil(Root, 'Missing root'); + AssertTrue(Root.Typ = ntUnit, 'The root is the unit.'); + AssertTrue(Root.ChildNodes[0].Typ = ntCompilerDirective, 'First directive under the root.'); + AssertEquals('WARN', Root.ChildNodes[0].GetAttribute(anType), 'First directive, in source order.'); + AssertEquals(1, Root.ChildNodes[0].Line, 'First directive line.'); + AssertTrue(Root.ChildNodes[1].Typ = ntCompilerDirective, 'Second directive under the root.'); + AssertEquals('D', Root.ChildNodes[1].GetAttribute(anType), 'Second directive, in source order.'); + AssertNotNil(FindDescendant(Root, ntImplementation), 'The rest of the unit still parses.'); + finally + Root.Free; + end; +end; + procedure TestInvalidSyntax; var Root: TSyntaxNode; @@ -397,6 +417,7 @@ procedure RunAllTests; RunTest('Node.AttributeRemove', TestAttributeRemove); RunTest('AST.RepeatedCallingConvention', TestRepeatedCallingConvention); RunTest('AST.UnicodeStringTypecast', TestUnicodeStringTypecast); + RunTest('AST.DirectiveBeforeUnit', TestDirectiveBeforeUnit); RunTest('Parser.InvalidSyntax', TestInvalidSyntax); RunTest('Parser.UnexpectedEndOfFilePosition', TestUnexpectedEndOfFilePosition); {$IFNDEF FPC}