fix(codegen): capture the dynamic override when taking @Obj.VirtualMethod

Taking the address of a virtual method through a receiver
(`M := @Obj.Method`) stored the statically-resolved declared-type
method address as the Code half of the (Code, Data) method pointer.
A later call through M therefore always ran the declared type's method,
ignoring the receiver's dynamic override — unlike a direct `Obj.Method()`
call, which dispatches through the vtable.

Resolve the Code half through the instance's vtable when the method is
virtual/override (VTableSlot >= 0): load the vptr from the object,
index slot (VTableSlot + 1)*8 (slot 0 is typeinfo), and store the
resulting code pointer. Non-virtual methods keep the static label.

Both the QBE and x86-64 backends had the same defect; the native side
fixes it at both the variable- and field-destination assignment sites.

Additionally fixes a pre-existing native-backend bug this change exposed:
EmitClassSection re-asserts FSymTable.DefineOwningUnit to the unit being
emitted before every FindType.  Resolving an earlier class in the loop
(its parent/field/method types via ClassSymName -> Lookup -> the
uses-chain walk) could leave DefineOwningUnit pointing at a dependency
unit; FindType for one of this unit's own implementation-section
(IsImplPrivate) classes was then suppressed by Lookup's cross-unit-leak
guard and returned nil, so the class was skipped and its typeinfo /
vtable / _FieldCleanup were never emitted.  The dangling
`typeinfo_<Unit>_<Class>` reference (e.g. a metaclass value passed to
RegisterTest from the init block) then bound to a garbage address,
producing a layout-sensitive out-of-range-metaclass crash at runtime.

Tests: an IR-level assertion that the capture no longer stores the
static method label, plus two e2e cases (variable and field
destination) asserting the override runs on every backend.

compiler/src/main/pascal/blaise.codegen.native.x86_64.pas

@@ -2107,6 +2107,18 @@ begin
   begin
     TD := TTypeDecl(ATypeDecls.Items[I]);
     if not (TD.Def is TClassTypeDef) then Continue;
+    { Re-assert the viewing context before EVERY FindType.  Resolving a prior
+      class in this loop (its parent/field/method types via ClassSymName ->
+      Lookup -> the uses-chain walk) can leave FSymTable.DefineOwningUnit
+      pointing at a dependency unit.  If it has drifted, FindType for one of THIS
+      unit's own implementation-section (IsImplPrivate) classes is suppressed by
+      Lookup's cross-unit-leak guard and returns nil — so the class is skipped
+      and its typeinfo / vtable / _FieldCleanup are NEVER emitted, leaving a
+      dangling reference the linker binds to garbage (an out-of-range metaclass
+      crash, e.g. via RegisterTest).  Pin DOU to the unit being emitted so an
+      owned impl-private class always resolves. }
+    if (ASymTable <> nil) and (FCurrentUnitName <> '') then
+      ASymTable.DefineOwningUnit := FCurrentUnitName;
     TDesc := ASymTable.FindType(TD.Name);
     if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
     RT := TRecordTypeDesc(TDesc);
