From 33655582650cbea09c2290dea2cc663f4bd5dea0 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 21 Apr 2026 21:25:49 +0100 Subject: [PATCH] Add is/as for interface types with _ImplementsInterface/_GetItab dispatch Extend BlaiseTypeInfo with an impllist field (NULL-terminated {ti,itab} pairs) so the runtime can walk a class's interface set. Add _ImplementsInterface and _GetItab to blaise_exc.c for the 'is IFoo' and 'F := T as IFoo' operators respectively. Compiler changes: - uAST: ResolvedTargetType field on TIsExpr - uSemantic: accept tyInterface on RHS of is/as; set ResolvedTargetType - uCodeGenQBE: EmitIsExpr dispatches to _ImplementsInterface for interface targets; EmitAssignment handles F := T as IFoo via _GetItab + branch - EmitTypeInfoDefs: extend to 2-field layout {parent, impllist} - EmitInterfaceDefs: emit per-class impllist data blocks - uSymbolTable: register IInterface as built-in interface type 10 new tests in cp.test.interfaces; 2 existing typeinfo tests updated for new 2-field format. 494 tests, 0 failures. --- compiler/src/main/pascal/uAST.pas | 5 +- compiler/src/main/pascal/uCodeGenQBE.pas | 120 +++++++++--- compiler/src/main/pascal/uSemantic.pas | 11 +- compiler/src/main/pascal/uSymbolTable.pas | 3 + .../src/test/pascal/cp.test.interfaces.pas | 185 ++++++++++++++++++ .../src/test/pascal/cp.test.typetests.pas | 8 +- rtl/src/main/c/blaise_exc.c | 59 +++++- 7 files changed, 350 insertions(+), 41 deletions(-) diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 9ed814c..1a92e7c 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -54,8 +54,9 @@ type TIsExpr = class(TASTExpr) public - Obj: TASTExpr; { owned — left-hand side; must be class instance } - TypeName: string; { right-hand side type name; resolved by uSemantic } + Obj: TASTExpr; { owned — left-hand side; must be class instance } + TypeName: string; { right-hand side type name; resolved by uSemantic } + ResolvedTargetType: TTypeDesc; { set by uSemantic — class or interface descriptor } destructor Destroy; override; end; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index b79e77e..ebc79ef 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -549,15 +549,50 @@ end; procedure TCodeGenQBE.EmitAssignment(AAssign: TAssignment); var ValTemp, OldTemp, QType, StoreInstr, PtrTemp: string; - IntfDesc: TInterfaceTypeDesc; - ClassRT: TRecordTypeDesc; - ItabName: string; + IntfDesc: TInterfaceTypeDesc; + ClassRT: TRecordTypeDesc; + ItabName: string; + AE: TAsExpr; + ObjTemp: string; + ItabTemp: string; + CheckTemp: string; + LblOk: string; + LblFail: string; + LblEnd: string; begin if AAssign.Expr.ResolvedType = nil then raise ECodeGenError.CreateFmt( 'Expression in assignment to ''%s'' has no resolved type', [AAssign.Name]); - { Interface assignment: store obj pointer + itab pointer } + { Interface as-cast: F := T as IFoo — use _GetItab for runtime itab lookup } + if (AAssign.ResolvedLhsType <> nil) and + (AAssign.ResolvedLhsType.Kind = tyInterface) and + (AAssign.Expr is TAsExpr) and + (AAssign.Expr.ResolvedType.Kind = tyInterface) then + begin + AE := TAsExpr(AAssign.Expr); + IntfDesc := TInterfaceTypeDesc(AAssign.ResolvedLhsType); + ObjTemp := EmitExpr(AE.Obj); + ItabTemp := AllocTemp; + EmitLine(Format(' %s =l call $_GetItab(l %s, l $typeinfo_%s)', + [ItabTemp, ObjTemp, AE.TypeName])); + CheckTemp := AllocTemp; + LblOk := AllocLabel('as_ok'); + LblFail := AllocLabel('as_fail'); + LblEnd := AllocLabel('as_end'); + EmitLine(Format(' %s =w cnel %s, 0', [CheckTemp, ItabTemp])); + EmitLine(Format(' jnz %s, @%s, @%s', [CheckTemp, LblOk, LblFail])); + EmitLine('@' + LblFail); + EmitLine(' call $_Raise_InvalidCast()'); + EmitLine(Format(' jmp @%s', [LblEnd])); + EmitLine('@' + LblOk); + EmitLine(Format(' storel %s, %%_var_%s_obj', [ObjTemp, AAssign.Name])); + EmitLine(Format(' storel %s, %%_var_%s_itab', [ItabTemp, AAssign.Name])); + EmitLine('@' + LblEnd); + Exit; + end; + + { Interface direct assignment: F := T where T is a class implementing the interface } if (AAssign.ResolvedLhsType <> nil) and (AAssign.ResolvedLhsType.Kind = tyInterface) and (AAssign.Expr.ResolvedType.Kind = tyClass) then @@ -844,13 +879,16 @@ end; procedure TCodeGenQBE.EmitTypeInfoDefs(AProg: TProgram); { Emit one $typeinfo_T data item per class type. - Layout: { l parent_typeinfo_or_zero } - TypeInfo is at vtable slot 0; _IsInstance walks parent chain via this ptr. } + Layout: { l parent_typeinfo_or_zero, l impllist_or_zero } + TypeInfo is at vtable slot 0; _IsInstance walks parent chain. + impllist is NULL-terminated array of {typeinfo_intf, itab} pairs for _ImplementsInterface. } var - I: Integer; - TD: TTypeDecl; - TDesc: TTypeDesc; - RT: TRecordTypeDesc; + I: Integer; + TD: TTypeDecl; + TDesc: TTypeDesc; + RT: TRecordTypeDesc; + ParentStr: string; + ImplStr: string; begin for I := 0 to AProg.Block.TypeDecls.Count - 1 do begin @@ -860,10 +898,15 @@ begin if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue; RT := TRecordTypeDesc(TDesc); if RT.Parent <> nil then - EmitLine('data $typeinfo_' + TD.Name + - ' = { l $typeinfo_' + RT.Parent.Name + ' }') + ParentStr := '$typeinfo_' + RT.Parent.Name else - EmitLine('data $typeinfo_' + TD.Name + ' = { l 0 }'); + ParentStr := '0'; + if RT.ImplementsCount > 0 then + ImplStr := '$impllist_' + TD.Name + else + ImplStr := '0'; + EmitLine('data $typeinfo_' + TD.Name + + ' = { l ' + ParentStr + ', l ' + ImplStr + ' }'); end; EmitLine(''); end; @@ -901,18 +944,20 @@ begin end; procedure TCodeGenQBE.EmitInterfaceDefs(AProg: TProgram); -{ Emit typeinfo blocks for interfaces and itab blocks for class-interface pairs. - Interface typeinfo: data $typeinfo_IFoo = { l 0 } (address IS the identity) +{ 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) Itab: data $itab_TFoo_IFoo = { l $TFoo_DoIt, l $TFoo_GetVal } - Methods appear in declaration order (itab slot N = interface method N). } + Impllist: data $impllist_TFoo = { l $typeinfo_IFoo, l $itab_TFoo_IFoo, l 0 } + Methods in declaration order; impllist is NULL-terminated {ti, itab} pair array. } var - I, J, K: Integer; - TD: TTypeDecl; - TDesc: TTypeDesc; - IntfDesc: TInterfaceTypeDesc; - ClassRT: TRecordTypeDesc; - ItabLine: string; - MethName: string; + I, J, K: Integer; + TD: TTypeDecl; + TDesc: TTypeDesc; + IntfDesc: TInterfaceTypeDesc; + ClassRT: TRecordTypeDesc; + ItabLine: string; + ImplLine: string; + MethName: string; begin { Typeinfo blocks for every interface } for I := 0 to AProg.Block.TypeDecls.Count - 1 do @@ -922,7 +967,7 @@ begin EmitLine('data $typeinfo_' + TD.Name + ' = { l 0 }'); end; - { Itab blocks for each (class, interface) pair } + { Itab and impllist blocks for each implementing class } for I := 0 to AProg.Block.TypeDecls.Count - 1 do begin TD := TTypeDecl(AProg.Block.TypeDecls[I]); @@ -930,6 +975,9 @@ 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; + + { One itab per interface } for J := 0 to ClassRT.ImplementsCount - 1 do begin IntfDesc := ClassRT.ImplementsIntfAt(J); @@ -945,6 +993,21 @@ begin ItabLine := ItabLine + ' }'; EmitLine(ItabLine); end; + + { One impllist per class: NULL-terminated {typeinfo_intf, itab} pairs } + ImplLine := 'data $impllist_' + TD.Name + ' = {'; + for J := 0 to ClassRT.ImplementsCount - 1 do + begin + IntfDesc := ClassRT.ImplementsIntfAt(J); + if J = 0 then + ImplLine := ImplLine + ' l $typeinfo_' + IntfDesc.Name + + ', l $itab_' + TD.Name + '_' + IntfDesc.Name + else + ImplLine := ImplLine + ', l $typeinfo_' + IntfDesc.Name + + ', l $itab_' + TD.Name + '_' + IntfDesc.Name; + end; + ImplLine := ImplLine + ', l 0 }'; + EmitLine(ImplLine); end; EmitLine(''); end; @@ -1415,8 +1478,13 @@ var begin ObjTemp := EmitExpr(AExpr.Obj); ResTemp := AllocTemp; - EmitLine(Format(' %s =w call $_IsInstance(l %s, l $typeinfo_%s)', - [ResTemp, ObjTemp, AExpr.TypeName])); + if (AExpr.ResolvedTargetType <> nil) and + (AExpr.ResolvedTargetType.Kind = tyInterface) then + EmitLine(Format(' %s =w call $_ImplementsInterface(l %s, l $typeinfo_%s)', + [ResTemp, ObjTemp, AExpr.TypeName])) + else + EmitLine(Format(' %s =w call $_IsInstance(l %s, l $typeinfo_%s)', + [ResTemp, ObjTemp, AExpr.TypeName])); Result := ResTemp; end; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index c4f6afb..a135519 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -1389,12 +1389,14 @@ begin AExpr.Line, AExpr.Col); TargetType := FTable.FindType(AExpr.TypeName); - if (TargetType = nil) or (TargetType.Kind <> tyClass) then + if (TargetType = nil) or + ((TargetType.Kind <> tyClass) and (TargetType.Kind <> tyInterface)) then SemanticError( - Format('''is'' requires a class type name on the right, got ''%s''', + Format('''is'' requires a class or interface type name on the right, got ''%s''', [AExpr.TypeName]), AExpr.Line, AExpr.Col); + AExpr.ResolvedTargetType := TargetType; Result := FTable.TypeBoolean; end; @@ -1411,9 +1413,10 @@ begin AExpr.Line, AExpr.Col); TargetType := FTable.FindType(AExpr.TypeName); - if (TargetType = nil) or (TargetType.Kind <> tyClass) then + if (TargetType = nil) or + ((TargetType.Kind <> tyClass) and (TargetType.Kind <> tyInterface)) then SemanticError( - Format('''as'' requires a class type name on the right, got ''%s''', + Format('''as'' requires a class or interface type name on the right, got ''%s''', [AExpr.TypeName]), AExpr.Line, AExpr.Col); diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index 9996ea2..61407a6 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -640,6 +640,9 @@ begin { TObject — root of the class hierarchy; no fields, no parent } Define(TSymbol.Create('TObject', skType, NewClassType('TObject'))); + { IInterface — root of the interface hierarchy; no methods } + Define(TSymbol.Create('IInterface', skType, NewInterfaceType('IInterface'))); + { Built-in I/O procedures } Sym := TSymbol.Create('Write', skProcedure, nil); Define(Sym); diff --git a/compiler/src/test/pascal/cp.test.interfaces.pas b/compiler/src/test/pascal/cp.test.interfaces.pas index 505d097..a1181e4 100644 --- a/compiler/src/test/pascal/cp.test.interfaces.pas +++ b/compiler/src/test/pascal/cp.test.interfaces.pas @@ -34,6 +34,20 @@ type procedure TestSemantic_ClassImplements_OK; procedure TestSemantic_ClassImplements_MissingMethod_RaisesError; + { ------------------------------------------------------------------ } + { Semantic — is/as with interface types } + { ------------------------------------------------------------------ } + procedure TestSemantic_IsExpr_Interface_OK; + procedure TestSemantic_IsExpr_Interface_ResultIsBoolean; + procedure TestSemantic_AsExpr_Interface_OK; + procedure TestSemantic_AsExpr_Interface_ResultType; + + { ------------------------------------------------------------------ } + { Semantic — IInterface built-in } + { ------------------------------------------------------------------ } + procedure TestSemantic_IInterface_Registered; + procedure TestSemantic_IInterface_IsInterfaceKind; + { ------------------------------------------------------------------ } { Code generation } { ------------------------------------------------------------------ } @@ -42,6 +56,10 @@ type procedure TestCodegen_Itab_ContainsMethodPointer; procedure TestCodegen_InterfaceVar_AllocsTwoSlots; procedure TestCodegen_InterfaceMethodCall_IndirectDispatch; + procedure TestCodegen_Typeinfo_ClassHasImpllistField; + procedure TestCodegen_Impllist_Emitted; + procedure TestCodegen_IsExpr_Interface_CallsImplementsInterface; + procedure TestCodegen_AsExpr_Interface_CallsGetItab; end; implementation @@ -131,6 +149,46 @@ const 'begin' + LineEnding + 'end.'; + SrcIsExprInterface = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' IFoo = interface' + LineEnding + + ' procedure DoIt;' + LineEnding + + ' end;' + LineEnding + + ' TFoo = class(TObject, IFoo)' + LineEnding + + ' procedure DoIt;' + LineEnding + + ' end;' + LineEnding + + 'procedure TFoo.DoIt;' + LineEnding + + 'begin' + LineEnding + + 'end;' + LineEnding + + 'var' + LineEnding + + ' T: TFoo;' + LineEnding + + ' R: Boolean;' + LineEnding + + 'begin' + LineEnding + + ' T := TFoo.Create;' + LineEnding + + ' R := T is IFoo' + LineEnding + + 'end.'; + + SrcAsExprInterface = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' IFoo = interface' + LineEnding + + ' procedure DoIt;' + LineEnding + + ' end;' + LineEnding + + ' TFoo = class(TObject, IFoo)' + LineEnding + + ' procedure DoIt;' + LineEnding + + ' end;' + LineEnding + + 'procedure TFoo.DoIt;' + LineEnding + + 'begin' + LineEnding + + 'end;' + LineEnding + + 'var' + LineEnding + + ' T: TFoo;' + LineEnding + + ' F: IFoo;' + LineEnding + + 'begin' + LineEnding + + ' T := TFoo.Create;' + LineEnding + + ' F := T as IFoo' + LineEnding + + 'end.'; + SrcInterfaceVar = 'program P;' + LineEnding + 'type' + LineEnding + @@ -422,6 +480,133 @@ begin AssertTrue('indirect call via register', Pos('call %', IR) > 0); end; +{ ------------------------------------------------------------------ } +{ Semantic — is/as with interface types } +{ ------------------------------------------------------------------ } + +procedure TInterfaceTests.TestSemantic_IsExpr_Interface_OK; +begin + AnalyseSrc(SrcIsExprInterface).Free; +end; + +procedure TInterfaceTests.TestSemantic_IsExpr_Interface_ResultIsBoolean; +var + Prog: TProgram; + IE: TIsExpr; +begin + Prog := AnalyseSrc(SrcIsExprInterface); + try + { Stmts[0] = T := TFoo.Create; Stmts[1] = R := T is IFoo } + IE := TIsExpr(TAssignment(Prog.Block.Stmts[1]).Expr); + AssertNotNull('resolved type', IE.ResolvedType); + AssertEquals('result is Boolean', Ord(tyBoolean), Ord(IE.ResolvedType.Kind)); + finally + Prog.Free; + end; +end; + +procedure TInterfaceTests.TestSemantic_AsExpr_Interface_OK; +begin + AnalyseSrc(SrcAsExprInterface).Free; +end; + +procedure TInterfaceTests.TestSemantic_AsExpr_Interface_ResultType; +var + Prog: TProgram; + AE: TAsExpr; +begin + Prog := AnalyseSrc(SrcAsExprInterface); + try + { Stmts[0] = T := TFoo.Create; Stmts[1] = F := T as IFoo } + AE := TAsExpr(TAssignment(Prog.Block.Stmts[1]).Expr); + AssertNotNull('resolved type', AE.ResolvedType); + AssertEquals('result kind is tyInterface', Ord(tyInterface), Ord(AE.ResolvedType.Kind)); + AssertEquals('result type name is IFoo', 'IFoo', AE.ResolvedType.Name); + finally + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Semantic — IInterface built-in } +{ ------------------------------------------------------------------ } + +procedure TInterfaceTests.TestSemantic_IInterface_Registered; +var + Prog: TProgram; + Sym: TSymbol; +begin + Prog := AnalyseSrc('program P; begin end.'); + try + Sym := Prog.SymbolTable.Lookup('IInterface'); + AssertNotNull('IInterface symbol exists', Sym); + AssertEquals('IInterface is skType', Ord(skType), Ord(Sym.Kind)); + finally + Prog.Free; + end; +end; + +procedure TInterfaceTests.TestSemantic_IInterface_IsInterfaceKind; +var + Prog: TProgram; + TD: TTypeDesc; +begin + Prog := AnalyseSrc('program P; begin end.'); + try + TD := Prog.SymbolTable.FindType('IInterface'); + AssertNotNull('IInterface type exists', TD); + AssertEquals('kind is tyInterface', Ord(tyInterface), Ord(TD.Kind)); + finally + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Codegen — impllist and extended typeinfo } +{ ------------------------------------------------------------------ } + +procedure TInterfaceTests.TestCodegen_Typeinfo_ClassHasImpllistField; +var + IR: string; +begin + IR := GenIR(SrcClassImplements); + { Class with implements must have 2-field typeinfo: { l parent, l impllist } } + AssertTrue('TFoo typeinfo has impllist field', + Pos('$typeinfo_TFoo = { l $typeinfo_TObject, l $impllist_TFoo }', IR) > 0); +end; + +procedure TInterfaceTests.TestCodegen_Impllist_Emitted; +var + IR: string; +begin + IR := GenIR(SrcClassImplements); + AssertTrue('impllist_TFoo emitted', Pos('$impllist_TFoo', IR) > 0); + { Impllist contains typeinfo_IFoo and itab_TFoo_IFoo pointers } + AssertTrue('impllist references typeinfo_IFoo', + PosEx('$typeinfo_IFoo', IR, + Pos('$impllist_TFoo', IR)) > 0); + AssertTrue('impllist references itab_TFoo_IFoo', + PosEx('$itab_TFoo_IFoo', IR, + Pos('$impllist_TFoo', IR)) > 0); +end; + +procedure TInterfaceTests.TestCodegen_IsExpr_Interface_CallsImplementsInterface; +var + IR: string; +begin + IR := GenIR(SrcIsExprInterface); + AssertTrue('is IFoo calls _ImplementsInterface', + Pos('call $_ImplementsInterface', IR) > 0); +end; + +procedure TInterfaceTests.TestCodegen_AsExpr_Interface_CallsGetItab; +var + IR: string; +begin + IR := GenIR(SrcAsExprInterface); + AssertTrue('as IFoo calls _GetItab', Pos('call $_GetItab', IR) > 0); +end; + initialization RegisterTest(TInterfaceTests); diff --git a/compiler/src/test/pascal/cp.test.typetests.pas b/compiler/src/test/pascal/cp.test.typetests.pas index 711434f..630883a 100644 --- a/compiler/src/test/pascal/cp.test.typetests.pas +++ b/compiler/src/test/pascal/cp.test.typetests.pas @@ -320,19 +320,19 @@ end; procedure TTypeTestTests.TestCodegen_TypeInfo_ParentPtr_IsZero_ForRoot; var IR: string; begin - { Root class (no parent) must have parent pointer = 0 } + { Root class (no parent) must have parent pointer = 0; second field is impllist = 0 } IR := GenIR(SrcBase); AssertTrue('root typeinfo has zero parent ptr', - Pos('$typeinfo_TAnimal = { l 0 }', IR) > 0); + Pos('$typeinfo_TAnimal = { l 0, l 0 }', IR) > 0); end; procedure TTypeTestTests.TestCodegen_TypeInfo_ParentPtr_ForDerived; var IR: string; begin - { Derived class typeinfo must reference parent typeinfo } + { Derived class typeinfo must reference parent typeinfo; impllist = 0 (no interfaces) } IR := GenIR(SrcInherit); AssertTrue('derived typeinfo refs parent', - Pos('$typeinfo_TDog = { l $typeinfo_TAnimal }', IR) > 0); + Pos('$typeinfo_TDog = { l $typeinfo_TAnimal, l 0 }', IR) > 0); end; procedure TTypeTestTests.TestCodegen_Vtable_StartsWithTypeInfo; diff --git a/rtl/src/main/c/blaise_exc.c b/rtl/src/main/c/blaise_exc.c index adad2e4..ff826a0 100644 --- a/rtl/src/main/c/blaise_exc.c +++ b/rtl/src/main/c/blaise_exc.c @@ -83,15 +83,18 @@ void _Reraise(void* exc) { * ----------------------------------------------------------------------- */ /* - * BlaiseTypeInfo — one per class, stored as vtable slot 0. - * parent = pointer to parent class TypeInfo, or NULL for root classes. + * BlaiseTypeInfo — one per class/interface, stored as vtable slot 0. + * parent = pointer to parent class TypeInfo, or NULL for root classes. + * impllist = NULL-terminated array of {typeinfo_intf*, itab*} pairs, or NULL + * if the class implements no interfaces. */ typedef struct BlaiseTypeInfo { const struct BlaiseTypeInfo* parent; + const void** impllist; } BlaiseTypeInfo; /* - * _IsInstance — runtime 'is' check. + * _IsInstance — runtime 'is' check for class inheritance. * Walks the TypeInfo parent chain from the object's own TypeInfo upward. * Returns 1 if the object is an instance of target (or a subclass), else 0. * obj must be non-nil and point to an instance whose first field is the vptr. @@ -109,11 +112,57 @@ int _IsInstance(void* obj, const BlaiseTypeInfo* target) { return 0; } +/* + * _ImplementsInterface — runtime 'is' check for interface membership. + * Walks the class TypeInfo chain; at each level searches the impllist for + * a matching interface TypeInfo pointer. + * Returns 1 if the object's class (or any ancestor) implements the interface. + */ +int _ImplementsInterface(void* obj, const BlaiseTypeInfo* intf_ti) { + const BlaiseTypeInfo* ti; + const void** impl; + void** vtable; + if (!obj || !intf_ti) return 0; + vtable = *(void***)obj; + ti = (const BlaiseTypeInfo*)vtable[0]; + while (ti) { + impl = ti->impllist; + while (impl && *impl) { + if ((const BlaiseTypeInfo*)(*impl) == intf_ti) return 1; + impl += 2; /* each entry is {typeinfo*, itab*} — skip both */ + } + ti = ti->parent; + } + return 0; +} + +/* + * _GetItab — return the itab pointer for the given object/interface pair. + * Walks the class TypeInfo chain searching the impllist for a matching + * interface TypeInfo pointer; returns the associated itab on match. + * Returns NULL if the object's class does not implement the interface. + */ +const void* _GetItab(void* obj, const BlaiseTypeInfo* intf_ti) { + const BlaiseTypeInfo* ti; + const void** impl; + void** vtable; + if (!obj || !intf_ti) return 0; + vtable = *(void***)obj; + ti = (const BlaiseTypeInfo*)vtable[0]; + while (ti) { + impl = ti->impllist; + while (impl && *impl) { + if ((const BlaiseTypeInfo*)(*impl) == intf_ti) return *(impl + 1); + impl += 2; + } + ti = ti->parent; + } + return 0; +} + /* * _Raise_InvalidCast — raised by the 'as' operator when the type check fails. - * Phase 2: aborts with a message. Phase 3 will raise EInvalidCast. */ void _Raise_InvalidCast(void) { - /* TODO Phase 3: create EInvalidCast object and call _Raise */ abort(); }