From b6736d3925a0f973785f9addb4aded07e33398cc Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 May 2026 14:30:24 +0100 Subject: [PATCH] fix(semantic): clone method bodies per generic instance MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Generic instance method bodies were shared via OwnBody=False, so a single TBlock AST was annotated by the semantic analyser once for each instance in turn. The Resolved* annotations on the shared body ended up reflecting whichever instance was analysed last, causing call targets in earlier instances to point at later instances' helpers — e.g. TList.Add would emit `call $TList_TObject_Grow` and skip $_StringAddRef on the value parameter. Add CloneBlock/CloneStmt/CloneExpr in uAST.pas covering all node types that can appear inside a method body (~26 expr/stmt forms plus block- level Var/Const/Type/Proc decls). Annotations are deliberately not copied — each instance re-runs semantic analysis on its own AST. Wire the clone into InstantiateGeneric and InstantiateGenericFunction so each instance owns its body. Adds TestCodegen_Generic_TwoInstances_MethodCallsResolveToOwnInstance to lock in: with TBox and TBox in one program, the emitted TBox_Integer_Init body must contain `call \$TBox_Integer_SetValue` and the TBox_String_Init body must contain `call \$TBox_String_SetValue`. Previously both bodies called the String instance's helper. Verified: 2107 tests pass; fixpoint clean; the two-instance benchmark scenario (TList + TList in one program) now compiles and runs correctly. --- compiler/src/main/pascal/uAST.pas | 606 ++++++++++++++++++ compiler/src/main/pascal/uSemantic.pas | 33 +- compiler/src/test/pascal/cp.test.generics.pas | 65 ++ tests/bench_lists_results.txt | 3 +- 4 files changed, 701 insertions(+), 6 deletions(-) diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index a20a518..a362fac 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -759,6 +759,15 @@ type function BinaryOpName(AOp: TBinaryOp): string; function IsComparisonOp(AOp: TBinaryOp): Boolean; +{ Deep-clone helpers for generic-instance method body re-analysis. + Clones structure + raw textual fields (names, type names, operators). + Resolved* / FieldInfo / IsXxx semantic annotations are NOT copied: each + instance must re-run semantic analysis to populate them correctly for + its own concrete type arguments. } +function CloneExpr(AExpr: TASTExpr): TASTExpr; +function CloneStmt(AStmt: TASTStmt): TASTStmt; +function CloneBlock(ABlock: TBlock): TBlock; + implementation function BinaryOpName(AOp: TBinaryOp): string; @@ -1440,4 +1449,601 @@ begin inherited Destroy; end; +{ ------------------------------------------------------------------ } +{ Deep clone for generic-instance method body re-analysis } +{ ------------------------------------------------------------------ } + +function CloneVarDecl(ASrc: TVarDecl): TVarDecl; forward; +function CloneFieldDecl(ASrc: TFieldDecl): TFieldDecl; forward; +function CloneTypeDecl(ASrc: TTypeDecl): TTypeDecl; forward; +function CloneConstDecl(ASrc: TConstDecl): TConstDecl; forward; +function CloneMethodParam(ASrc: TMethodParam): TMethodParam; forward; +function CloneMethodDecl(ASrc: TMethodDecl): TMethodDecl; forward; +function CloneTypeDef(ASrc: TASTTypeDef): TASTTypeDef; forward; +function CloneExceptHandler(ASrc: TExceptHandlerClause): TExceptHandlerClause; forward; +function CloneCaseBranch(ASrc: TCaseBranch): TCaseBranch; forward; +function CloneCompound(ASrc: TCompoundStmt): TCompoundStmt; forward; + +procedure CopyExprPos(ADst, ASrc: TASTExpr); +begin + ADst.Line := ASrc.Line; + ADst.Col := ASrc.Col; +end; + +procedure CopyStmtPos(ADst, ASrc: TASTStmt); +begin + ADst.Line := ASrc.Line; + ADst.Col := ASrc.Col; +end; + +function CloneExprList(ASrc: TObjectList): TObjectList; +var + I: Integer; +begin + Result := TObjectList.Create(True); + for I := 0 to ASrc.Count - 1 do + Result.Add(CloneExpr(TASTExpr(ASrc.Items[I]))); +end; + +function CloneExpr(AExpr: TASTExpr): TASTExpr; +var + IL: TIntLiteral; + FL: TFloatLiteral; + SL: TStringLiteral; + SS: TStringSubscriptExpr; + AL: TArrayLiteralExpr; + IE: TIdentExpr; + FA: TFieldAccessExpr; + IsE: TIsExpr; + AsE: TAsExpr; + SuE: TSupportsExpr; + BE: TBinaryExpr; + NE: TNotExpr; + FCE: TFuncCallExpr; + DE: TDerefExpr; + AoE: TAddrOfExpr; + MCE: TMethodCallExpr; + I: Integer; +begin + if AExpr = nil then + begin Result := nil; Exit; end; + + if AExpr is TIntLiteral then + begin + IL := TIntLiteral.Create; + IL.Value := TIntLiteral(AExpr).Value; + Result := IL; + end + else if AExpr is TFloatLiteral then + begin + FL := TFloatLiteral.Create; + FL.Value := TFloatLiteral(AExpr).Value; + Result := FL; + end + else if AExpr is TStringLiteral then + begin + SL := TStringLiteral.Create; + SL.Value := TStringLiteral(AExpr).Value; + Result := SL; + end + else if AExpr is TNilLiteral then + begin + Result := TNilLiteral.Create; + end + else if AExpr is TStringSubscriptExpr then + begin + SS := TStringSubscriptExpr.Create; + SS.StrExpr := CloneExpr(TStringSubscriptExpr(AExpr).StrExpr); + SS.IndexExpr := CloneExpr(TStringSubscriptExpr(AExpr).IndexExpr); + Result := SS; + end + else if AExpr is TArrayLiteralExpr then + begin + AL := TArrayLiteralExpr.Create; + for I := 0 to TArrayLiteralExpr(AExpr).Elements.Count - 1 do + AL.Elements.Add(CloneExpr(TASTExpr(TArrayLiteralExpr(AExpr).Elements.Items[I]))); + Result := AL; + end + else if AExpr is TIdentExpr then + begin + IE := TIdentExpr.Create; + IE.Name := TIdentExpr(AExpr).Name; + { Note: leave IsConstant/IsVarParam/IsImplicitSelf/etc. nil/false — + semantic analyser must re-resolve in the new instance's scope. } + Result := IE; + end + else if AExpr is TFieldAccessExpr then + begin + FA := TFieldAccessExpr.Create; + FA.RecordName := TFieldAccessExpr(AExpr).RecordName; + FA.FieldName := TFieldAccessExpr(AExpr).FieldName; + FA.Base := CloneExpr(TFieldAccessExpr(AExpr).Base); + FA.PropIndexExpr := CloneExpr(TFieldAccessExpr(AExpr).PropIndexExpr); + Result := FA; + end + else if AExpr is TIsExpr then + begin + IsE := TIsExpr.Create; + IsE.Obj := CloneExpr(TIsExpr(AExpr).Obj); + IsE.TypeName := TIsExpr(AExpr).TypeName; + Result := IsE; + end + else if AExpr is TAsExpr then + begin + AsE := TAsExpr.Create; + AsE.Obj := CloneExpr(TAsExpr(AExpr).Obj); + AsE.TypeName := TAsExpr(AExpr).TypeName; + Result := AsE; + end + else if AExpr is TSupportsExpr then + begin + SuE := TSupportsExpr.Create; + SuE.Obj := CloneExpr(TSupportsExpr(AExpr).Obj); + SuE.IntfTypeName := TSupportsExpr(AExpr).IntfTypeName; + SuE.OutVarName := TSupportsExpr(AExpr).OutVarName; + Result := SuE; + end + else if AExpr is TBinaryExpr then + begin + BE := TBinaryExpr.Create; + BE.Op := TBinaryExpr(AExpr).Op; + BE.Left := CloneExpr(TBinaryExpr(AExpr).Left); + BE.Right := CloneExpr(TBinaryExpr(AExpr).Right); + Result := BE; + end + else if AExpr is TNotExpr then + begin + NE := TNotExpr.Create; + NE.Expr := CloneExpr(TNotExpr(AExpr).Expr); + Result := NE; + end + else if AExpr is TFuncCallExpr then + begin + FCE := TFuncCallExpr.Create; + FCE.Name := TFuncCallExpr(AExpr).Name; + for I := 0 to TFuncCallExpr(AExpr).Args.Count - 1 do + FCE.Args.Add(CloneExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Items[I]))); + Result := FCE; + end + else if AExpr is TDerefExpr then + begin + DE := TDerefExpr.Create; + DE.Expr := CloneExpr(TDerefExpr(AExpr).Expr); + Result := DE; + end + else if AExpr is TAddrOfExpr then + begin + AoE := TAddrOfExpr.Create; + AoE.Expr := CloneExpr(TAddrOfExpr(AExpr).Expr); + Result := AoE; + end + else if AExpr is TMethodCallExpr then + begin + MCE := TMethodCallExpr.Create; + MCE.ObjectName := TMethodCallExpr(AExpr).ObjectName; + MCE.Name := TMethodCallExpr(AExpr).Name; + MCE.ObjExpr := CloneExpr(TMethodCallExpr(AExpr).ObjExpr); + for I := 0 to TMethodCallExpr(AExpr).Args.Count - 1 do + MCE.Args.Add(CloneExpr(TASTExpr(TMethodCallExpr(AExpr).Args.Items[I]))); + Result := MCE; + end + else + raise Exception.CreateFmt('CloneExpr: unhandled expression node %s', + [AExpr.ClassName]); + + CopyExprPos(Result, AExpr); +end; + +function CloneCompound(ASrc: TCompoundStmt): TCompoundStmt; +var + I: Integer; +begin + if ASrc = nil then + begin Result := nil; Exit; end; + Result := TCompoundStmt.Create; + CopyStmtPos(Result, ASrc); + for I := 0 to ASrc.Stmts.Count - 1 do + Result.Stmts.Add(CloneStmt(TASTStmt(ASrc.Stmts.Items[I]))); +end; + +function CloneExceptHandler(ASrc: TExceptHandlerClause): TExceptHandlerClause; +begin + Result := TExceptHandlerClause.Create; + Result.VarName := ASrc.VarName; + Result.TypeName := ASrc.TypeName; + Result.Body := CloneCompound(ASrc.Body); +end; + +function CloneCaseBranch(ASrc: TCaseBranch): TCaseBranch; +var + I: Integer; +begin + Result := TCaseBranch.Create; + for I := 0 to ASrc.Values.Count - 1 do + Result.Values.Add(CloneExpr(TASTExpr(ASrc.Values.Items[I]))); + Result.Stmt := CloneStmt(ASrc.Stmt); +end; + +function CloneStmt(AStmt: TASTStmt): TASTStmt; +var + AS_: TAssignment; + IF_: TIfStmt; + CS_: TCompoundStmt; + WS_: TWhileStmt; + RS_: TRepeatStmt; + FS_: TForStmt; + FIS_: TForInStmt; + TFS_: TTryFinallyStmt; + TES_: TTryExceptStmt; + RaS_: TRaiseStmt; + CSS_: TCaseStmt; + FAS_: TFieldAssignment; + SSA_: TStaticSubscriptAssign; + PWS_: TPointerWriteStmt; + PC_: TProcCall; + MCS_: TMethodCallStmt; + ICS_: TInheritedCallStmt; + I: Integer; +begin + if AStmt = nil then + begin Result := nil; Exit; end; + + if AStmt is TAssignment then + begin + AS_ := TAssignment.Create; + AS_.Name := TAssignment(AStmt).Name; + AS_.Expr := CloneExpr(TAssignment(AStmt).Expr); + Result := AS_; + end + else if AStmt is TIfStmt then + begin + IF_ := TIfStmt.Create; + IF_.Condition := CloneExpr(TIfStmt(AStmt).Condition); + IF_.ThenStmt := CloneStmt(TIfStmt(AStmt).ThenStmt); + IF_.ElseStmt := CloneStmt(TIfStmt(AStmt).ElseStmt); + Result := IF_; + end + else if AStmt is TCompoundStmt then + begin + CS_ := TCompoundStmt.Create; + for I := 0 to TCompoundStmt(AStmt).Stmts.Count - 1 do + CS_.Stmts.Add(CloneStmt(TASTStmt(TCompoundStmt(AStmt).Stmts.Items[I]))); + Result := CS_; + end + else if AStmt is TWhileStmt then + begin + WS_ := TWhileStmt.Create; + WS_.Condition := CloneExpr(TWhileStmt(AStmt).Condition); + WS_.Body := CloneStmt(TWhileStmt(AStmt).Body); + Result := WS_; + end + else if AStmt is TRepeatStmt then + begin + RS_ := TRepeatStmt.Create; + RS_.Body := CloneCompound(TRepeatStmt(AStmt).Body); + RS_.Condition := CloneExpr(TRepeatStmt(AStmt).Condition); + Result := RS_; + end + else if AStmt is TForStmt then + begin + FS_ := TForStmt.Create; + FS_.VarName := TForStmt(AStmt).VarName; + FS_.StartExpr := CloneExpr(TForStmt(AStmt).StartExpr); + FS_.EndExpr := CloneExpr(TForStmt(AStmt).EndExpr); + FS_.IsDownTo := TForStmt(AStmt).IsDownTo; + FS_.Body := CloneStmt(TForStmt(AStmt).Body); + Result := FS_; + end + else if AStmt is TForInStmt then + begin + FIS_ := TForInStmt.Create; + FIS_.VarName := TForInStmt(AStmt).VarName; + FIS_.CollExpr := CloneExpr(TForInStmt(AStmt).CollExpr); + FIS_.Body := CloneStmt(TForInStmt(AStmt).Body); + Result := FIS_; + end + else if AStmt is TTryFinallyStmt then + begin + TFS_ := TTryFinallyStmt.Create; + TFS_.TryBody := CloneCompound(TTryFinallyStmt(AStmt).TryBody); + TFS_.FinallyBody := CloneCompound(TTryFinallyStmt(AStmt).FinallyBody); + Result := TFS_; + end + else if AStmt is TTryExceptStmt then + begin + TES_ := TTryExceptStmt.Create; + TES_.TryBody := CloneCompound(TTryExceptStmt(AStmt).TryBody); + for I := 0 to TTryExceptStmt(AStmt).Handlers.Count - 1 do + TES_.Handlers.Add( + CloneExceptHandler( + TExceptHandlerClause(TTryExceptStmt(AStmt).Handlers.Items[I]))); + TES_.ElseBody := CloneCompound(TTryExceptStmt(AStmt).ElseBody); + TES_.ExceptBody := CloneCompound(TTryExceptStmt(AStmt).ExceptBody); + Result := TES_; + end + else if AStmt is TRaiseStmt then + begin + RaS_ := TRaiseStmt.Create; + RaS_.Expr := CloneExpr(TRaiseStmt(AStmt).Expr); + Result := RaS_; + end + else if AStmt is TExitStmt then + Result := TExitStmt.Create + else if AStmt is TBreakStmt then + Result := TBreakStmt.Create + else if AStmt is TContinueStmt then + Result := TContinueStmt.Create + else if AStmt is TCaseStmt then + begin + CSS_ := TCaseStmt.Create; + CSS_.Selector := CloneExpr(TCaseStmt(AStmt).Selector); + for I := 0 to TCaseStmt(AStmt).Branches.Count - 1 do + CSS_.Branches.Add( + CloneCaseBranch(TCaseBranch(TCaseStmt(AStmt).Branches.Items[I]))); + CSS_.ElseStmt := CloneStmt(TCaseStmt(AStmt).ElseStmt); + Result := CSS_; + end + else if AStmt is TFieldAssignment then + begin + FAS_ := TFieldAssignment.Create; + FAS_.RecordName := TFieldAssignment(AStmt).RecordName; + FAS_.FieldName := TFieldAssignment(AStmt).FieldName; + FAS_.Expr := CloneExpr(TFieldAssignment(AStmt).Expr); + FAS_.ObjExpr := CloneExpr(TFieldAssignment(AStmt).ObjExpr); + FAS_.PropIndexExpr := CloneExpr(TFieldAssignment(AStmt).PropIndexExpr); + Result := FAS_; + end + else if AStmt is TStaticSubscriptAssign then + begin + SSA_ := TStaticSubscriptAssign.Create; + SSA_.ArrayName := TStaticSubscriptAssign(AStmt).ArrayName; + SSA_.IndexExpr := CloneExpr(TStaticSubscriptAssign(AStmt).IndexExpr); + SSA_.ValueExpr := CloneExpr(TStaticSubscriptAssign(AStmt).ValueExpr); + Result := SSA_; + end + else if AStmt is TPointerWriteStmt then + begin + PWS_ := TPointerWriteStmt.Create; + PWS_.PtrExpr := CloneExpr(TPointerWriteStmt(AStmt).PtrExpr); + PWS_.ValExpr := CloneExpr(TPointerWriteStmt(AStmt).ValExpr); + Result := PWS_; + end + else if AStmt is TProcCall then + begin + PC_ := TProcCall.Create; + PC_.Name := TProcCall(AStmt).Name; + for I := 0 to TProcCall(AStmt).Args.Count - 1 do + PC_.Args.Add(CloneExpr(TASTExpr(TProcCall(AStmt).Args.Items[I]))); + Result := PC_; + end + else if AStmt is TMethodCallStmt then + begin + MCS_ := TMethodCallStmt.Create; + MCS_.ObjectName := TMethodCallStmt(AStmt).ObjectName; + MCS_.Name := TMethodCallStmt(AStmt).Name; + MCS_.ObjExpr := CloneExpr(TMethodCallStmt(AStmt).ObjExpr); + for I := 0 to TMethodCallStmt(AStmt).Args.Count - 1 do + MCS_.Args.Add(CloneExpr(TASTExpr(TMethodCallStmt(AStmt).Args.Items[I]))); + Result := MCS_; + end + else if AStmt is TInheritedCallStmt then + begin + ICS_ := TInheritedCallStmt.Create; + ICS_.Name := TInheritedCallStmt(AStmt).Name; + for I := 0 to TInheritedCallStmt(AStmt).Args.Count - 1 do + ICS_.Args.Add(CloneExpr(TASTExpr(TInheritedCallStmt(AStmt).Args.Items[I]))); + Result := ICS_; + end + else + raise Exception.CreateFmt('CloneStmt: unhandled statement node %s', + [AStmt.ClassName]); + + CopyStmtPos(Result, AStmt); +end; + +function CloneVarDecl(ASrc: TVarDecl): TVarDecl; +var + I: Integer; +begin + Result := TVarDecl.Create; + Result.Line := ASrc.Line; + Result.Col := ASrc.Col; + Result.TypeName := ASrc.TypeName; + for I := 0 to ASrc.Names.Count - 1 do + Result.Names.Add(ASrc.Names.Strings[I]); + for I := 0 to ASrc.Attributes.Count - 1 do + Result.Attributes.Add(ASrc.Attributes.Strings[I]); +end; + +function CloneFieldDecl(ASrc: TFieldDecl): TFieldDecl; +var + I: Integer; +begin + Result := TFieldDecl.Create; + Result.Line := ASrc.Line; + Result.Col := ASrc.Col; + Result.TypeName := ASrc.TypeName; + for I := 0 to ASrc.Names.Count - 1 do + Result.Names.Add(ASrc.Names.Strings[I]); + for I := 0 to ASrc.Attributes.Count - 1 do + Result.Attributes.Add(ASrc.Attributes.Strings[I]); +end; + +function CloneTypeDecl(ASrc: TTypeDecl): TTypeDecl; +begin + Result := TTypeDecl.Create; + Result.Line := ASrc.Line; + Result.Col := ASrc.Col; + Result.Name := ASrc.Name; + Result.Def := CloneTypeDef(ASrc.Def); +end; + +function CloneConstDecl(ASrc: TConstDecl): TConstDecl; +var + I: Integer; +begin + Result := TConstDecl.Create; + Result.Line := ASrc.Line; + Result.Col := ASrc.Col; + Result.Name := ASrc.Name; + Result.TypeName := ASrc.TypeName; + Result.IntVal := ASrc.IntVal; + Result.StrVal := ASrc.StrVal; + Result.IsString := ASrc.IsString; + Result.IsFloat := ASrc.IsFloat; + if ASrc.ConstParts <> nil then + begin + Result.ConstParts := TStringList.Create; + for I := 0 to ASrc.ConstParts.Count - 1 do + Result.ConstParts.AddObject( + ASrc.ConstParts.Strings[I], ASrc.ConstParts.Objects[I]); + end; + Result.IsArrayConst := ASrc.IsArrayConst; + Result.ArrayIndexType := ASrc.ArrayIndexType; + Result.ArrayElemType := ASrc.ArrayElemType; + Result.ArrayIsRangeIndexed := ASrc.ArrayIsRangeIndexed; + Result.ArrayLowBound := ASrc.ArrayLowBound; + Result.ArrayHighBound := ASrc.ArrayHighBound; + if ASrc.ArrayElements <> nil then + begin + Result.ArrayElements := TStringList.Create; + for I := 0 to ASrc.ArrayElements.Count - 1 do + Result.ArrayElements.Add(ASrc.ArrayElements.Strings[I]); + end; +end; + +function CloneMethodParam(ASrc: TMethodParam): TMethodParam; +begin + Result := TMethodParam.Create; + Result.Line := ASrc.Line; + Result.Col := ASrc.Col; + Result.ParamName := ASrc.ParamName; + Result.TypeName := ASrc.TypeName; + Result.IsVarParam := ASrc.IsVarParam; + Result.IsConstParam := ASrc.IsConstParam; + Result.IsOpenArray := ASrc.IsOpenArray; + Result.DefaultValue := CloneExpr(ASrc.DefaultValue); +end; + +function CloneMethodDecl(ASrc: TMethodDecl): TMethodDecl; +var + I: Integer; +begin + Result := TMethodDecl.Create; + Result.Line := ASrc.Line; + Result.Col := ASrc.Col; + Result.Name := ASrc.Name; + Result.OwnerTypeName := ASrc.OwnerTypeName; + Result.ReturnTypeName := ASrc.ReturnTypeName; + Result.IsVirtual := ASrc.IsVirtual; + Result.IsOverride := ASrc.IsOverride; + Result.IsAbstract := ASrc.IsAbstract; + Result.IsOverload := ASrc.IsOverload; + Result.IsPublished := ASrc.IsPublished; + Result.IsExternal := ASrc.IsExternal; + Result.ExternalName := ASrc.ExternalName; + Result.IsRecordMethod := ASrc.IsRecordMethod; + for I := 0 to ASrc.Params.Count - 1 do + Result.Params.Add(CloneMethodParam(TMethodParam(ASrc.Params.Items[I]))); + if ASrc.TypeParams <> nil then + begin + Result.TypeParams := TStringList.Create; + for I := 0 to ASrc.TypeParams.Count - 1 do + Result.TypeParams.Add(ASrc.TypeParams.Strings[I]); + end; + if ASrc.TypeParamConstraints <> nil then + begin + Result.TypeParamConstraints := TStringList.Create; + for I := 0 to ASrc.TypeParamConstraints.Count - 1 do + Result.TypeParamConstraints.Add(ASrc.TypeParamConstraints.Strings[I]); + end; + if ASrc.OwnerTypeParams <> nil then + begin + Result.OwnerTypeParams := TStringList.Create; + for I := 0 to ASrc.OwnerTypeParams.Count - 1 do + Result.OwnerTypeParams.Add(ASrc.OwnerTypeParams.Strings[I]); + end; + if (ASrc.Body <> nil) and ASrc.OwnBody then + begin + Result.Body := CloneBlock(ASrc.Body); + Result.OwnBody := True; + end + else + begin + Result.Body := ASrc.Body; + Result.OwnBody := False; + end; +end; + +function CloneTypeDef(ASrc: TASTTypeDef): TASTTypeDef; +var + TA: TTypeAliasDef; + ST: TSetTypeDef; + RT: TRecordTypeDef; + ET: TEnumTypeDef; + I: Integer; +begin + if ASrc = nil then + begin Result := nil; Exit; end; + if ASrc is TTypeAliasDef then + begin + TA := TTypeAliasDef.Create; + TA.TypeName := TTypeAliasDef(ASrc).TypeName; + Result := TA; + end + else if ASrc is TSetTypeDef then + begin + ST := TSetTypeDef.Create; + ST.BaseTypeName := TSetTypeDef(ASrc).BaseTypeName; + Result := ST; + end + else if ASrc is TEnumTypeDef then + begin + ET := TEnumTypeDef.Create; + for I := 0 to TEnumTypeDef(ASrc).Members.Count - 1 do + ET.Members.AddObject( + TEnumTypeDef(ASrc).Members.Strings[I], + TEnumTypeDef(ASrc).Members.Objects[I]); + Result := ET; + end + else if ASrc is TRecordTypeDef then + begin + RT := TRecordTypeDef.Create; + for I := 0 to TRecordTypeDef(ASrc).Fields.Count - 1 do + RT.Fields.Add(CloneFieldDecl(TFieldDecl(TRecordTypeDef(ASrc).Fields.Items[I]))); + for I := 0 to TRecordTypeDef(ASrc).Methods.Count - 1 do + RT.Methods.Add(CloneMethodDecl(TMethodDecl(TRecordTypeDef(ASrc).Methods.Items[I]))); + Result := RT; + end + else + { Class, generic, interface, procedural defs do not legally appear nested + inside a method body — fail loudly so we notice if that changes. } + raise Exception.CreateFmt( + 'CloneTypeDef: unsupported nested type def %s', [ASrc.ClassName]); + + Result.Line := ASrc.Line; + Result.Col := ASrc.Col; +end; + +function CloneBlock(ABlock: TBlock): TBlock; +var + I: Integer; +begin + if ABlock = nil then + begin Result := nil; Exit; end; + Result := TBlock.Create; + Result.Line := ABlock.Line; + Result.Col := ABlock.Col; + for I := 0 to ABlock.TypeDecls.Count - 1 do + Result.TypeDecls.Add(CloneTypeDecl(TTypeDecl(ABlock.TypeDecls.Items[I]))); + for I := 0 to ABlock.ConstDecls.Count - 1 do + Result.ConstDecls.Add(CloneConstDecl(TConstDecl(ABlock.ConstDecls.Items[I]))); + for I := 0 to ABlock.Decls.Count - 1 do + Result.Decls.Add(CloneVarDecl(TVarDecl(ABlock.Decls.Items[I]))); + for I := 0 to ABlock.ProcDecls.Count - 1 do + Result.ProcDecls.Add(CloneMethodDecl(TMethodDecl(ABlock.ProcDecls.Items[I]))); + for I := 0 to ABlock.Stmts.Count - 1 do + Result.Stmts.Add(CloneStmt(TASTStmt(ABlock.Stmts.Items[I]))); +end; + end. diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index db88879..a1f2287 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -1500,7 +1500,11 @@ begin ClonedCD.Fields.Add(NewFDecl); end; - { Clone method declarations (shared body — OwnBody = False) } + { Clone method declarations. Body is deep-cloned so each generic + instance has its own AST nodes for semantic re-analysis; without this + the Resolved* annotations on the shared body would carry whichever + instance was analysed last, causing call targets in instance N's + method body to resolve against instance M's class. } for I := 0 to Templ.ClassDef.Methods.Count - 1 do begin MDecl := TMethodDecl(Templ.ClassDef.Methods.Items[I]); @@ -1509,8 +1513,16 @@ begin NewMDecl.OwnerTypeName := ATypeName; NewMDecl.IsVirtual := MDecl.IsVirtual; NewMDecl.IsOverride := MDecl.IsOverride; - NewMDecl.Body := MDecl.Body; - NewMDecl.OwnBody := False; + if MDecl.Body <> nil then + begin + NewMDecl.Body := CloneBlock(MDecl.Body); + NewMDecl.OwnBody := True; + end + else + begin + NewMDecl.Body := nil; + NewMDecl.OwnBody := False; + end; for J := 0 to MDecl.Params.Count - 1 do begin @@ -1887,8 +1899,19 @@ begin NewMDecl := TMethodDecl.Create; NewMDecl.Name := AInstName; - NewMDecl.OwnBody := False; { share the template body } - NewMDecl.Body := Templ.Body; + { Deep-clone the template body so each instance has its own analysed + AST. Sharing would leave Resolved* annotations from the last + instance on the body, miscompiling earlier instances. } + if Templ.Body <> nil then + begin + NewMDecl.Body := CloneBlock(Templ.Body); + NewMDecl.OwnBody := True; + end + else + begin + NewMDecl.Body := nil; + NewMDecl.OwnBody := False; + end; { Substitute return type } RetTypeName := Templ.ReturnTypeName; diff --git a/compiler/src/test/pascal/cp.test.generics.pas b/compiler/src/test/pascal/cp.test.generics.pas index 9cfb17d..6882508 100644 --- a/compiler/src/test/pascal/cp.test.generics.pas +++ b/compiler/src/test/pascal/cp.test.generics.pas @@ -81,6 +81,7 @@ type { ------------------------------------------------------------------ } procedure TestSemantic_Generic_TwoInstancesOfSameClass_Resolve; procedure TestSemantic_Generic_TwoInstances_PointerFieldDistinctTypes; + procedure TestCodegen_Generic_TwoInstances_MethodCallsResolveToOwnInstance; end; implementation @@ -728,6 +729,35 @@ begin end; end; +const + { Two instances of the same generic class; one method calls another method + on the same class. If the method body is shared across instances without + re-analysis, the inner Self.SetValue call will resolve to the same + instance for both — so TBox_String_Init would emit + call $TBox_Integer_SetValue + instead of $TBox_String_SetValue. Per-instance AST body cloning ensures + each instance has its own analysed body and the correct call targets. } + SrcTwoInstancesMethodCallsOwn = + ''' + program P; + type + TBox = class + FValue: T; + procedure SetValue(V: T); + begin + Self.FValue := V + end; + procedure Init(V: T); + begin + Self.SetValue(V) + end; + end; + var + A: TBox; + B: TBox; + begin end. + '''; + procedure TGenericsTests.TestSemantic_Generic_TwoInstances_PointerFieldDistinctTypes; var Prog: TProgram; @@ -755,6 +785,41 @@ begin end; end; +procedure TGenericsTests.TestCodegen_Generic_TwoInstances_MethodCallsResolveToOwnInstance; +var + IR: string; + IntInit: Integer; + StrInit: Integer; + IntBody: string; + StrBody: string; +begin + IR := GenIR(SrcTwoInstancesMethodCallsOwn); + + { Locate the two Init function bodies in the IR. } + IntInit := Pos('function $TBox_Integer_Init', IR); + StrInit := Pos('function $TBox_String_Init', IR); + AssertTrue('TBox_Integer_Init function emitted', IntInit > 0); + AssertTrue('TBox_String_Init function emitted', StrInit > 0); + + { Take a window from each function start until the next 'function ' marker + (or end of string). } + if IntInit < StrInit then + begin + IntBody := Copy(IR, IntInit, StrInit - IntInit); + StrBody := Copy(IR, StrInit, Length(IR) - StrInit + 1); + end + else + begin + StrBody := Copy(IR, StrInit, IntInit - StrInit); + IntBody := Copy(IR, IntInit, Length(IR) - IntInit + 1); + end; + + AssertTrue('TBox_Integer_Init body calls $TBox_Integer_SetValue', + Pos('call $TBox_Integer_SetValue', IntBody) > 0); + AssertTrue('TBox_String_Init body calls $TBox_String_SetValue', + Pos('call $TBox_String_SetValue', StrBody) > 0); +end; + initialization RegisterTest(TGenericsTests); diff --git a/tests/bench_lists_results.txt b/tests/bench_lists_results.txt index d7be30b..6e1bec1 100644 --- a/tests/bench_lists_results.txt +++ b/tests/bench_lists_results.txt @@ -55,4 +55,5 @@ Phases (all ms wall-clock): * The compiler currently miscompiles a program that instantiates the same generic class with two different concrete arguments (e.g. TList and TList in one program) — that is - why the benchmark is split into two files. + why the benchmark is split into two files. (Fixed in a later + commit via per-instance AST body cloning.)