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

feat(lang): ClassCreate(Cls, ...args) builtin for runtime construction

Browse source 
Step 11e, part 3.  New compiler builtin that constructs an instance
from a metaclass value at runtime.  Lowers to:

  %p =l call $_ClassCreate(l <classvalue>)
  call $<BaseClass>_Create(l %p, args...)
  result = %p

The first argument must be tyMetaClass; remaining args are forwarded
to the resolved constructor.  Result type is the metaclass's BaseClass,
so 'F := ClassCreate(C, 7)' is well-typed when C: class of TFoo and
F: TFoo.  The constructor lookup is currently by name 'Create' (no
overload resolution yet — fpcunit's Create(string) and TObject's
parameter-less Create are the only shapes the bcl.testing runner
needs).  When the resolved class declares no Create method, only
the alloc call is emitted; fields stay in their _ClassAlloc-zeroed
default state.

This is the missing half that makes 'class of TTestCase' useful: the
runner (Step 11e, part 4) will iterate the published-method table
of each registered test class and call ClassCreate(Cls, MethodName)
to instantiate one TTestCase per test method, exactly the shape
fpcunit's class-method 'Suite' produces.

Symbol table: 'ClassCreate' added as skFunction in uSymbolTable.pas
              (return type filled in semantically).
Semantic   : AnalyseFuncCallExpr handles SameText('ClassCreate') —
              validates first arg is metaclass, analyses remaining
              args, resolves Create on BaseClass, stores it on
              ResolvedDecl, returns BaseClass as result type.
Codegen    : EmitExpr handles SameText('ClassCreate') — emits the
              two-call sequence above; reuses the ConstructorCall
              arg-coercion pattern (CoerceArg).

Three regression tests added to cp.test.classof.pas:
  TestSemantic_ClassCreate_RejectsNonMetaclassFirstArg
  TestCodegen_ClassCreate_EmitsAllocAndCtorCall
  TestCodegen_ClassCreate_NoCtor_OnlyAllocCalled

Verified end-to-end: ClassCreate(TCounter, 100); .Bump; .Bump;
prints 102 — argument flowed through the constructor, the instance
runs methods, and Free cleans up correctly.

