diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index 46348d8..fc70347 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -1925,6 +1925,7 @@ var ParentStr: string; ImplStr: string; MethStr: string; + AttrsStr: string; PubCount: Integer; Line: string; EmitSys: Boolean; @@ -2060,6 +2061,24 @@ begin else MethStr := '0'; + { Class attribute RTTI table at typeinfo slot 7: a count word followed by + one typeinfo pointer per attribute. Referenced by _HasClassAttribute. + Emitted before the typeinfo so the symbol is defined when slot 7 + references it; nil when the class carries no attributes. Mirrors the + QBE backend's attrs_. } + if RT.ClassAttributeCount() > 0 then + begin + Self.Emit('.balign 8'); + Self.Emit('attrs_' + CSym + ':'); + Self.Emit(Format(#9'.quad %d', [RT.ClassAttributeCount()])); + for J := 0 to RT.ClassAttributeCount() - 1 do + Self.Emit(#9'.quad typeinfo_' + + Self.ClassSymName(RT.ClassAttributeAt(J))); + AttrsStr := 'attrs_' + CSym; + end + else + AttrsStr := '0'; + Self.Emit('.balign 8'); Self.Emit('.globl typeinfo_' + CSym); Self.Emit('typeinfo_' + CSym + ':'); @@ -2070,7 +2089,7 @@ begin Self.Emit(Format(#9'.quad %d', [RT.TotalSize()])); Self.Emit(#9'.quad _FieldCleanup_' + CSym); Self.Emit(#9'.quad vtable_' + CSym); - Self.Emit(#9'.quad 0'); { attrs } + Self.Emit(#9'.quad ' + AttrsStr); { attrs } end; { Typeinfo blocks for generic class instances. } @@ -5332,6 +5351,24 @@ begin { Result = method code pointer in %rax. } Exit; end; + { HasClassAttribute(AClass, AAttrClass): Boolean — query attribute RTTI. + Both args are metaclass expressions that lower to typeinfo pointers. + Pass them in %rdi/%rsi and call the runtime helper (result in %al). + Without this the native backend never emitted the call — the result + was the low byte of the first metaclass's typeinfo address, a layout- + dependent false positive. } + if FC.IsBuiltinHasClassAttr and (FC.Args.Count = 2) then + begin + Self.EmitExprToEax(TASTExpr(FC.Args.Items[0])); { ti_class -> %rax } + Self.Emit(#9'pushq %rax'); + Self.EmitExprToEax(TASTExpr(FC.Args.Items[1])); { ti_attr -> %rax } + Self.Emit(#9'movq %rax, %rsi'); + Self.Emit(#9'popq %rdi'); + Self.Emit(#9'callq _HasClassAttribute'); + { Result Boolean in %al; normalise to a clean 0/1 in %rax. } + Self.Emit(#9'movzbq %al, %rax'); + Exit; + end; { SizeOf(expr) → integer literal = byte size of the resolved type. } if SameText(FC.Name, 'SizeOf') and (FC.Args.Count = 1) then begin diff --git a/compiler/src/test/pascal/cp.test.e2e.gaps.pas b/compiler/src/test/pascal/cp.test.e2e.gaps.pas index ede5a19..948bc6b 100644 --- a/compiler/src/test/pascal/cp.test.e2e.gaps.pas +++ b/compiler/src/test/pascal/cp.test.e2e.gaps.pas @@ -58,6 +58,12 @@ type { Published RTTI + MethodAddress } procedure TestRun_PublishedRTTI_MethodAddress; + { HasClassAttribute attribute RTTI query: a plain class reports False, a + [Threaded]-marked class reports True. Regression: the native backend + emitted no call (result = low byte of the metaclass address, a false + positive) and emitted no attribute table in typeinfo. } + procedure TestRun_HasClassAttribute_PlainAndMarked; + { Named-type alias array const (GitHub #113) } procedure TestRun_NamedArrayAlias_IntConst; @@ -646,6 +652,26 @@ begin AssertRunsOnAll(Src, 'found' + Chr(10), 0); end; +procedure TE2EGapTests.TestRun_HasClassAttribute_PlainAndMarked; +const Src = ''' + program T; + uses blaise.testing; + type + TPlain = class(TTestCase) published procedure M; end; + [Threaded] + TMarked = class(TTestCase) published procedure M; end; + procedure TPlain.M; begin end; + procedure TMarked.M; begin end; + begin + WriteLn(HasClassAttribute(TPlain, ThreadedAttribute)); + WriteLn(HasClassAttribute(TMarked, ThreadedAttribute)) + end. + '''; +begin + { Uses blaise.testing (stdlib), so the RTL+stdlib search-path helper. } + AssertRTLRunsOnAll(Src, 'False' + Chr(10) + 'True' + Chr(10), 0); +end; + { ---- Multi-arg WriteLn ---- } procedure TE2EGapTests.TestRun_StaticArrayReturn_12Bytes; diff --git a/compiler/src/main/pascal/blaise.testing.pas b/stdlib/src/main/pascal/blaise.testing.pas similarity index 100% rename from compiler/src/main/pascal/blaise.testing.pas rename to stdlib/src/main/pascal/blaise.testing.pas diff --git a/compiler/src/main/pascal/blaise.testing.runner.text.pas b/stdlib/src/main/pascal/blaise.testing.runner.text.pas similarity index 100% rename from compiler/src/main/pascal/blaise.testing.runner.text.pas rename to stdlib/src/main/pascal/blaise.testing.runner.text.pas