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

Add is/as type-test operators with runtime typeinfo dispatch

Browse source 
- AST: TIsExpr, TAsExpr nodes (obj + type name, ResolvedType set by semantic)
- Lexer: tkIs, tkAs tokens (IS/AS are true keywords, handled in MapKeyword)
- Parser: parse 'Obj is T' and 'Obj as T' at comparison precedence level;
  right-hand side is a type name (identifier), not a sub-expression
- Semantic: AnalyseIsExpr (result Boolean), AnalyseAsExpr (result = target type);
  both require class type on left, known class type on right
- CodeGen: EmitTypeInfoDefs emits $typeinfo_T = { l parent_or_0 } per class;
  vtable slot 0 is now the typeinfo pointer (methods shift to (slot+1)*8);
  EmitIsExpr emits call $_IsInstance; EmitAsExpr emits branch + _Raise_InvalidCast
- RTL: BlaiseTypeInfo struct, _IsInstance (walks parent chain), _Raise_InvalidCast
- 21 new tests (481 total); all existing vtable dispatch tests pass after slot shift
This commit is contained in:
Graeme Geldenhuys 2026-04-21 14:45:21 +01:00
parent c1d53e7be6
commit 62026fb00a
8 changed files with 627 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -52,6 +52,20 @@ type
IsClassAccess: Boolean; { set by uSemantic — pointer deref needed }
end;
TIsExpr = class(TASTExpr)
public
Obj: TASTExpr; { owned — left-hand side; must be class instance }
TypeName: string; { right-hand side type name; resolved by uSemantic }
destructor Destroy; override;
end;
TAsExpr = class(TASTExpr)
public
Obj: TASTExpr; { owned — left-hand side; must be class instance }
TypeName: string; { right-hand side type name; resolved by uSemantic }
destructor Destroy; override;
end;
TBinaryOp = (boAdd, boSub, boMul, boDiv, boEQ, boNE, boLT, boGT, boLE, boGE);
TBinaryExpr = class(TASTExpr)
@ -386,6 +400,22 @@ begin
inherited Destroy;
end;
{ TIsExpr }
destructor TIsExpr.Destroy;
begin
Obj.Free;
inherited Destroy;
end;
{ TAsExpr }
destructor TAsExpr.Destroy;
begin
Obj.Free;
inherited Destroy;
end;
{ TBinaryExpr }
destructor TBinaryExpr.Destroy;

110
compiler/src/main/pascal/uCodeGenQBE.pas
View file