All 1238 tests pass (1235 prior + 3 new).
This commit is contained in:
Graeme Geldenhuys 2026-05-06 07:36:00 +01:00
parent 113baa71f3
commit 1fb2648f66
4 changed files with 126 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -4200,6 +4200,35 @@ begin
Exit;
end;
{ ClassCreate(Cls, ...args): runtime equivalent of TFoo.Create(args).
Allocates via _ClassCreate (which reads totalsize/fieldcleanup/vtable
from Cls's typeinfo), then calls $<BaseClass>_Create statically with
the new pointer and the supplied args. Returns the new pointer. }
if SameText(FC.Name,'ClassCreate') then
begin
L := EmitExpr(TASTExpr(FC.Args.Items[0])); { metaclass = typeinfo ptr }
T := AllocTemp;
EmitLine(Format(' %s =l call $_ClassCreate(l %s)', [T, L]));
if FC.ResolvedDecl <> nil then
begin
MDecl := TMethodDecl(FC.ResolvedDecl);
ArgLine := Format('l %s', [T]);
for I := 1 to FC.Args.Count - 1 do
begin
Par := TMethodParam(MDecl.Params.Items[I - 1]);
ArgTemp := EmitExpr(TASTExpr(FC.Args.Items[I]));
ArgTemp := CoerceArg(ArgTemp, TASTExpr(FC.Args.Items[I]),
QbeTypeOf(Par.ResolvedType));
ArgLine := ArgLine + Format(', %s %s',
[QbeTypeOf(Par.ResolvedType), ArgTemp]);
end;
EmitLine(Format(' call $%s(%s)',
[MethodEmitName(MDecl, MDecl.OwnerTypeName, 'Create'), ArgLine]));
end;
Result := T;
Exit;
end;
if SameText(FC.Name,'StrToInt64') then
begin
L := EmitExpr(TASTExpr(FC.Args.Items[0]));

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

@ -4536,6 +4536,33 @@ begin
Exit;
end;
{ ClassCreate(Cls, ...args): runtime construction from a metaclass.
Resolves the constructor on Cls.BaseClass with the supplied args
and stores the TMethodDecl on AExpr.ResolvedDecl. Codegen lowers
this to '%p = call $_ClassCreate(l <classvalue>); call $T_Create(l %p, args...)'.
Result type is the BaseClass — assigning to a 'var T: TFoo' is
well-typed when Cls: class of TFoo. }
if SameText(AExpr.Name, 'ClassCreate') then
begin
if AExpr.Args.Count < 1 then
SemanticError('ClassCreate requires a metaclass as the first argument',
AExpr.Line, AExpr.Col);
AnalyseExpr(TASTExpr(AExpr.Args.Items[0]));
if (TASTExpr(AExpr.Args.Items[0]).ResolvedType = nil) or
(TASTExpr(AExpr.Args.Items[0]).ResolvedType.Kind <> tyMetaClass) then
SemanticError('ClassCreate: first argument must be a metaclass (class of T) value',
AExpr.Line, AExpr.Col);
{ Analyse remaining args before resolving the constructor — argument
types feed FindMethodDecl when we add overload resolution; for v0
we look up 'Create' by name and trust uniqueness. }
for I := 1 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
Result := TMetaClassTypeDesc(TASTExpr(AExpr.Args.Items[0]).ResolvedType).BaseClass;
AExpr.ResolvedType := Result;
AExpr.ResolvedDecl := FindMethodDecl(Result.Name, 'Create');
Exit;
end;
if SameText(AExpr.Name, 'Format') then
begin
if AExpr.Args.Count < 1 then

5
compiler/src/main/pascal/uSymbolTable.pas
View file

@ -1169,6 +1169,11 @@ begin
Sym := TSymbol.Create('Abs', skFunction, FTypeInteger); Define(Sym);
{ MethodAddress(Obj, Name) — published-method lookup via typeinfo chain }
Sym := TSymbol.Create('MethodAddress', skFunction, FTypePointer); Define(Sym);
{ ClassCreate(Cls, ...args) — runtime construction from a metaclass value.
Calls _ClassCreate to allocate + install vtable, then invokes the
constructor on Cls.BaseClass with the supplied args. Result type is
the BaseClass; resolved by AnalyseFuncCallExpr in uSemantic. }
Sym := TSymbol.Create('ClassCreate', skFunction, FTypePointer); Define(Sym);
{ Inc/Dec — in-place increment/decrement (var param, 1 or 2 args) }
Sym := TSymbol.Create('Inc', skProcedure, nil); Define(Sym);
Sym := TSymbol.Create('Dec', skProcedure, nil); Define(Sym);

65
compiler/src/test/pascal/cp.test.classof.pas
View file

@ -45,6 +45,13 @@ type
procedure TestCodegen_ClassIdent_EmitsTypeinfo;
procedure TestCodegen_MetaClassVar_StorelTypeinfo;
procedure TestCodegen_MetaClassEquality_UsesCEQL;
{ ClassCreate builtin (Step 11e): runtime construction via a
metaclass value. Lowers to '_ClassCreate(Cls)' followed by a
static call to the resolved constructor. }
procedure TestSemantic_ClassCreate_RejectsNonMetaclassFirstArg;
procedure TestCodegen_ClassCreate_EmitsAllocAndCtorCall;
procedure TestCodegen_ClassCreate_NoCtor_OnlyAllocCalled;
end;
implementation
@ -381,6 +388,64 @@ begin
Pos('ceql', IR) > 0);
end;
{ ------------------------------------------------------------------ }
{ ClassCreate builtin }
{ ------------------------------------------------------------------ }
procedure TClassOfTests.TestSemantic_ClassCreate_RejectsNonMetaclassFirstArg;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'type TFoo = class(TObject) end;' + LineEnding +
'var F: TFoo;' + LineEnding +
'begin' + LineEnding +
' F := ClassCreate(F)' + LineEnding +
'end.'
);
end;
procedure TClassOfTests.TestCodegen_ClassCreate_EmitsAllocAndCtorCall;
const
Src =
'program P;' + LineEnding +
'type' + LineEnding +
' TFoo = class(TObject)' + LineEnding +
' Value: Integer;' + LineEnding +
' constructor Create(N: Integer);' + LineEnding +
' end;' + LineEnding +
'constructor TFoo.Create(N: Integer);' + LineEnding +
'begin Self.Value := N end;' + LineEnding +
'var C: class of TFoo; F: TFoo;' + LineEnding +
'begin' + LineEnding +
' C := TFoo;' + LineEnding +
' F := ClassCreate(C, 7)' + LineEnding +
'end.';
var IR: string;
begin
IR := GenIR(Src);
AssertTrue('emits call to $_ClassCreate', Pos('call $_ClassCreate(', IR) > 0);
AssertTrue('emits static call to TFoo_Create after alloc',
Pos('call $TFoo_Create(', IR) > 0);
end;
procedure TClassOfTests.TestCodegen_ClassCreate_NoCtor_OnlyAllocCalled;
const
Src =
'program P;' + LineEnding +
'type TFoo = class(TObject) end;' + LineEnding +
'var C: class of TFoo; F: TFoo;' + LineEnding +
'begin' + LineEnding +
' C := TFoo;' + LineEnding +
' F := ClassCreate(C)' + LineEnding +
'end.';
var IR: string;
begin
IR := GenIR(Src);
AssertTrue('emits call to $_ClassCreate', Pos('call $_ClassCreate(', IR) > 0);
AssertEquals('no constructor call emitted when class declares none',
0, Pos('TFoo_Create', IR));
end;
initialization
RegisterTest(TClassOfTests);
end.