From 4addcd107604f3cce8d1cc4e5bdf15651a426a2f Mon Sep 17 00:00:00 2001 From: Andrew Haines Date: Wed, 24 Jun 2026 17:48:59 -0400 Subject: [PATCH] feat(types): support forward class and interface declarations A bare `TFoo = class;` / `IFoo = interface;` (the keyword immediately followed by `;`, with no ancestor clause and no body) is a forward declaration: it registers a placeholder type that a later full declaration of the same name completes within the same declaration scope. This is the standard Object Pascal idiom for mutually referential types, e.g. a class declared between the forward and its full declaration may name the forward-declared type. Previously the front end registered the bare `class;` as a complete type and then rejected the full declaration as a duplicate type name, so the idiom could not be used at all. The parser flags the stub via TClassTypeDef.IsForward / TInterfaceTypeDef.IsForward. AnalyseTypeDecls registers the placeholder in pass 1, lets the matching full declaration complete it (reusing the placeholder descriptor) instead of erroring, skips the stub in pass 2, and after resolution drops the now-redundant stub from the AST so later phases see a single declaration. A forward never completed in the scope is reported as "Forward type not resolved"; a type forward-declared twice is "Duplicate forward type declaration". Tests: IR/semantic coverage for completion, mutual reference, unresolved, and double-forward errors, plus a single-vtable codegen check (the stub must not double-emit); an e2e test compiles and runs a mutually-referential class pair with a managed field. --- compiler/src/main/pascal/uAST.pas | 5 + compiler/src/main/pascal/uParser.pas | 16 +++ compiler/src/main/pascal/uSemantic.pas | 90 ++++++++++++- compiler/src/test/pascal/cp.test.classes.pas | 124 ++++++++++++++++++ .../src/test/pascal/cp.test.e2e.classes2.pas | 41 ++++++ .../src/test/pascal/cp.test.interfaces.pas | 50 +++++++ 6 files changed, 325 insertions(+), 1 deletion(-) diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 7513c3a..bef2d04 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -897,6 +897,8 @@ type Methods: TObjectList; { owned TMethodDecl } Properties: TObjectList; { owned TPropertyDecl } Attributes: TStringList; { owned — class-level custom attribute names e.g. 'Threaded' } + IsForward: Boolean; { True for a forward decl 'TFoo = class;' (no ancestor, + no body) — completed by the full decl later in scope } constructor Create; destructor Destroy; override; end; @@ -957,6 +959,7 @@ type ParentName: string; Methods: TObjectList; { owned TMethodDecl — forward signatures only } Properties: TObjectList; { owned TPropertyDecl — accessors are interface methods } + IsForward: Boolean; { True for a forward decl 'IFoo = interface;' — completed later in scope } constructor Create; destructor Destroy; override; end; @@ -2471,6 +2474,7 @@ begin if ASrc = nil then begin Result := nil; Exit; end; Result := TClassTypeDef.Create(); Result.ParentName := ASrc.ParentName; + Result.IsForward := ASrc.IsForward; for I := 0 to ASrc.ImplementsNames.Count - 1 do Result.ImplementsNames.Add(ASrc.ImplementsNames.Strings[I]); for I := 0 to ASrc.ConstDecls.Count - 1 do @@ -2511,6 +2515,7 @@ begin if ASrc = nil then begin Result := nil; Exit; end; Result := TInterfaceTypeDef.Create(); Result.ParentName := ASrc.ParentName; + Result.IsForward := ASrc.IsForward; for I := 0 to ASrc.Methods.Count - 1 do Result.Methods.Add(CloneMethodDecl(TMethodDecl(ASrc.Methods.Items[I]))); for I := 0 to ASrc.Properties.Count - 1 do diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index b296a84..c76c417 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -1975,6 +1975,15 @@ begin Result.Line := FCurrent.Line; Result.Col := FCurrent.Col; Expect(tkClass); + { Forward class declaration: the keyword `class` immediately followed by + `;` (no ancestor clause, no body). `class(TBase);` and `class end;` are + complete empty classes, not forwards. The full declaration later in the + same type scope completes it (see uSemantic.AnalyseTypeDecls). } + if Check(tkSemicolon) then + begin + Result.IsForward := True; + Exit; + end; if Check(tkLParen) then begin Advance(); @@ -2047,6 +2056,13 @@ begin Result.Line := FCurrent.Line; Result.Col := FCurrent.Col; Expect(tkIntf); + { Forward interface declaration `IFoo = interface;` — no parent, no body, + completed later in the same type scope. } + if Check(tkSemicolon) then + begin + Result.IsForward := True; + Exit; + end; if Check(tkLParen) then begin Advance(); diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 00175c7..102aa90 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -4843,7 +4843,16 @@ var IdxTD: TTypeDesc; ArrTD: TStaticArrayTypeDesc; Expected: Integer; + ForwardDecls: TStringList; { names of bare forward class/interface decls still + awaiting their completing full declaration } + FwdIdx: Integer; begin + { Forward declarations (`TFoo = class;` / `IFoo = interface;`) register a + placeholder type in pass 1 and are completed by a later full declaration of + the same name in this scope. Track the pending ones so a never-completed + forward is reported as an error. } + ForwardDecls := TStringList.Create(); + ForwardDecls.CaseSensitive := False; { Pass 1 — register all type symbols with empty descriptors. This allows self-referential field types to resolve in pass 2. } for I := 0 to ABlock.TypeDecls.Count - 1 do @@ -4855,7 +4864,37 @@ begin RT.IsPacked := TRecordTypeDef(TD.Def).IsPacked; end else if TD.Def is TClassTypeDef then - RT := FTable.NewClassType(TD.Name) + begin + if TClassTypeDef(TD.Def).IsForward then + begin + { Forward class: register a placeholder class type so intervening + declarations can name it. A name already in the table — including a + prior forward — is a redeclaration. } + if FTable.Lookup(TD.Name) <> nil then + begin + if ForwardDecls.IndexOf(TD.Name) >= 0 then + SemanticError(Format('Duplicate forward type declaration ''%s''', + [TD.Name]), TD.Line, TD.Col) + else + SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), + TD.Line, TD.Col); + end; + Sym := TSymbol.Create(TD.Name, skType, FTable.NewClassType(TD.Name)); + FTable.Define(Sym); + ForwardDecls.AddObject(TD.Name, TD); + Continue; + end; + { Full class declaration completing a pending forward: reuse the + placeholder descriptor (pass 2 re-derives it by name) — skip the + re-registration below. } + FwdIdx := ForwardDecls.IndexOf(TD.Name); + if FwdIdx >= 0 then + begin + ForwardDecls.Delete(FwdIdx); + Continue; + end; + RT := FTable.NewClassType(TD.Name); + end else if TD.Def is TGenericTypeDef then begin { Register as template — no concrete type symbol; instantiated on demand. @@ -4878,6 +4917,30 @@ begin end else if TD.Def is TInterfaceTypeDef then begin + if TInterfaceTypeDef(TD.Def).IsForward then + begin + { Forward interface: placeholder, completed later in scope. } + if FTable.Lookup(TD.Name) <> nil then + begin + if ForwardDecls.IndexOf(TD.Name) >= 0 then + SemanticError(Format('Duplicate forward type declaration ''%s''', + [TD.Name]), TD.Line, TD.Col) + else + SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), + TD.Line, TD.Col); + end; + Sym := TSymbol.Create(TD.Name, skType, FTable.NewInterfaceType(TD.Name)); + FTable.Define(Sym); + ForwardDecls.AddObject(TD.Name, TD); + Continue; + end; + { Full interface completing a pending forward: reuse the placeholder. } + FwdIdx := ForwardDecls.IndexOf(TD.Name); + if FwdIdx >= 0 then + begin + ForwardDecls.Delete(FwdIdx); + Continue; + end; IntfDesc := FTable.NewInterfaceType(TD.Name); Sym := TSymbol.Create(TD.Name, skType, IntfDesc); if not FTable.Define(Sym) then @@ -5064,6 +5127,11 @@ begin if TD.Def is TSetTypeDef then Continue; if TD.Def is TTypeAliasDef then Continue; + { Forward stub: the completing full declaration (same name, later) carries + the body and does all pass-2 work. } + if (TD.Def is TClassTypeDef) and TClassTypeDef(TD.Def).IsForward then Continue; + if (TD.Def is TInterfaceTypeDef) and TInterfaceTypeDef(TD.Def).IsForward then Continue; + { Procedural types: resolve param + return types now that all type names are registered. } if TD.Def is TProceduralTypeDef then @@ -5657,6 +5725,26 @@ begin if (Sym <> nil) and (Sym.Kind = skType) then TPointerTypeDesc(BaseSym.TypeDesc).BaseType := Sym.TypeDesc; end; + + { A forward declaration never completed in this scope is an error. } + if ForwardDecls.Count > 0 then + begin + TD := TTypeDecl(ForwardDecls.Objects[0]); + SemanticError(Format('Forward type not resolved ''%s''', + [ForwardDecls.Strings[0]]), TD.Line, TD.Col); + end; + + { Drop the now-redundant forward stubs from the AST so later phases (codegen + iterates ABlock.TypeDecls) never see two declarations of the same type. } + for I := ABlock.TypeDecls.Count - 1 downto 0 do + begin + TD := TTypeDecl(ABlock.TypeDecls.Items[I]); + if ((TD.Def is TClassTypeDef) and TClassTypeDef(TD.Def).IsForward) or + ((TD.Def is TInterfaceTypeDef) and TInterfaceTypeDef(TD.Def).IsForward) then + ABlock.TypeDecls.Delete(I); + end; + + ForwardDecls.Free(); end; procedure TSemanticAnalyser.AnalyseMethodBodies(ABlock: TBlock); diff --git a/compiler/src/test/pascal/cp.test.classes.pas b/compiler/src/test/pascal/cp.test.classes.pas index 9f247fa..37557b6 100644 --- a/compiler/src/test/pascal/cp.test.classes.pas +++ b/compiler/src/test/pascal/cp.test.classes.pas @@ -71,6 +71,15 @@ type procedure TestCodegen_MethodCall_CaseInsensitive; procedure TestCodegen_MethodBody_ReadsProgramGlobal; + { ------------------------------------------------------------------ } + { Forward class declarations (TFoo = class;) } + { ------------------------------------------------------------------ } + procedure TestSemantic_ForwardClass_CompletedByFullDecl; + procedure TestSemantic_ForwardClass_MutualReference; + procedure TestSemantic_ForwardClass_Unresolved_RaisesError; + procedure TestSemantic_ForwardClass_DoubleForward_RaisesError; + procedure TestCodegen_ForwardClass_SingleVTable; + { ------------------------------------------------------------------ } { Free built-in } { ------------------------------------------------------------------ } @@ -1180,6 +1189,121 @@ begin end; end; +{ ------------------------------------------------------------------ } +{ Forward class declarations } +{ ------------------------------------------------------------------ } + +procedure TClassTests.TestSemantic_ForwardClass_CompletedByFullDecl; +var + Prog: TProgram; +begin + { A bare `TFoo = class;` forward stub, completed by the full declaration + later in the same type section, must not be a duplicate-type error. } + Prog := AnalyseSrc( + ''' + program P; + type + TFoo = class; + TFoo = class + X: Integer; + end; + begin + end. + '''); + try + AssertTrue('forward class completed by full decl analyses OK', Prog <> nil); + finally + Prog.Free(); + end; +end; + +procedure TClassTests.TestSemantic_ForwardClass_MutualReference; +var + Prog: TProgram; +begin + { The point of a forward decl: a class declared between the forward and the + full declaration can name the forward-declared type. } + Prog := AnalyseSrc( + ''' + program P; + type + TFoo = class; + TBar = class + Foo: TFoo; + end; + TFoo = class + Bar: TBar; + end; + begin + end. + '''); + try + AssertTrue('mutual class reference via forward decl analyses OK', + Prog <> nil); + finally + Prog.Free(); + end; +end; + +procedure TClassTests.TestSemantic_ForwardClass_Unresolved_RaisesError; +begin + { A forward never completed in the scope is an error. } + AnalyseExpectError( + ''' + program P; + type + TFoo = class; + begin + end. + '''); +end; + +procedure TClassTests.TestSemantic_ForwardClass_DoubleForward_RaisesError; +begin + { The same type may be forward-declared only once. } + AnalyseExpectError( + ''' + program P; + type + TFoo = class; + TFoo = class; + TFoo = class + X: Integer; + end; + begin + end. + '''); +end; + +procedure TClassTests.TestCodegen_ForwardClass_SingleVTable; +var + IR: string; + Count: Integer; + P: Integer; +begin + { The forward stub is dropped after semantic analysis, so codegen must emit + the class's vtable exactly once — a second emission would be a duplicate + data symbol and fail to link. } + IR := GenIR( + ''' + program P; + type + TFoo = class; + TFoo = class + X: Integer; + end; + begin + end. + '''); + Count := 0; + P := 0; + repeat + P := PosEx('data $vtable_TFoo', IR, P); + if P >= 0 then begin Inc(Count); Inc(P) end; + until P < 0; + AssertEquals('vtable_TFoo emitted exactly once', 1, Count); +end; + initialization RegisterTest(TClassTests); diff --git a/compiler/src/test/pascal/cp.test.e2e.classes2.pas b/compiler/src/test/pascal/cp.test.e2e.classes2.pas index 3ced1bb..00aa662 100644 --- a/compiler/src/test/pascal/cp.test.e2e.classes2.pas +++ b/compiler/src/test/pascal/cp.test.e2e.classes2.pas @@ -159,6 +159,10 @@ type { ClassCreate builtin still works (backwards compat) and now dispatches the ctor body via vtable too. } procedure TestRun_ClassCreate_StillWorks; + { Forward class declaration with a managed (string) field: the forward + stub must complete into the same type so the full class — including its + ARC field — compiles and runs correctly. } + procedure TestRun_ForwardClass_MutualRefRuns; procedure TestRun_SelfIndexedRecordFieldAssign; end; @@ -201,6 +205,35 @@ const end. '''; + { Forward-declared TNode referenced by TEdge before its full definition, + then completed with a managed (string) field and a back-reference. } + SrcForwardClass = + ''' + program Prg; + type + TNode = class; + TEdge = class + Target: TNode; + end; + TNode = class + Name: string; + Link: TEdge; + end; + var + N: TNode; + E: TEdge; + begin + N := TNode.Create(); + N.Name := 'hello'; + E := TEdge.Create(); + E.Target := N; + N.Link := E; + WriteLn(E.Target.Name); + N.Free(); + E.Free() + end. + '''; + SrcToStringDefault = ''' program Prg; type @@ -2286,6 +2319,14 @@ begin AssertRunsOnAll(Src, '1' + LE, 0); end; +procedure TE2EClasses2Tests.TestRun_ForwardClass_MutualRefRuns; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRun(SrcForwardClass, Output, RCode)); + AssertEquals('forward-declared TNode field read back', 'hello', Trim(Output)); +end; + initialization RegisterTest(TE2EClasses2Tests); diff --git a/compiler/src/test/pascal/cp.test.interfaces.pas b/compiler/src/test/pascal/cp.test.interfaces.pas index 35af657..d482992 100644 --- a/compiler/src/test/pascal/cp.test.interfaces.pas +++ b/compiler/src/test/pascal/cp.test.interfaces.pas @@ -130,6 +130,12 @@ type procedure TestCodegen_IntfDispatch_RecordArg_PassesAggregate; procedure TestCodegen_IntfDispatch_OutString_PassesSlotAddr; procedure TestCodegen_DiscardedIntfReturnStmt_GetsSretAndRelease; + + { ------------------------------------------------------------------ } + { Forward interface declarations (IFoo = interface;) } + { ------------------------------------------------------------------ } + procedure TestSemantic_ForwardInterface_CompletedByFullDecl; + procedure TestSemantic_ForwardInterface_Unresolved_RaisesError; end; implementation @@ -1774,6 +1780,50 @@ begin Pos('call $_ClassRelease', Copy(IR, CallPos, MaxInt)) > 0); end; +{ ------------------------------------------------------------------ } +{ Forward interface declarations } +{ ------------------------------------------------------------------ } + +procedure TInterfaceTests.TestSemantic_ForwardInterface_CompletedByFullDecl; +var + Prog: TProgram; +begin + { `IFoo = interface;` forward stub completed later in the same scope. } + Prog := AnalyseSrc( + ''' + program P; + type + IFoo = interface; + IBar = interface + function GetFoo: IFoo; + end; + IFoo = interface + function GetBar: IBar; + end; + begin + end. + '''); + try + AssertTrue('forward interface completed by full decl analyses OK', + Prog <> nil); + finally + Prog.Free(); + end; +end; + +procedure TInterfaceTests.TestSemantic_ForwardInterface_Unresolved_RaisesError; +begin + { A forward interface never completed in the scope is an error. } + AnalyseExpectError( + ''' + program P; + type + IFoo = interface; + begin + end. + '''); +end; + initialization RegisterTest(TInterfaceTests);