@ -29,6 +29,7 @@ type
procedure EmitDataSection;
procedure EmitMainHeader;
procedure EmitMainFooter;
procedure EmitTypeInfoDefs(AProg: TProgram);
procedure EmitVTableDefs(AProg: TProgram);
procedure EmitMethodDefs(AProg: TProgram);
procedure EmitMethodDef(const ATypeName: string; AMethod: TMethodDecl);
@ -53,6 +54,8 @@ type
procedure EmitProcCall(ACall: TProcCall);
procedure EmitWrite(ACall: TProcCall; ANewline: Boolean);
function EmitExpr(AExpr: TASTExpr): string;
function EmitIsExpr(AExpr: TIsExpr): string;
function EmitAsExpr(AExpr: TAsExpr): string;
function FieldPtr(const ARecordVar: string; AOffset: Integer): string;
function QbeTypeOf(AType: TTypeDesc): string;
function QbeEscapeString(const AStr: string): string;
@ -626,19 +629,15 @@ begin
if MDecl.VTableSlot >= 0 then
begin
{ Virtual dispatch: load vptr from instance[0], then load fptr from vtable[slot] }
{ Virtual dispatch: load vptr from instance[0], then load fptr from vtable.
Slot 0 of vtable is typeinfo, so method N is at offset (N+1)*8. }
VTblTemp := AllocTemp;
EmitLine(Format(' %s =l loadl %s', [VTblTemp, SelfTemp]));
FPtrTemp := AllocTemp;
SlotOff := MDecl.VTableSlot * 8;
if SlotOff > 0 then
begin
ArgTemp := AllocTemp;
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
end
else
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, VTblTemp]));
SlotOff := (MDecl.VTableSlot + 1) * 8;
ArgTemp := AllocTemp;
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
EmitLine(Format(' call %%%s(%s)', [FPtrTemp, ArgLine]));
end
else
@ -754,7 +753,35 @@ begin
EmitLine('');
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. }
var
I: Integer;
TD: TTypeDecl;
TDesc: TTypeDesc;
RT: TRecordTypeDesc;
begin
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
begin
TD := TTypeDecl(AProg.Block.TypeDecls[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := AProg.SymbolTable.FindType(TD.Name);
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 + ' }')
else
EmitLine('data $typeinfo_' + TD.Name + ' = { l 0 }');
end;
EmitLine('');
end;
procedure TCodeGenQBE.EmitVTableDefs(AProg: TProgram);
{ Vtable layout: slot 0 = $typeinfo_T pointer, slots 1..N = virtual method ptrs.
Dispatch uses (VTableSlot + 1) * 8 to skip the typeinfo slot. }
var
I, S: Integer;
TD: TTypeDecl;
@ -771,12 +798,12 @@ begin
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
if not RT.HasVTable then Continue;
Line := 'data $vtable_' + TD.Name + ' = {';
{ TypeInfo pointer is always the first vtable entry }
Line := 'data $vtable_' + TD.Name + ' = { l $typeinfo_' + TD.Name;
for S := 0 to RT.VTableCount - 1 do
begin
E := RT.VTableEntryAt(S);
if S > 0 then Line := Line + ',';
Line := Line + ' l ' + E.ImplName;
E := RT.VTableEntryAt(S);
Line := Line + ', l ' + E.ImplName;
end;
Line := Line + ' }';
EmitLine(Line);
@ -1227,10 +1254,64 @@ begin
end;
Result := T;
end
else if AExpr is TIsExpr then
Result := EmitIsExpr(TIsExpr(AExpr))
else if AExpr is TAsExpr then
Result := EmitAsExpr(TAsExpr(AExpr))
else
raise ECodeGenError.Create('Unknown expression node type');
end;
function TCodeGenQBE.EmitIsExpr(AExpr: TIsExpr): string;
var
ObjTemp: string;
ResTemp: string;
begin
ObjTemp := EmitExpr(AExpr.Obj);
ResTemp := AllocTemp;
EmitLine(Format(' %s =w call $_IsInstance(l %s, l $typeinfo_%s)',
[ResTemp, ObjTemp, AExpr.TypeName]));
Result := ResTemp;
end;
function TCodeGenQBE.EmitAsExpr(AExpr: TAsExpr): string;
var
ObjTemp: string;
OkTemp: string;
SlotTemp: string;
ResTemp: string;
LblOk: string;
LblFail: string;
LblEnd: string;
begin
ObjTemp := EmitExpr(AExpr.Obj);
SlotTemp := AllocTemp;
EmitLine(Format(' %s =l alloc8 1', [SlotTemp]));
OkTemp := AllocTemp;
LblOk := AllocLabel('as_ok');
LblFail := AllocLabel('as_fail');
LblEnd := AllocLabel('as_end');
EmitLine(Format(' %s =w call $_IsInstance(l %s, l $typeinfo_%s)',
[OkTemp, ObjTemp, AExpr.TypeName]));
EmitLine(Format(' jnz %s, @%s, @%s', [OkTemp, LblOk, LblFail]));
EmitLine('@' + LblFail);
EmitLine(' call $_Raise_InvalidCast()');
EmitLine(Format(' storel 0, %s', [SlotTemp])); { unreachable; satisfies SSA }
EmitLine(Format(' jmp @%s', [LblEnd]));
EmitLine('@' + LblOk);
EmitLine(Format(' storel %s, %s', [ObjTemp, SlotTemp]));
EmitLine(Format(' jmp @%s', [LblEnd]));
EmitLine('@' + LblEnd);
ResTemp := AllocTemp;
EmitLine(Format(' %s =l loadl %s', [ResTemp, SlotTemp]));
Result := ResTemp;
end;
function TCodeGenQBE.QbeEscapeString(const AStr: string): string;
var
I: Integer;
@ -1282,6 +1363,7 @@ begin
EmitLine('# Source: ' + AProg.Name);
EmitLine('');
EmitDataSection;
EmitTypeInfoDefs(AProg);
EmitVTableDefs(AProg);
FOutput.AddStrings(Body);
finally

4
compiler/src/main/pascal/uLexer.pas
View file

@ -46,6 +46,8 @@ type
tkImplementation,
tkVirtual,
tkOverride,
tkIs,
tkAs,
{ Identifier }
tkIdent,
{ Arithmetic operators }
@ -135,6 +137,8 @@ begin
else if AUpper = 'IMPLEMENTATION' then Result := tkImplementation
else if AUpper = 'VIRTUAL' then Result := tkVirtual
else if AUpper = 'OVERRIDE' then Result := tkOverride
else if AUpper = 'IS' then Result := tkIs
else if AUpper = 'AS' then Result := tkAs
else
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
end;

20
compiler/src/main/pascal/uParser.pas
View file

@ -961,6 +961,8 @@ var
Right: TASTExpr;
CmpOp: TBinaryOp;
Node: TBinaryExpr;
IsNode: TIsExpr;
AsNode: TAsExpr;
begin
Result := ParseAddSub;
@ -982,6 +984,24 @@ begin
Node.Left := Result;
Node.Right := Right;
Result := Node;
end
else if Check(tkIs) then
begin
Advance;
IsNode := TIsExpr.Create;
IsNode.Obj := Result;
IsNode.TypeName := FCurrent.Value;
Expect(tkIdent);
Result := IsNode;
end
else if Check(tkAs) then
begin
Advance;
AsNode := TAsExpr.Create;
AsNode.Obj := Result;
AsNode.TypeName := FCurrent.Value;
Expect(tkIdent);
Result := AsNode;
end;
end;

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

@ -45,6 +45,8 @@ type
function AnalyseExpr(AExpr: TASTExpr): TTypeDesc;
function AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc;
function AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc;
function AnalyseIsExpr(AExpr: TIsExpr): TTypeDesc;
function AnalyseAsExpr(AExpr: TAsExpr): TTypeDesc;
procedure AnalyseCompoundBody(ABody: TCompoundStmt);
function FindMethodDecl(const ATypeName, AMethodName: string): TMethodDecl;
@ -1111,6 +1113,10 @@ begin
Result := AnalyseFieldAccess(TFieldAccessExpr(AExpr))
else if AExpr is TBinaryExpr then
Result := AnalyseBinaryExpr(TBinaryExpr(AExpr))
else if AExpr is TIsExpr then
Result := AnalyseIsExpr(TIsExpr(AExpr))
else if AExpr is TAsExpr then
Result := AnalyseAsExpr(TAsExpr(AExpr))
else
SemanticError('Unknown expression node', AExpr.Line, AExpr.Col);
@ -1216,4 +1222,48 @@ begin
end;
end;
function TSemanticAnalyser.AnalyseIsExpr(AExpr: TIsExpr): TTypeDesc;
var
ObjType: TTypeDesc;
TargetType: TTypeDesc;
begin
ObjType := AnalyseExpr(AExpr.Obj);
if ObjType.Kind <> tyClass then
SemanticError(
Format('''is'' requires a class instance on the left, got ''%s''',
[ObjType.Name]),
AExpr.Line, AExpr.Col);
TargetType := FTable.FindType(AExpr.TypeName);
if (TargetType = nil) or (TargetType.Kind <> tyClass) then
SemanticError(
Format('''is'' requires a class type name on the right, got ''%s''',
[AExpr.TypeName]),
AExpr.Line, AExpr.Col);
Result := FTable.TypeBoolean;
end;
function TSemanticAnalyser.AnalyseAsExpr(AExpr: TAsExpr): TTypeDesc;
var
ObjType: TTypeDesc;
TargetType: TTypeDesc;
begin
ObjType := AnalyseExpr(AExpr.Obj);
if ObjType.Kind <> tyClass then
SemanticError(
Format('''as'' requires a class instance on the left, got ''%s''',
[ObjType.Name]),
AExpr.Line, AExpr.Col);
TargetType := FTable.FindType(AExpr.TypeName);
if (TargetType = nil) or (TargetType.Kind <> tyClass) then
SemanticError(
Format('''as'' requires a class type name on the right, got ''%s''',
[AExpr.TypeName]),
AExpr.Line, AExpr.Col);
Result := TargetType;
end;
end.

3
compiler/src/test/pascal/TestRunner.pas
View file

@ -27,7 +27,8 @@ uses
cp.test.exceptions,
cp.test.units,
cp.test.varparams,
cp.test.vtable;
cp.test.vtable,
cp.test.typetests;
var
Application: TTestRunner;

385
compiler/src/test/pascal/cp.test.typetests.pas Normal file
View file

@ -0,0 +1,385 @@
unit cp.test.typetests;
{$mode objfpc}{$H+}
{ Tests for the 'is' and 'as' type-test operators. }
interface
uses
Classes, SysUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TTypeTestTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
published
{ ------------------------------------------------------------------ }
{ Lexer }
{ ------------------------------------------------------------------ }
procedure TestLexer_Is_Keyword;
procedure TestLexer_As_Keyword;
{ ------------------------------------------------------------------ }
{ Parser — is }
{ ------------------------------------------------------------------ }
procedure TestParse_IsExpr_NodeKind;
procedure TestParse_IsExpr_TypeName;
{ ------------------------------------------------------------------ }
{ Parser — as }
{ ------------------------------------------------------------------ }
procedure TestParse_AsExpr_NodeKind;
procedure TestParse_AsExpr_TypeName;
{ ------------------------------------------------------------------ }
{ Semantic }
{ ------------------------------------------------------------------ }
procedure TestSemantic_IsExpr_ClassInstance_OK;
procedure TestSemantic_IsExpr_ResultIsBoolean;
procedure TestSemantic_IsExpr_NonClass_RaisesError;
procedure TestSemantic_AsExpr_ClassInstance_OK;
procedure TestSemantic_AsExpr_ResultType_IsTargetClass;
procedure TestSemantic_AsExpr_NonClass_RaisesError;
{ ------------------------------------------------------------------ }
{ Codegen — typeinfo data sections }
{ ------------------------------------------------------------------ }
procedure TestCodegen_TypeInfo_Emitted;
procedure TestCodegen_TypeInfo_ParentPtr_IsZero_ForRoot;
procedure TestCodegen_TypeInfo_ParentPtr_ForDerived;
procedure TestCodegen_Vtable_StartsWithTypeInfo;
{ ------------------------------------------------------------------ }
{ Codegen — is / as expressions }
{ ------------------------------------------------------------------ }
procedure TestCodegen_IsExpr_CallsIsInstance;
procedure TestCodegen_IsExpr_PassesTypeInfoLabel;
procedure TestCodegen_AsExpr_CallsIsInstance;
procedure TestCodegen_AsExpr_CallsRaiseOnFail;
end;
implementation
{ ------------------------------------------------------------------ }
{ Shared source snippets }
{ ------------------------------------------------------------------ }
const
{ Base class with one virtual method — has a vtable/vptr }
SrcBase =
'program P;' + LineEnding +
'type' + LineEnding +
' TAnimal = class' + LineEnding +
' procedure Speak; virtual; begin end;' + LineEnding +
' end;' + LineEnding +
'var A: TAnimal;' + LineEnding +
' R: Boolean;' + LineEnding +
'begin' + LineEnding +
' A := TAnimal.Create;' + LineEnding +
' R := A is TAnimal' + LineEnding +
'end.';
SrcInherit =
'program P;' + LineEnding +
'type' + LineEnding +
' TAnimal = class' + LineEnding +
' procedure Speak; virtual; begin end;' + LineEnding +
' end;' + LineEnding +
' TDog = class(TAnimal)' + LineEnding +
' procedure Speak; override; begin end;' + LineEnding +
' end;' + LineEnding +
'var A: TAnimal;' + LineEnding +
' D: TDog;' + LineEnding +
' R: Boolean;' + LineEnding +
'begin' + LineEnding +
' D := TDog.Create;' + LineEnding +
' A := D;' + LineEnding +
' R := A is TDog' + LineEnding +
'end.';
SrcAsExpr =
'program P;' + LineEnding +
'type' + LineEnding +
' TAnimal = class' + LineEnding +
' procedure Speak; virtual; begin end;' + LineEnding +
' end;' + LineEnding +
' TDog = class(TAnimal)' + LineEnding +
' procedure Speak; override; begin end;' + LineEnding +
' end;' + LineEnding +
'var A: TAnimal;' + LineEnding +
' D: TDog;' + LineEnding +
'begin' + LineEnding +
' A := TDog.Create;' + LineEnding +
' D := A as TDog' + LineEnding +
'end.';
{ ------------------------------------------------------------------ }
{ Helpers }
{ ------------------------------------------------------------------ }
function TTypeTestTests.ParseSrc(const ASrc: string): TProgram;
var L: TLexer; P: TParser;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Result := P.Parse;
finally
P.Free; L.Free;
end;
end;
function TTypeTestTests.AnalyseSrc(const ASrc: string): TProgram;
var A: TSemanticAnalyser;
begin
Result := ParseSrc(ASrc);
A := TSemanticAnalyser.Create;
try
A.Analyse(Result);
finally
A.Free;
end;
end;
function TTypeTestTests.GenIR(const ASrc: string): string;
var Prog: TProgram; CG: TCodeGenQBE;
begin
Prog := AnalyseSrc(ASrc);
try
CG := TCodeGenQBE.Create;
try
CG.Generate(Prog);
Result := CG.GetOutput;
finally
CG.Free;
end;
finally
Prog.Free;
end;
end;
procedure TTypeTestTests.AnalyseExpectError(const ASrc: string);
var Prog: TProgram;
begin
try
Prog := AnalyseSrc(ASrc);
Prog.Free;
Fail('Expected ESemanticError');
except
on E: ESemanticError do ;
end;
end;
{ ------------------------------------------------------------------ }
{ Lexer tests }
{ ------------------------------------------------------------------ }
procedure TTypeTestTests.TestLexer_Is_Keyword;
var L: TLexer; T: TToken;
begin
L := TLexer.Create('is');
try
T := L.Next;
AssertEquals('is token', Ord(tkIs), Ord(T.Kind));
finally L.Free; end;
end;
procedure TTypeTestTests.TestLexer_As_Keyword;
var L: TLexer; T: TToken;
begin
L := TLexer.Create('as');
try
T := L.Next;
AssertEquals('as token', Ord(tkAs), Ord(T.Kind));
finally L.Free; end;
end;
{ ------------------------------------------------------------------ }
{ Parser — is }
{ ------------------------------------------------------------------ }
procedure TTypeTestTests.TestParse_IsExpr_NodeKind;
var Prog: TProgram; Stmt: TAssignment;
begin
Prog := ParseSrc(SrcBase);
try
Stmt := TAssignment(Prog.Block.Stmts[1]);
AssertTrue('is expr node kind', Stmt.Expr is TIsExpr);
finally Prog.Free; end;
end;
procedure TTypeTestTests.TestParse_IsExpr_TypeName;
var Prog: TProgram; IE: TIsExpr;
begin
Prog := ParseSrc(SrcBase);
try
IE := TIsExpr(TAssignment(Prog.Block.Stmts[1]).Expr);
AssertEquals('is type name', 'TAnimal', IE.TypeName);
finally Prog.Free; end;
end;
{ ------------------------------------------------------------------ }
{ Parser — as }
{ ------------------------------------------------------------------ }
procedure TTypeTestTests.TestParse_AsExpr_NodeKind;
var Prog: TProgram; Stmt: TAssignment;
begin
Prog := ParseSrc(SrcAsExpr);
try
Stmt := TAssignment(Prog.Block.Stmts[1]);
AssertTrue('as expr node kind', Stmt.Expr is TAsExpr);
finally Prog.Free; end;
end;
procedure TTypeTestTests.TestParse_AsExpr_TypeName;
var Prog: TProgram; AE: TAsExpr;
begin
Prog := ParseSrc(SrcAsExpr);
try
AE := TAsExpr(TAssignment(Prog.Block.Stmts[1]).Expr);
AssertEquals('as type name', 'TDog', AE.TypeName);
finally Prog.Free; end;
end;
{ ------------------------------------------------------------------ }
{ Semantic tests }
{ ------------------------------------------------------------------ }
procedure TTypeTestTests.TestSemantic_IsExpr_ClassInstance_OK;
begin
AnalyseSrc(SrcBase).Free;
end;
procedure TTypeTestTests.TestSemantic_IsExpr_ResultIsBoolean;
var Prog: TProgram; IE: TIsExpr;
begin
Prog := AnalyseSrc(SrcBase);
try
IE := TIsExpr(TAssignment(Prog.Block.Stmts[1]).Expr);
AssertNotNull('is-expr resolved type', IE.ResolvedType);
AssertEquals('is-expr result is Boolean', Ord(tyBoolean), Ord(IE.ResolvedType.Kind));
finally Prog.Free; end;
end;
procedure TTypeTestTests.TestSemantic_IsExpr_NonClass_RaisesError;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'var X: Integer;' + LineEnding +
' R: Boolean;' + LineEnding +
'begin' + LineEnding +
' R := X is Integer' + LineEnding +
'end.');
end;
procedure TTypeTestTests.TestSemantic_AsExpr_ClassInstance_OK;
begin
AnalyseSrc(SrcAsExpr).Free;
end;
procedure TTypeTestTests.TestSemantic_AsExpr_ResultType_IsTargetClass;
var Prog: TProgram; AE: TAsExpr;
begin
Prog := AnalyseSrc(SrcAsExpr);
try
AE := TAsExpr(TAssignment(Prog.Block.Stmts[1]).Expr);
AssertNotNull('as-expr resolved type', AE.ResolvedType);
AssertEquals('as-expr result is target class', 'TDog', AE.ResolvedType.Name);
finally Prog.Free; end;
end;
procedure TTypeTestTests.TestSemantic_AsExpr_NonClass_RaisesError;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'var X: Integer;' + LineEnding +
' Y: Integer;' + LineEnding +
'begin' + LineEnding +
' Y := X as Integer' + LineEnding +
'end.');
end;
{ ------------------------------------------------------------------ }
{ Codegen — typeinfo data sections }
{ ------------------------------------------------------------------ }
procedure TTypeTestTests.TestCodegen_TypeInfo_Emitted;
var IR: string;
begin
IR := GenIR(SrcBase);
AssertTrue('typeinfo data section emitted',
Pos('data $typeinfo_TAnimal', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_TypeInfo_ParentPtr_IsZero_ForRoot;
var IR: string;
begin
{ Root class (no parent) must have parent pointer = 0 }
IR := GenIR(SrcBase);
AssertTrue('root typeinfo has zero parent ptr',
Pos('$typeinfo_TAnimal = { l 0 }', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_TypeInfo_ParentPtr_ForDerived;
var IR: string;
begin
{ Derived class typeinfo must reference parent typeinfo }
IR := GenIR(SrcInherit);
AssertTrue('derived typeinfo refs parent',
Pos('$typeinfo_TDog = { l $typeinfo_TAnimal }', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_Vtable_StartsWithTypeInfo;
var IR: string;
begin
{ Vtable first slot must be the typeinfo pointer }
IR := GenIR(SrcBase);
AssertTrue('vtable starts with typeinfo',
Pos('$vtable_TAnimal = { l $typeinfo_TAnimal', IR) > 0);
end;
{ ------------------------------------------------------------------ }
{ Codegen — is / as expressions }
{ ------------------------------------------------------------------ }
procedure TTypeTestTests.TestCodegen_IsExpr_CallsIsInstance;
var IR: string;
begin
IR := GenIR(SrcBase);
AssertTrue('is calls _IsInstance', Pos('call $_IsInstance', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_IsExpr_PassesTypeInfoLabel;
var IR: string;
begin
IR := GenIR(SrcBase);
{ The call must pass $typeinfo_TAnimal as the target type argument }
AssertTrue('is passes typeinfo label',
Pos('$typeinfo_TAnimal', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_AsExpr_CallsIsInstance;
var IR: string;
begin
IR := GenIR(SrcAsExpr);
AssertTrue('as calls _IsInstance', Pos('call $_IsInstance', IR) > 0);
end;
procedure TTypeTestTests.TestCodegen_AsExpr_CallsRaiseOnFail;
var IR: string;
begin
IR := GenIR(SrcAsExpr);
AssertTrue('as calls _Raise_InvalidCast on fail',
Pos('call $_Raise_InvalidCast', IR) > 0);
end;
initialization
RegisterTest(TTypeTestTests);
end.

40
rtl/src/main/c/blaise_exc.c
View file

@ -77,3 +77,43 @@ void* _CurrentException(void) {
void _Reraise(void* exc) {
_Raise(exc);
}
/* -----------------------------------------------------------------------
* Type identity — is / as operators
* ----------------------------------------------------------------------- */
/*
* BlaiseTypeInfo — one per class, stored as vtable slot 0.
* parent = pointer to parent class TypeInfo, or NULL for root classes.
*/
typedef struct BlaiseTypeInfo {
const struct BlaiseTypeInfo* parent;
} BlaiseTypeInfo;
/*
* _IsInstance — runtime 'is' check.
* 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.
*/
int _IsInstance(void* obj, const BlaiseTypeInfo* target) {
const BlaiseTypeInfo* ti;
void** vtable;
if (!obj || !target) return 0;
vtable = *(void***)obj; /* obj[0] = vptr */
ti = (const BlaiseTypeInfo*)vtable[0]; /* vtable[0] = typeinfo */
while (ti) {
if (ti == target) return 1;
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();
}