From 62026fb00a01cbbbedd8e2f48784bc187a578250 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 21 Apr 2026 14:45:21 +0100 Subject: [PATCH] Add is/as type-test operators with runtime typeinfo dispatch - 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 --- compiler/src/main/pascal/uAST.pas | 30 ++ compiler/src/main/pascal/uCodeGenQBE.pas | 110 ++++- compiler/src/main/pascal/uLexer.pas | 4 + compiler/src/main/pascal/uParser.pas | 20 + compiler/src/main/pascal/uSemantic.pas | 50 +++ compiler/src/test/pascal/TestRunner.pas | 3 +- .../src/test/pascal/cp.test.typetests.pas | 385 ++++++++++++++++++ rtl/src/main/c/blaise_exc.c | 40 ++ 8 files changed, 627 insertions(+), 15 deletions(-) create mode 100644 compiler/src/test/pascal/cp.test.typetests.pas diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index d238496..b8c554a 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 7df8642..f55f962 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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 diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas index caa43dd..ce8311b 100644 --- a/compiler/src/main/pascal/uLexer.pas +++ b/compiler/src/main/pascal/uLexer.pas @@ -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; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 9f9b913..e2d14f3 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index e8f3828..b1a0269 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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. diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index 925514c..97cbc23 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.typetests.pas b/compiler/src/test/pascal/cp.test.typetests.pas new file mode 100644 index 0000000..711434f --- /dev/null +++ b/compiler/src/test/pascal/cp.test.typetests.pas @@ -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. diff --git a/rtl/src/main/c/blaise_exc.c b/rtl/src/main/c/blaise_exc.c index d9415cd..adad2e4 100644 --- a/rtl/src/main/c/blaise_exc.c +++ b/rtl/src/main/c/blaise_exc.c @@ -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(); +}