administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

fix: class recognised as implementing an interface inherited from an ancestor (issue #130 bug3)

Browse source 
A class that inherits an interface from its ancestor (the ancestor declares
the interface; the descendant does not re-list it) was not recognised as
implementing it.  `g := TLoud.Create` where TLoud < TPerson(IGreeter) failed
with "Type mismatch", and after the semantic gate was opened the codegen
referenced a non-existent itab.

Three coordinated fixes:

- uSemantic (CheckTypesMatch): the class->interface compatibility check
  scanned only the class's own ImplementsList.  It now walks the whole class
  parent chain, so a descendant inherits its ancestors' interface
  implementations.

- blaise.codegen.qbe / blaise.codegen.native (EmitInterfaceDefs): itab/impllist
  generation likewise only considered a class's own ImplementsList, so no itab
  was emitted for an inherited interface.  Both backends now:
    * skip a class only when neither it nor any ancestor implements an
      interface (and, on native, point the typeinfo at the impllist on the same
      condition);
    * collect implemented interfaces by walking the class parent chain;
    * resolve each itab method ref via the vtable slot's ImplName, so an
      overridden method points at the descendant's body and an inherited
      (non-overridden) method at the ancestor's — uniformly correct across
      arbitrary inheritance depth.

Tests (cp.test.e2e.interfaces.pas, dual-backend via AssertRunsOnAll): the
exact issue repro (descendant assigned to an interface var, dispatching to its
override), and a three-level chain through an interface parameter mixing an
overridden method with an inherited non-overridden one.

Verified: FIXPOINT_OK, NATIVE_FIXPOINT_OK, NATIVE_INTERNAL_OK; full suite green
on both the QBE-built and native-built runners (3695 tests).
This commit is contained in:
Graeme Geldenhuys 2026-06-20 16:56:33 +01:00
parent 33db0f699e
commit 56e73c8ce4
4 changed files with 225 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

89
compiler/src/main/pascal/blaise.codegen.native.x86_64.pas
View file

@ -337,6 +337,12 @@ type
must then point at _AbstractMethodError). }
function IsAbstractClassMethod(ARec: TRecordTypeDesc;
const AMethName: string): Boolean;
{ True when the class or any ancestor implements an interface. }
function ClassOrAncestorImplements(AClassRT: TRecordTypeDesc): Boolean;
{ Native label for a class's implementation of an interface method,
resolved via the vtable (inherited + overridden both work). }
function ItabMethodRefNative(AClassRT: TRecordTypeDesc;
ATD: TTypeDecl; const AMethName: string): string;
{ Load an integer-family value from AOperand into %rax, extended to 64
bits per AType (sign/zero-extend by width and signedness). }
procedure EmitLoadVar(const AOperand: string; AType: TTypeDesc);
@ -1959,7 +1965,10 @@ begin
ParentStr := 'typeinfo_' + Self.ClassSymName(RT.Parent.Name)
else
ParentStr := '0';
if RT.ImplementsCount() > 0 then
{ Point at the impllist when this class OR any ancestor implements an
interface — a descendant inherits its parent's interfaces and gets its
own impllist (issue #130 bug3). }
if Self.ClassOrAncestorImplements(RT) then
ImplStr := 'impllist_' + CSym
else
ImplStr := '0';
@ -2513,6 +2522,53 @@ begin
Result := ARec.VTableEntryAt(Slot).IsAbstract;
end;
{ True when AClassRT or any of its ancestors implements at least one interface.
A descendant inherits its parent's interface implementations (issue #130
bug3), so the whole class parent chain must be scanned. }
function TX86_64Backend.ClassOrAncestorImplements(AClassRT: TRecordTypeDesc): Boolean;
var
Walk: TRecordTypeDesc;
begin
Walk := AClassRT;
while Walk <> nil do
begin
if Walk.ImplementsCount() > 0 then Exit(True);
Walk := Walk.Parent;
end;
Result := False;
end;
{ Native label for AClassRT's implementation of interface method AMethName.
Prefers the vtable slot's resolved ImplName (so an inherited method points at
the ancestor's body and an override at the descendant's — issue #130 bug3);
the ImplName may carry a leading '$' (QBE convention) which is stripped, then
NativeMangle is applied. Falls back to the declaring-class method name. }
function TX86_64Backend.ItabMethodRefNative(AClassRT: TRecordTypeDesc;
ATD: TTypeDecl; const AMethName: string): string;
var
Slot: Integer;
E: TVTableEntry;
begin
if AClassRT <> nil then
begin
Slot := AClassRT.FindVTableSlot(AMethName);
if Slot >= 0 then
begin
E := AClassRT.VTableEntryAt(Slot);
if (E <> nil) and (E.ImplName <> '') then
begin
if StrAt(E.ImplName, 0) = 36 then { 36 = '$' }
Exit(NativeMangle(StrCopyTail(E.ImplName, 1)))
else
Exit(NativeMangle(E.ImplName));
end;
end;
end;
Result := MethodEmitNameNative(
FindMethodInClassDef(TClassTypeDef(ATD.Def), AMethName),
ATD.Name, AMethName);
end;
{ Emit typeinfo / itab / impllist blocks for interfaces and implementing
classes. Mirrors the QBE backend's EmitInterfaceDefs:
@ -2541,6 +2597,7 @@ var
MDecl: TMethodDecl;
EmitIntfs: TObjectList;
IntfWalk: TInterfaceTypeDesc;
ClassWalk: TRecordTypeDesc;
begin
{ Typeinfo blocks for every plain interface. }
for I := 0 to ATypeDecls.Count - 1 do
@ -2572,23 +2629,32 @@ begin
TDesc := ASymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
ClassRT := TRecordTypeDesc(TDesc);
if ClassRT.ImplementsCount() = 0 then Continue;
{ Skip only when neither this class NOR any ancestor implements an interface
— a descendant inherits its parent's interfaces (issue #130 bug3). }
if not Self.ClassOrAncestorImplements(ClassRT) then Continue;
CSym := Self.ClassSymName(TD.Name);
{ Collect each implemented interface PLUS every ancestor on its parent
chain so a class instance can narrow directly to a base interface (an
ancestor's methods are a prefix of the descendant's itab — same impl
pointers). Dedup keeps one itab per (class, interface). }
pointers). Also walk the CLASS parent chain to pick up interfaces an
ancestor implements (issue #130 bug3). Dedup keeps one itab per
(class, interface). }
EmitIntfs := TObjectList.Create(False);
try
for J := 0 to ClassRT.ImplementsCount() - 1 do
ClassWalk := ClassRT;
while ClassWalk <> nil do
begin
IntfWalk := ClassRT.ImplementsIntfAt(J);
while IntfWalk <> nil do
for J := 0 to ClassWalk.ImplementsCount() - 1 do
begin
if EmitIntfs.IndexOf(IntfWalk) < 0 then EmitIntfs.Add(IntfWalk);
IntfWalk := IntfWalk.Parent;
IntfWalk := ClassWalk.ImplementsIntfAt(J);
while IntfWalk <> nil do
begin
if EmitIntfs.IndexOf(IntfWalk) < 0 then EmitIntfs.Add(IntfWalk);
IntfWalk := IntfWalk.Parent;
end;
end;
ClassWalk := ClassWalk.Parent;
end;
{ One itab per interface — a flat array of method-code ptrs in interface
@ -2605,9 +2671,10 @@ begin
if Self.IsAbstractClassMethod(ClassRT, MethName) then
MethRef := '_AbstractMethodError'
else
MethRef := MethodEmitNameNative(
FindMethodInClassDef(TClassTypeDef(TD.Def), MethName),
TD.Name, MethName);
{ Resolve via the vtable so an inherited (non-overridden) method
points at the ancestor's body and an override at the descendant's
(issue #130 bug3). }
MethRef := Self.ItabMethodRefNative(ClassRT, TD, MethName);
Self.Emit(#9'.quad ' + MethRef);
end;
end;

68
compiler/src/main/pascal/blaise.codegen.qbe.pas
View file

@ -186,6 +186,10 @@ type
procedure EmitVTableDefs(AProg: TProgram);
procedure EmitMethodDefs(AProg: TProgram);
procedure EmitInterfaceDefs(AProg: TProgram);
{ QBE label for AClassRT's implementation of interface method AMethName,
resolved via the vtable so inherited/overridden methods both work. }
function ItabMethodRef(AClassRT: TRecordTypeDesc;
const AClassName, AMethName: string): string;
function IsAbstractClassMethod(ARec: TRecordTypeDesc;
const AMethName: string): Boolean;
procedure EmitFieldCleanupDefs(AProg: TProgram);
@ -7621,6 +7625,31 @@ begin
EmitLine('');
end;
function TCodeGenQBE.ItabMethodRef(AClassRT: TRecordTypeDesc;
const AClassName, AMethName: string): string;
var
Slot: Integer;
E: TVTableEntry;
begin
{ The QBE label for AClassRT's implementation of interface method AMethName.
The vtable already records the resolved impl per slot (an override points at
the descendant's body, an inherited method at the ancestor's), so prefer it.
Fall back to $<class>_<method> for the rare case of a class with no vtable
entry for the method (defensive — should not happen for a satisfied
interface). }
if AClassRT <> nil then
begin
Slot := AClassRT.FindVTableSlot(AMethName);
if Slot >= 0 then
begin
E := AClassRT.VTableEntryAt(Slot);
if (E <> nil) and (E.ImplName <> '') then
Exit(E.ImplName);
end;
end;
Result := '$' + ClassSymName(AClassName) + '_' + AMethName;
end;
procedure TCodeGenQBE.EmitInterfaceDefs(AProg: TProgram);
{ Emit typeinfo blocks for interfaces and itab/impllist blocks for class-interface pairs.
Interface typeinfo: data $typeinfo_IFoo = ( l 0 ) -- address IS the identity token
@ -7644,6 +7673,7 @@ var
MName: string;
EmitIntfs: TObjectList;
IntfWalk: TInterfaceTypeDesc;
ClassWalk: TRecordTypeDesc;
begin
{ Typeinfo blocks for every plain interface }
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
@ -7668,23 +7698,39 @@ begin
TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
ClassRT := TRecordTypeDesc(TDesc);
if ClassRT.ImplementsCount() = 0 then Continue;
{ Skip only when neither this class NOR any ancestor implements an
interface — a descendant inherits its parent's interfaces and still needs
its own itab (issue #130 bug3). }
ClassWalk := ClassRT;
while (ClassWalk <> nil) and (ClassWalk.ImplementsCount() = 0) do
ClassWalk := ClassWalk.Parent;
if ClassWalk = nil then Continue;
{ Collect each implemented interface PLUS every ancestor on its parent
chain (IDog = interface(IAnimal) -> also emit an IAnimal itab), so a
class instance can be narrowed directly to a base interface. An
ancestor's methods are a prefix of the descendant's itab, so the same
impl pointers apply; the dedup keeps one itab per (class, interface). }
impl pointers apply; the dedup keeps one itab per (class, interface).
Also walk the CLASS parent chain: a descendant inherits the interfaces
its ancestors implement (TLoud < TPerson(IGreeter) -> TLoud also
implements IGreeter), so it needs its own itab whose method refs resolve
to TLoud's (possibly overridden) implementations (issue #130 bug3). }
EmitIntfs := TObjectList.Create(False);
try
for J := 0 to ClassRT.ImplementsCount() - 1 do
ClassWalk := ClassRT;
while ClassWalk <> nil do
begin
IntfWalk := ClassRT.ImplementsIntfAt(J);
while IntfWalk <> nil do
for J := 0 to ClassWalk.ImplementsCount() - 1 do
begin
if EmitIntfs.IndexOf(IntfWalk) < 0 then EmitIntfs.Add(IntfWalk);
IntfWalk := IntfWalk.Parent;
IntfWalk := ClassWalk.ImplementsIntfAt(J);
while IntfWalk <> nil do
begin
if EmitIntfs.IndexOf(IntfWalk) < 0 then EmitIntfs.Add(IntfWalk);
IntfWalk := IntfWalk.Parent;
end;
end;
ClassWalk := ClassWalk.Parent;
end;
{ One itab per interface — when a class's vtable slot for a given
@ -7703,7 +7749,13 @@ begin
if IsAbstractClassMethod(ClassRT, MethName) then
MethRef := '$_AbstractMethodError'
else
MethRef := '$' + ClassSymName(TD.Name) + '_' + MethName;
{ Resolve to the class's actual implementation of this method. The
vtable slot's ImplName already accounts for inheritance and
overrides ($TLoud_Greet for an override, $TPerson_Greet for a
method inherited unchanged), so use it rather than blindly naming
$<thisclass>_<method> which would not exist for inherited methods
(issue #130 bug3). }
MethRef := ItabMethodRef(ClassRT, TD.Name, MethName);
if K = 0 then
ItabLine := ItabLine + ' l ' + MethRef
else

30
compiler/src/main/pascal/uSemantic.pas
View file

@ -759,8 +759,9 @@ end;
procedure TSemanticAnalyser.CheckTypesMatch(AExpected, AActual: TTypeDesc;
const AContext: string; ALine, ACol: Integer);
var
RT: TRecordTypeDesc;
I: Integer;
RT: TRecordTypeDesc;
Walk: TRecordTypeDesc;
I: Integer;
begin
if AExpected = AActual then
Exit;
@ -838,17 +839,24 @@ begin
if InterfaceInheritsFrom(TInterfaceTypeDesc(AActual),
TInterfaceTypeDesc(AExpected)) then
Exit;
{ class → interface: allowed when the class implements that interface (or a
descendant of it — implementing IDog also satisfies IAnimal). }
{ class → interface: allowed when the class — or ANY of its ancestors —
implements that interface (or a descendant of it: implementing IDog also
satisfies IAnimal). A descendant inherits its parent's interface
implementations, so the whole parent chain must be scanned, not just the
class's own ImplementsList (issue #130 bug3). }
if (AExpected.Kind = tyInterface) and (AActual.Kind = tyClass) then
begin
RT := TRecordTypeDesc(AActual);
for I := 0 to RT.ImplementsCount() - 1 do
if (RT.ImplementsIntfAt(I) = AExpected) or
((RT.ImplementsIntfAt(I) is TInterfaceTypeDesc) and
InterfaceInheritsFrom(TInterfaceTypeDesc(RT.ImplementsIntfAt(I)),
TInterfaceTypeDesc(AExpected))) then
Exit;
Walk := TRecordTypeDesc(AActual);
while Walk <> nil do
begin
for I := 0 to Walk.ImplementsCount() - 1 do
if (Walk.ImplementsIntfAt(I) = AExpected) or
((Walk.ImplementsIntfAt(I) is TInterfaceTypeDesc) and
InterfaceInheritsFrom(TInterfaceTypeDesc(Walk.ImplementsIntfAt(I)),
TInterfaceTypeDesc(AExpected))) then
Exit;
Walk := Walk.Parent;
end;
end;
{ Untyped pointer accepts any class/interface/string/PChar reference and vice-versa }
if (AExpected.Kind = tyPointer) and

68
compiler/src/test/pascal/cp.test.e2e.interfaces.pas
View file

@ -41,6 +41,13 @@ type
interface (needs the class to emit an itab for the inherited base). }
procedure TestRun_ClassImplDerived_ToBaseVar;
procedure TestRun_ClassImplDerived_ToBaseParam;
{ A class that INHERITS an interface from its ancestor (the ancestor
declares the interface; the descendant does not re-list it). The
descendant must be assignable/passable as that interface, dispatching to
its own overrides and to inherited (non-overridden) methods alike
(issue #130 bug3). }
procedure TestRun_InheritedInterface_DescendantToVar;
procedure TestRun_InheritedInterface_OverrideAndInheritedMethod;
end;
implementation
@ -306,6 +313,67 @@ begin
AssertRunsOnAll(SrcClassImplDerivedToBaseParam, 'A:Rex' + LE, 0);
end;
procedure TE2EInterfaceTests.TestRun_InheritedInterface_DescendantToVar;
const
{ TLoud inherits IGreeter from TPerson; assigning a TLoud to an IGreeter var
must work and dispatch to TLoud's override (issue #130 bug3 — the repro). }
Src = '''
program P;
type
IGreeter = interface function Greet: string; end;
TPerson = class(IGreeter) function Greet: string; virtual; end;
TLoud = class(TPerson) function Greet: string; override; end;
function TPerson.Greet: string; begin Result := 'hi' end;
function TLoud.Greet: string; begin Result := 'HI' end;
var g: IGreeter;
begin
g := TPerson.Create; WriteLn(g.Greet());
g := TLoud.Create; WriteLn(g.Greet());
g := nil
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, 'hi' + LE + 'HI' + LE, 0);
end;
procedure TE2EInterfaceTests.TestRun_InheritedInterface_OverrideAndInheritedMethod;
const
{ Three-level chain through an interface parameter: each level's itab must
resolve overridden methods to the level's own body and NON-overridden
methods to the inherited ancestor body (Who is never overridden). }
Src = '''
program P;
type
IGreeter = interface
function Greet: string;
function Who: string;
end;
TPerson = class(IGreeter)
function Greet: string; virtual;
function Who: string; virtual;
end;
TLoud = class(TPerson) function Greet: string; override; end;
TVeryLoud = class(TLoud) function Greet: string; override; end;
function TPerson.Greet: string; begin Result := 'hi' end;
function TPerson.Who: string; begin Result := 'person' end;
function TLoud.Greet: string; begin Result := 'HI' end;
function TVeryLoud.Greet: string; begin Result := 'HI!!!' end;
procedure Use(g: IGreeter);
begin WriteLn(g.Greet(), ' / ', g.Who()) end;
var per: TPerson; lou: TLoud; vl: TVeryLoud;
begin
per := TPerson.Create; Use(per); per.Free;
lou := TLoud.Create; Use(lou); lou.Free;
vl := TVeryLoud.Create; Use(vl); vl.Free
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src,
'hi / person' + LE + 'HI / person' + LE + 'HI!!! / person' + LE, 0);
end;
initialization
RegisterTest(TE2EInterfaceTests);