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);