@@ -11126,11 +11138,8 @@ begin
         Self.Emit(Format(#9'leaq %s, %%rcx', [Self.VarOperand(Asgn.Name)]))
       else
         Self.Emit(Format(#9'leaq %s(%%rip), %%rcx', [Asgn.Name]));
-      { Store code pointer at offset 0 }
-      Self.Emit(Format(#9'leaq %s(%%rip), %%rax',
-        [MethodEmitNameNative(MD, MD.OwnerTypeName, FAE.FieldName)]));
-      Self.Emit(#9'movq %rax, (%rcx)');
-      { Store object pointer at offset 8 }
+      { Store object pointer at offset 8 first — a virtual method reads its
+        code pointer from THIS instance's vtable. }
       if FAE.Base <> nil then
       begin
         Self.Emit(#9'pushq %rcx');
@@ -11143,6 +11152,21 @@ begin
         Self.EmitVarBaseToReg(FAE.RecordName, False, '%rax');
         Self.Emit(#9'movq %rax, 8(%rcx)');
       end;
+      { Store code pointer at offset 0.  A virtual/override method must be
+        resolved through the instance's vtable so @Obj.M captures the dynamic
+        type's override — matching a direct Obj.M() call — instead of freezing
+        the static address.  Slot 0 of the vtable is typeinfo, so method N is
+        at offset (N+1)*8 (mirrors the dispatch in the call path). }
+      if MD.VTableSlot >= 0 then
+      begin
+        Self.Emit(#9'movq 8(%rcx), %rax');     { obj  = data slot }
+        Self.Emit(#9'movq (%rax), %rax');      { vptr = obj[0] }
+        Self.Emit(Format(#9'movq %d(%%rax), %%rax', [(MD.VTableSlot + 1) * 8]));
+      end
+      else
+        Self.Emit(Format(#9'leaq %s(%%rip), %%rax',
+          [MethodEmitNameNative(MD, MD.OwnerTypeName, FAE.FieldName)]));
+      Self.Emit(#9'movq %rax, (%rcx)');
       Exit;
     end;
     { Method-pointer (of-object) assignment from a TMethod/TAddProc cast:
@@ -12476,11 +12500,8 @@ begin
       else Self.EmitVarBaseToReg(FA.RecordName, True, '%rcx');
       if FA.FieldInfo.Offset > 0 then
         Self.Emit(Format(#9'addq $%d, %%rcx', [FA.FieldInfo.Offset]));
-      { Store the code pointer at offset 0. }
-      Self.Emit(Format(#9'leaq %s(%%rip), %%rax',
-        [MethodEmitNameNative(MD, MD.OwnerTypeName, FAE.FieldName)]));
-      Self.Emit(#9'movq %rax, (%rcx)');
-      { Store the captured object pointer at offset 8. }
+      { Store the captured object pointer at offset 8 first — a virtual method
+        reads its code pointer from THIS instance's vtable. }
       if FAE.Base <> nil then
       begin
         Self.Emit(#9'pushq %rcx');
@@ -12493,6 +12514,21 @@ begin
         Self.EmitVarBaseToReg(FAE.RecordName, False, '%rax');
         Self.Emit(#9'movq %rax, 8(%rcx)');
       end;
+      { Store the code pointer at offset 0.  A virtual/override method must be
+        resolved through the instance's vtable so @Obj.M captures the dynamic
+        type's override — matching a direct Obj.M() call — instead of freezing
+        the static address.  Slot 0 of the vtable is typeinfo, so method N is
+        at offset (N+1)*8. }
+      if MD.VTableSlot >= 0 then
+      begin
+        Self.Emit(#9'movq 8(%rcx), %rax');     { obj  = data slot }
+        Self.Emit(#9'movq (%rax), %rax');      { vptr = obj[0] }
+        Self.Emit(Format(#9'movq %d(%%rax), %%rax', [(MD.VTableSlot + 1) * 8]));
+      end
+      else
+        Self.Emit(Format(#9'leaq %s(%%rip), %%rax',
+          [MethodEmitNameNative(MD, MD.OwnerTypeName, FAE.FieldName)]));
+      Self.Emit(#9'movq %rax, (%rcx)');
       Exit;
     end;
     { Field := MethodCall() where the method returns a record via sret.

compiler/src/main/pascal/blaise.codegen.qbe.pas

@@ -15062,6 +15062,9 @@ var
   Adj:     string;
   Offset:  string;
   ElemPtr: string;
+  VTblTemp: string;
+  SlotPtr:  string;
+  FPtrTemp: string;
 begin
   if AExpr.Expr is TStringSubscriptExpr then
   begin
@@ -15230,7 +15233,8 @@ begin
   { @Obj.MethodName — method-pointer construction.  The semantic pass set
     IsMethodPtr on the TFieldAccessExpr's ResolvedType when it detected this
     pattern.  Allocate a 16-byte block [code_ptr, data_ptr] on the stack,
-    store the static method address and the object pointer, return the block. }
+    store the code pointer (vtable-resolved for a virtual/override method,
+    the static label otherwise) and the object pointer, return the block. }
   if (AExpr.Expr is TFieldAccessExpr) and
      (TFieldAccessExpr(AExpr.Expr).ResolvedType <> nil) and
      (TFieldAccessExpr(AExpr.Expr).ResolvedType.Kind = tyProcedural) and
@@ -15242,10 +15246,8 @@ begin
     EmitLine(Format('  %s =l alloc8 16', [MBlock]));
     DataSlot := AllocTemp();
     EmitLine(Format('  %s =l add %s, 8', [DataSlot, MBlock]));
-    { Store code pointer at offset 0 }
-    EmitLine(Format('  storel $%s, %s',
-      [MethodEmitName(MD, MD.OwnerTypeName, FldExpr.FieldName), MBlock]));
-    { Load and store the object pointer at offset 8.
+    { Compute the object (data) pointer first — a virtual method reads its
+      code pointer from THIS instance's vtable.
       Simple form: @VarName.Method — FldExpr.Base is nil; load via RecordName.
       Chained form: @Expr.Method — FldExpr.Base is set; use EmitInstancePtr. }
     if FldExpr.Base <> nil then
@@ -15255,6 +15257,26 @@ begin
       ObjPtr := AllocTemp();
       EmitLine(Format('  %s =l loadl %s', [ObjPtr, VarRef(FldExpr.RecordName, FldExpr.IsGlobal)]));
     end;
+    { Store the code pointer at offset 0.  A virtual/override method must be
+      resolved through the instance's vtable so @Obj.M captures the dynamic
+      type's override — matching a direct Obj.M() call — instead of freezing
+      the static address of the declared type.  Slot 0 of the vtable is
+      typeinfo, so method N is at offset (N+1)*8 (mirrors EmitMethodCall). }
+    if MD.VTableSlot >= 0 then
+    begin
+      VTblTemp := AllocTemp();
+      EmitLine(Format('  %s =l loadl %s', [VTblTemp, ObjPtr]));
+      SlotPtr  := AllocTemp();
+      EmitLine(Format('  %s =l add %s, %d',
+        [SlotPtr, VTblTemp, (MD.VTableSlot + 1) * 8]));
+      FPtrTemp := AllocTemp();
+      EmitLine(Format('  %s =l loadl %s', [FPtrTemp, SlotPtr]));
+      EmitLine(Format('  storel %s, %s', [FPtrTemp, MBlock]));
+    end
+    else
+      EmitLine(Format('  storel $%s, %s',
+        [MethodEmitName(MD, MD.OwnerTypeName, FldExpr.FieldName), MBlock]));
+    { Store the object pointer at offset 8. }
     EmitLine(Format('  storel %s, %s', [ObjPtr, DataSlot]));
     Exit(MBlock);
   end;

compiler/src/test/pascal/cp.test.e2e.misc.pas

@@ -50,6 +50,10 @@ type
     { Method-pointer (of object) field: assign @Obj.Method into a field, then
       dispatch through it — exercises the 16-byte (Code, Data) field store. }
     procedure TestRun_MethodPtrField_AssignAndCall;
+    { Capturing @Obj.VirtualMethod must bind the receiver's dynamic override,
+      not the statically-resolved declared-type method. }
+    procedure TestRun_MethodPtrVirtualCapture_Var;
+    procedure TestRun_MethodPtrVirtualCapture_Field;
     { Unqualified call to a procedural-typed field via implicit Self (FFn(...)
       with no 'Self.' prefix), as an expression and as a statement. }
     procedure TestRun_ImplicitSelfProcField_Expr;
@@ -473,6 +477,63 @@ const
     end.
     ''';
 
+  { Method-pointer capture of a VIRTUAL method through a base-typed variable:
+    A is declared TAnimal but holds a TDog, so @A.Speak must capture TDog's
+    override (print 'dog'), resolving the Code half through A's vtable rather
+    than freezing the declared type's TAnimal.Speak. }
+  SrcMethodPtrVirtualCaptureVar = '''
+    program Prg;
+    type
+      TSpeak = procedure of object;
+      TAnimal = class
+        procedure Speak; virtual;
+      end;
+      TDog = class(TAnimal)
+        procedure Speak; override;
+      end;
+    procedure TAnimal.Speak;
+    begin WriteLn('animal') end;
+    procedure TDog.Speak;
+    begin WriteLn('dog') end;
+    var A: TAnimal; M: TSpeak;
+    begin
+      A := TDog.Create();
+      M := @A.Speak;
+      M();
+      A.Free()
+    end.
+    ''';
+
+  { Same dynamic-dispatch capture, but stored into a class FIELD rather than a
+    local variable — exercises the field-destination assignment path. }
+  SrcMethodPtrVirtualCaptureField = '''
+    program Prg;
+    type
+      TSpeak = procedure of object;
+      TAnimal = class
+        procedure Speak; virtual;
+      end;
+      TDog = class(TAnimal)
+        procedure Speak; override;
+      end;
+      TBox = class
+        M: TSpeak;
+      end;
+    procedure TAnimal.Speak;
+    begin WriteLn('animal') end;
+    procedure TDog.Speak;
+    begin WriteLn('dog') end;
+    var A: TAnimal; B: TBox;
+    begin
+      A := TDog.Create();
+      B := TBox.Create();
+      B.M := @A.Speak;
+      B.M();
+      B.Free();
+      A.Free()
+    end.
+    ''';
+
   { Unqualified (implicit-Self) call to a procedural-typed field, as an
     expression — FFn(...) with no 'Self.' prefix. }
   SrcImplicitProcFieldExpr = '''
@@ -866,6 +927,18 @@ begin
   AssertRunsOnAll(SrcMethodPtrField, 'T:hello' + LE, 0);
 end;
 
+procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Var;
+begin
+  if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
+  AssertRunsOnAll(SrcMethodPtrVirtualCaptureVar, 'dog' + LE, 0);
+end;
+
+procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Field;
+begin
+  if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
+  AssertRunsOnAll(SrcMethodPtrVirtualCaptureField, 'dog' + LE, 0);
+end;
+
 procedure TE2EMiscTests.TestRun_ImplicitSelfProcField_Expr;
 begin
   if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;

compiler/src/test/pascal/cp.test.proctypes_ofobject.pas

@@ -55,6 +55,7 @@ type
     procedure TestCodegen_MethodPtrField_RecordTotalSizeIncludes16;
 
     procedure TestCodegen_MethodPtrField_DirectCall_LoadsCodeAndData;
+    procedure TestCodegen_MethodPtrVirtualCapture_LoadsFromVTable;
 
     { End-to-end }
     procedure TestE2E_MethodPtr_NoArgs;
@@ -688,6 +689,43 @@ begin
     StrPos('$THolder_Handler', IR) >= 0);
 end;
 
+procedure TProcTypesOfObjectTests.TestCodegen_MethodPtrVirtualCapture_LoadsFromVTable;
+const
+  Src =
+    '''
+        program P;
+        type
+          TSpeak = procedure of object;
+          TAnimal = class(TObject)
+            procedure Speak; virtual;
+          end;
+          TDog = class(TAnimal)
+            procedure Speak; override;
+          end;
+        procedure TAnimal.Speak;
+        begin WriteLn('animal') end;
+        procedure TDog.Speak;
+        begin WriteLn('dog') end;
+        var A: TAnimal; M: TSpeak;
+        begin
+          A := TDog.Create();
+          M := @A.Speak;
+          M();
+          A.Free()
+        end.
+        ''';
+var IR: string;
+begin
+  IR := GenIR(Src);
+  { Capturing @A.Speak where Speak is virtual must read the Code half from
+    the receiver's vtable, not freeze the statically-resolved declared-type
+    address.  The buggy codegen stored the static label '$TAnimal_Speak'
+    into the (Code, Data) block; the fix loads the slot through the instance
+    vptr, so that static store must be absent. }
+  AssertFalse('virtual capture must not store the static method address',
+    StrPos('storel $TAnimal_Speak', IR) >= 0);
+end;
+
 procedure TProcTypesOfObjectTests.TestE2E_MethodPtrField_DirectCall_StmtForm;
 const
   Src =