diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 12aabbf..db9d1cc 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -639,6 +639,15 @@ var FPtrTemp: string; SlotOff: Integer; begin + { Built-in Free: load Self pointer and call C free() } + if (ACall.ResolvedMethod = nil) and SameText(ACall.Name, 'Free') then + begin + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', [SelfTemp, ACall.ObjectName])); + EmitLine(Format(' call $free(l %s)', [SelfTemp])); + Exit; + end; + RT := TRecordTypeDesc(ACall.ResolvedClassType); MDecl := TMethodDecl(ACall.ResolvedMethod); @@ -853,7 +862,8 @@ begin Continue; CD := TClassTypeDef(TD.Def); for J := 0 to CD.Methods.Count - 1 do - EmitMethodDef(TD.Name, TMethodDecl(CD.Methods[J])); + if TMethodDecl(CD.Methods[J]).Body <> nil then + EmitMethodDef(TD.Name, TMethodDecl(CD.Methods[J])); end; end; @@ -984,10 +994,17 @@ end; procedure TCodeGenQBE.EmitStandaloneDefs(AProg: TProgram); var - I: Integer; + I: Integer; + Decl: TMethodDecl; begin for I := 0 to AProg.Block.ProcDecls.Count - 1 do - EmitStandaloneDef(TMethodDecl(AProg.Block.ProcDecls[I])); + begin + Decl := TMethodDecl(AProg.Block.ProcDecls[I]); + { Class method impls (OwnerTypeName != '') had their body transferred to the + class method decl — skip them here; EmitMethodDefs handles them. } + if Decl.OwnerTypeName <> '' then Continue; + EmitStandaloneDef(Decl); + end; end; procedure TCodeGenQBE.EmitProcCall(ACall: TProcCall); diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index e2d14f3..709bdbd 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -304,6 +304,17 @@ begin [FCurrent.Line, FCurrent.Col]); Result.Name := FCurrent.Value; Advance; + { Qualified name: TypeName.MethodName (standalone class method implementation) } + if Check(tkDot) then + begin + Advance; + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected method name after ''.'' at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + Result.OwnerTypeName := Result.Name; + Result.Name := FCurrent.Value; + Advance; + end; if Check(tkLParen) then begin Advance; @@ -333,8 +344,13 @@ begin Advance; Expect(tkSemicolon); end; - Result.Body := ParseBlock; - Expect(tkSemicolon); + { Body is optional — present for standalone impls and inline class methods, + absent for class forward declarations (no begin/var/type follows) } + if Check(tkBegin) or Check(tkVar) or Check(tkType) then + begin + Result.Body := ParseBlock; + Expect(tkSemicolon); + end; except Result.Free; raise; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index b1a0269..0d9b561 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -28,6 +28,7 @@ type procedure AnalyseBlock(ABlock: TBlock); procedure AnalyseTypeDecls(ABlock: TBlock); + procedure LinkClassMethodImpls(ABlock: TBlock); procedure AnalyseMethodBodies(ABlock: TBlock); procedure AnalyseMethodDecl(AMethod: TMethodDecl; AClassType: TRecordTypeDesc); procedure AnalyseStandaloneDecls(ABlock: TBlock); @@ -270,12 +271,46 @@ begin end; end; +procedure TSemanticAnalyser.LinkClassMethodImpls(ABlock: TBlock); +var + I: Integer; + Decl: TMethodDecl; + Key: string; + Idx: Integer; + CD: TMethodDecl; +begin + for I := 0 to ABlock.ProcDecls.Count - 1 do + begin + Decl := TMethodDecl(ABlock.ProcDecls[I]); + if Decl.OwnerTypeName = '' then Continue; + Key := Decl.OwnerTypeName + '.' + Decl.Name; + Idx := FMethodIndex.IndexOf(Key); + if Idx < 0 then + SemanticError( + Format('Method ''%s'' is not declared in class ''%s''', + [Decl.Name, Decl.OwnerTypeName]), + Decl.Line, Decl.Col); + CD := TMethodDecl(FMethodIndex.Objects[Idx]); + if CD.Body <> nil then + SemanticError( + Format('Method ''%s.%s'' already has an inline body', + [Decl.OwnerTypeName, Decl.Name]), + Decl.Line, Decl.Col); + { Transfer the body; after this, AnalyseMethodBodies will find and analyse it } + CD.Body := Decl.Body; + Decl.Body := nil; + end; +end; + procedure TSemanticAnalyser.AnalyseBlock(ABlock: TBlock); begin { Type declarations are registered in the outer scope so they remain visible after the block scope is popped — needed for var declarations and the transferred symbol table used by codegen. } AnalyseTypeDecls(ABlock); + { Link standalone TTypeName.MethodName implementations to their class method + declarations, transferring the body so AnalyseMethodBodies can process it. } + LinkClassMethodImpls(ABlock); AnalyseMethodBodies(ABlock); FTable.PushScope; try @@ -565,6 +600,8 @@ begin for I := 0 to ABlock.ProcDecls.Count - 1 do begin ADecl := TMethodDecl(ABlock.ProcDecls[I]); + { Class method implementations have their body transferred; skip them here } + if ADecl.OwnerTypeName <> '' then Continue; { Resolve parameter types } for J := 0 to ADecl.Params.Count - 1 do @@ -650,10 +687,16 @@ end; procedure TSemanticAnalyser.AnalyseStandaloneBodies(ABlock: TBlock); var - I: Integer; + I: Integer; + ADecl: TMethodDecl; begin for I := 0 to ABlock.ProcDecls.Count - 1 do - AnalyseStandaloneDecl(TMethodDecl(ABlock.ProcDecls[I])); + begin + ADecl := TMethodDecl(ABlock.ProcDecls[I]); + { Class method implementations have their body transferred; skip them here } + if ADecl.OwnerTypeName <> '' then Continue; + AnalyseStandaloneDecl(ADecl); + end; end; procedure TSemanticAnalyser.AnalyseVarDecls(ABlock: TBlock); @@ -840,9 +883,18 @@ begin RT := TRecordTypeDesc(ObjSym.TypeDesc); MDecl := FindMethodDecl(RT.Name, ACall.Name); if MDecl = nil then + begin + { Free is a built-in: if Self <> nil then free(Self). No user-defined method needed. } + if SameText(ACall.Name, 'Free') and (ACall.Args.Count = 0) then + begin + ACall.ResolvedClassType := RT; + ACall.ResolvedMethod := nil; { nil signals built-in Free to codegen } + Exit; + end; SemanticError( Format('Class ''%s'' has no method ''%s''', [RT.Name, ACall.Name]), ACall.Line, ACall.Col); + end; if ACall.Args.Count <> MDecl.Params.Count then SemanticError( diff --git a/compiler/src/test/pascal/cp.test.classes.pas b/compiler/src/test/pascal/cp.test.classes.pas index bdcd7d9..a59248b 100644 --- a/compiler/src/test/pascal/cp.test.classes.pas +++ b/compiler/src/test/pascal/cp.test.classes.pas @@ -53,6 +53,20 @@ type procedure TestCodegen_Constructor_CallsMalloc; procedure TestCodegen_ClassFieldStore_LoadsPointer; procedure TestCodegen_ClassFieldLoad_LoadsPointer; + + { ------------------------------------------------------------------ } + { Separate method implementations } + { ------------------------------------------------------------------ } + procedure TestParse_SeparateImpl_ForwardDeclNoBody; + procedure TestParse_SeparateImpl_QualifiedName; + procedure TestSemantic_SeparateImpl_OK; + procedure TestCodegen_SeparateImpl_EmitsMethod; + + { ------------------------------------------------------------------ } + { Free built-in } + { ------------------------------------------------------------------ } + procedure TestSemantic_Free_OK; + procedure TestCodegen_Free_CallsCFree; end; implementation @@ -554,6 +568,104 @@ begin AssertTrue('loads field', Pos('loadw', IR) > 0); end; +{ ------------------------------------------------------------------ } +{ Separate method implementations } +{ ------------------------------------------------------------------ } + +const + SrcSeparateImpl = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' TFoo = class' + LineEnding + + ' X: Integer;' + LineEnding + + ' procedure SetX(AVal: Integer);' + LineEnding + + ' end;' + LineEnding + + 'procedure TFoo.SetX(AVal: Integer);' + LineEnding + + 'begin' + LineEnding + + ' Self.X := AVal' + LineEnding + + 'end;' + LineEnding + + 'var F: TFoo;' + LineEnding + + 'begin' + LineEnding + + ' F := TFoo.Create;' + LineEnding + + ' F.SetX(42)' + LineEnding + + 'end.'; + +procedure TClassTests.TestParse_SeparateImpl_ForwardDeclNoBody; +var + Prog: TProgram; + CD: TClassTypeDef; + MD: TMethodDecl; +begin + Prog := ParseSrc(SrcSeparateImpl); + try + CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def); + MD := TMethodDecl(CD.Methods[0]); + AssertNull('class method forward decl has no body', MD.Body); + finally + Prog.Free; + end; +end; + +procedure TClassTests.TestParse_SeparateImpl_QualifiedName; +var + Prog: TProgram; + MD: TMethodDecl; +begin + Prog := ParseSrc(SrcSeparateImpl); + try + { First ProcDecl in block is the standalone impl } + MD := TMethodDecl(Prog.Block.ProcDecls[0]); + AssertEquals('owner type name', 'TFoo', MD.OwnerTypeName); + AssertEquals('method name', 'SetX', MD.Name); + finally + Prog.Free; + end; +end; + +procedure TClassTests.TestSemantic_SeparateImpl_OK; +begin + AnalyseSrc(SrcSeparateImpl).Free; +end; + +procedure TClassTests.TestCodegen_SeparateImpl_EmitsMethod; +var IR: string; +begin + IR := GenIR(SrcSeparateImpl); + { The method body must appear in the IR as TFoo_SetX } + AssertTrue('TFoo_SetX emitted', Pos('$TFoo_SetX', IR) > 0); + { The call site must use it } + AssertTrue('call to TFoo_SetX', Pos('call $TFoo_SetX', IR) > 0); +end; + +{ ------------------------------------------------------------------ } +{ Free built-in } +{ ------------------------------------------------------------------ } + +const + SrcFree = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' TFoo = class' + LineEnding + + ' X: Integer;' + LineEnding + + ' end;' + LineEnding + + 'var F: TFoo;' + LineEnding + + 'begin' + LineEnding + + ' F := TFoo.Create;' + LineEnding + + ' F.Free' + LineEnding + + 'end.'; + +procedure TClassTests.TestSemantic_Free_OK; +begin + AnalyseSrc(SrcFree).Free; +end; + +procedure TClassTests.TestCodegen_Free_CallsCFree; +var IR: string; +begin + IR := GenIR(SrcFree); + AssertTrue('calls C free()', Pos('call $free', IR) > 0); +end; + initialization RegisterTest(TClassTests); diff --git a/docs/design.adoc b/docs/design.adoc index cec4f57..c08b707 100644 --- a/docs/design.adoc +++ b/docs/design.adoc @@ -670,6 +670,31 @@ Phase 1 (bootstrap pipeline) is complete. Phase 2 type-system work is in progres static methods retain direct `call $T_M` dispatch; subtype assignment (`TDerived := TBase`) allowed via parent-chain walk in semantic pass +| `is`/`as` type tests +| Done +| `_IsInstance` RTL helper; typeinfo pointer stored at vtable slot 0; + `is` emits `call $_IsInstance` returning boolean; `as` adds a checked + downcast with `_Raise_InvalidCast` on failure; BlaiseTypeInfo struct in RTL + +| ARC cleanup on exception paths +| Done +| `EmitExcPathArcCleanup` walks in-scope variable declarations and emits + `_StringRelease` + `storel 0` for each string var on the `@fin_exc` path, + before `_Reraise`; slot zeroing prevents double-release in nested handlers + +| Separate method implementations +| Done +| `procedure TFoo.Bar(...)` outside the class definition; parser detects + qualified names (`TypeName.MethodName`) in `ParseMethodDecl`; body optional + for forward-only class declarations; `LinkClassMethodImpls` transfers bodies + to class method declarations before `AnalyseMethodBodies` runs + +| `Free` built-in +| Done +| `Obj.Free` with no user-defined `Free` method emits `call $free(l ptr)`; + semantic pass sets `ResolvedMethod := nil` as signal; codegen handles nil + method as built-in free before normal dispatch path + | macOS ARM64 target | Pending | — @@ -679,11 +704,6 @@ Phase 1 (bootstrap pipeline) is complete. Phase 2 type-system work is in progres . macOS ARM64 target — QBE supports it; compiler driver needs target detection and Darwin-specific link flags. -. `is`/`as` type tests — runtime type identity check and checked downcast, - requires storing type metadata alongside the vtable. -. ARC cleanup on exception paths — release in-scope ARC-managed variables on the - exception path inside try/finally before re-raising (requires scope-chain - tracking in the code generator). == Landscape Notes