2293 lines
68 KiB
ObjectPascal
2293 lines
68 KiB
ObjectPascal
{
|
|
Blaise - An Object Pascal Compiler
|
|
Copyright (c) 2026 Graeme Geldenhuys
|
|
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
|
|
Licensed under the Apache License v2.0 with Runtime Library Exception.
|
|
See LICENSE file in the project root for full license terms.
|
|
}
|
|
|
|
unit cp.test.e2e.classes2;
|
|
|
|
{ E2E tests for class features: milestone programs, multi-type blocks,
|
|
ToString, InheritsFrom, is/as, inheritance, interfaces, and Supports. }
|
|
|
|
interface
|
|
|
|
uses
|
|
blaise.testing, classes, sysutils, cp.test.e2e.base;
|
|
|
|
type
|
|
[Threaded]
|
|
TE2EClasses2Tests = class(TE2ETestCase)
|
|
protected
|
|
procedure SetUp; override;
|
|
published
|
|
procedure TestRun_Phase2Milestone_Stdout;
|
|
procedure TestRun_Phase2Milestone_Valgrind;
|
|
procedure TestRun_Phase3Milestone_Stdout;
|
|
procedure TestRun_Phase3Milestone_Valgrind;
|
|
procedure TestRun_MultiTypeBlock_BothClassesWork;
|
|
procedure TestRun_ToString_DefaultReturnsClassName;
|
|
procedure TestRun_ToString_OverrideDispatchedVirtually;
|
|
procedure TestRun_ToString_InheritedOverrideStillReached;
|
|
procedure TestRun_InheritsFrom_SameClass_ReturnsTrue;
|
|
procedure TestRun_InheritsFrom_Parent_ReturnsTrue;
|
|
procedure TestRun_InheritsFrom_GrandParent_ReturnsTrue;
|
|
procedure TestRun_InheritsFrom_Unrelated_ReturnsFalse;
|
|
procedure TestRun_InheritsFrom_Reverse_ReturnsFalse;
|
|
procedure TestRun_InheritsFrom_ClassType_Works;
|
|
procedure TestRun_Is_CorrectSubclass_True;
|
|
procedure TestRun_Is_WrongClass_False;
|
|
procedure TestRun_As_DowncastCallsMethod;
|
|
procedure TestRun_Inherited_CallsParentMethod;
|
|
{ inherited call whose Self + args exceed 6 integer registers must spill
|
|
the overflow args to the stack (native arg-register overflow). }
|
|
procedure TestRun_Inherited_ManyArgs_SpillsToStack;
|
|
procedure TestRun_Inherited_VarParam_PassesByReference;
|
|
procedure TestRun_Virtual_OverrideDispatch;
|
|
procedure TestRun_MultiLevel_Inheritance_Chain;
|
|
procedure TestRun_Interface_Dispatch_CallsImpl;
|
|
procedure TestRun_Interface_ARC_NoLeak;
|
|
procedure TestRun_Interface_GlobalNil_LinksAndRuns;
|
|
procedure TestRun_Interface_Is_As_Roundtrip;
|
|
procedure TestRun_Interface_MethodParam_ByValue_Dispatches;
|
|
procedure TestRun_Supports_TwoArg_BooleanResult;
|
|
procedure TestRun_Supports_ThreeArg_AssignsAndCalls;
|
|
procedure TestRun_ConstructorOverload_PicksCorrectArity;
|
|
{ Regression: native backend passed float args to methods/constructors via
|
|
integer registers instead of the SysV xmm registers — a literal crashed
|
|
codegen, a variable silently used the wrong register. }
|
|
procedure TestRun_MethodFloatArg_Literal_PassedInXmm;
|
|
procedure TestRun_MethodFloatArg_Variable_PassedInXmm;
|
|
procedure TestRun_ConstructorFloatArg_Literal_StoredCorrectly;
|
|
procedure TestRun_ConstructorFloatArg_Variable_StoredCorrectly;
|
|
procedure TestRun_MethodMixedIntFloatString_RegistersInterleave;
|
|
procedure TestRun_MethodMultipleFloats_UseXmm0AndXmm1;
|
|
{ >6-register-slot overflow path with float args: the integer args beyond
|
|
the 6 integer registers spill to the stack while floats still take xmm
|
|
registers, so the spill layout must classify by SysV class, not by
|
|
argument position. }
|
|
procedure TestRun_MethodOverflowFloatArgs_Pass;
|
|
procedure TestRun_ConstructorOverflowFloatArgs_Pass;
|
|
procedure TestRun_InheritedOverflowFloatArgs_Pass;
|
|
{ Regression: a virtual method called via implicit Self (unqualified
|
|
Foo(), no Self. prefix) must dispatch through the vtable, exactly as
|
|
Self.Foo() does — otherwise it binds the declaring class statically,
|
|
silently breaking polymorphism (and link-failing for an abstract base). }
|
|
procedure TestRun_ImplicitSelfVirtual_DispatchesOverride;
|
|
procedure TestRun_ImplicitSelfAbstractVirtual_LinksAndDispatches;
|
|
procedure TestRun_ImplicitSelfVirtual_NonVirtualStaysStatic;
|
|
procedure TestRun_ImplicitSelfVirtual_IntfReturn_Dispatches;
|
|
procedure TestRun_ImplicitSelfVirtual_RecordReturn_Dispatches;
|
|
procedure TestRun_MethodReadsProgramGlobal;
|
|
procedure TestRun_VarParam_ClassFields_WritebackVisible;
|
|
{ Name-resolution priority for unqualified calls inside a class
|
|
method. Adjacent-level distinctions, top wins:
|
|
1. local vars / parameters
|
|
2. implicit Self.member (incl. inherited via class chain)
|
|
3. program-level / uses-clause unit exports
|
|
Sub-distinctions inside level 2 (own vs parent), and level 3
|
|
(program vs uses-clause), depend on orthogonal mechanisms
|
|
(virtual dispatch; Blaise's duplicate-identifier rule for
|
|
program-level shadowing of unit exports). They're worth
|
|
pinning separately when their own bugs surface.
|
|
|
|
Cross-unit visibility (private skipped, protected accessible to
|
|
subclasses) is a follow-up commit. }
|
|
procedure TestRun_LocalVar_ShadowsOwnMethod;
|
|
procedure TestRun_ParentMethod_ShadowsProgramProc;
|
|
{ Explicit qualifiers are unambiguous paths — the priority order
|
|
does not apply. Self.X must hit a class member; inherited X
|
|
must hit a parent method. Neither falls through to unit-level. }
|
|
procedure TestRun_ExplicitSelf_AlwaysClassMember;
|
|
procedure TestRun_InheritedCall_AlwaysParent;
|
|
{ Regression (issue #64): interface-typed field with same name as a
|
|
program-level global of a different type. }
|
|
procedure TestRun_InterfaceField_ShadowsGlobal_Dispatches;
|
|
|
|
{ Regression for graemeg/blaise#111: a child class that inherits a
|
|
method-backed property must dispatch the getter/setter to the parent
|
|
that declares them, not to a never-emitted child-mangled symbol. }
|
|
procedure TestRun_InheritedProperty_AccessorsResolveToParent;
|
|
|
|
{ Class const accessed via the type name (TThing.MaxCount): native
|
|
backend lacked the IsConstant case (codegen error), QBE mis-emitted
|
|
string class consts (invalid IR + phantom _StringRetain). }
|
|
procedure TestRun_ClassConst_IntViaType;
|
|
procedure TestRun_ClassConst_StringViaType;
|
|
procedure TestRun_ClassConst_ViaInstanceAndType;
|
|
|
|
{ Interface properties: read/write through the interface variable. }
|
|
procedure TestRun_InterfaceProperty_ReadWrite;
|
|
{ Accessor names with non-declared casing must still link (symbols are
|
|
case-sensitive; Pascal resolution is not), and program-level classes
|
|
implementing interfaces must link when units are in the uses chain
|
|
(program-scope symbols carry no unit prefix). }
|
|
procedure TestRun_InterfaceProperty_CaseMismatchAndUses;
|
|
|
|
{ Statement-position method call through a non-Self interface field:
|
|
H.S.Note(); — expression position already worked. }
|
|
procedure TestRun_InterfaceFieldCall_StatementPosition;
|
|
|
|
{ var-param class: field reads/writes must double-deref (slot -> caller
|
|
var -> instance); single-deref corrupted the caller frame. }
|
|
procedure TestRun_VarParamClass_FieldReadWrite;
|
|
{ Nested proc with captured vars AND regular params: signature emission. }
|
|
procedure TestRun_NestedProc_CaptureAndParams;
|
|
{ var Double param (pointer arrives in an int register, not xmm) and
|
|
captured float read/write through the _cap_ slot. }
|
|
procedure TestRun_VarParamFloat_CapturedFloat;
|
|
{ var-param dynamic array: element writes and SetLength must reach the
|
|
caller's array (slot -> caller var -> data pointer). }
|
|
procedure TestRun_VarParamDynArray_WriteAndGrow;
|
|
{ var-param static array element write and var-param PChar byte write. }
|
|
procedure TestRun_VarParamStaticArray_PChar;
|
|
{ var-param interface: method dispatch and reassignment through the
|
|
var param must reach the caller's variable. }
|
|
procedure TestRun_VarParamInterface_DispatchAndReassign;
|
|
|
|
{ Metaclass-var constructor dispatch: cls.Create() runs the most-derived
|
|
ctor body via vtable (implicitly virtual), not the base ctor statically. }
|
|
procedure TestRun_MetaclassCreate_DispatchesToDerived;
|
|
{ Metaclass-var ctor with args: cls.Create(N) passes args correctly. }
|
|
procedure TestRun_MetaclassCreate_WithArgs;
|
|
{ Metaclass-var ctor in statement position (result discarded): allocates,
|
|
dispatches the most-derived ctor, then frees the instance. }
|
|
procedure TestRun_MetaclassCreate_StatementDiscardsResult;
|
|
{ Direct TFoo.Create stays static (no vtable dispatch). }
|
|
procedure TestRun_DirectCreate_StaysStatic;
|
|
{ ClassCreate builtin still works (backwards compat) and now dispatches
|
|
the ctor body via vtable too. }
|
|
procedure TestRun_ClassCreate_StillWorks;
|
|
procedure TestRun_SelfIndexedRecordFieldAssign;
|
|
end;
|
|
|
|
implementation
|
|
|
|
procedure TE2EClasses2Tests.SetUp;
|
|
begin
|
|
inherited SetUp();
|
|
SetUpScratch('compiler/target/test-e2e-classes2');
|
|
end;
|
|
|
|
const
|
|
LE = #10;
|
|
|
|
SrcMultiTypeBlock =
|
|
'''
|
|
program Prg;
|
|
type
|
|
TCounter = class
|
|
FN: Integer;
|
|
procedure Inc;
|
|
begin Self.FN := Self.FN + 1 end;
|
|
property Value: Integer read FN;
|
|
end;
|
|
var N: Integer;
|
|
type
|
|
TDoubler = class
|
|
function Double(X: Integer): Integer;
|
|
begin Result := X * 2 end;
|
|
end;
|
|
var
|
|
C: TCounter;
|
|
D: TDoubler;
|
|
begin
|
|
C := TCounter.Create();
|
|
D := TDoubler.Create();
|
|
C.Inc(); C.Inc(); C.Inc();
|
|
N := D.Double(C.Value);
|
|
WriteLn(N)
|
|
end.
|
|
''';
|
|
|
|
SrcToStringDefault = '''
|
|
program Prg;
|
|
type
|
|
TFoo = class end;
|
|
TBar = class(TFoo) end;
|
|
var F: TFoo; B: TBar;
|
|
begin
|
|
F := TFoo.Create();
|
|
WriteLn(F.ToString());
|
|
B := TBar.Create();
|
|
WriteLn(B.ToString())
|
|
end.
|
|
''';
|
|
|
|
SrcToStringOverride = '''
|
|
program Prg;
|
|
type
|
|
TFoo = class
|
|
function ToString: string; override;
|
|
end;
|
|
TBar = class(TFoo)
|
|
function ToString: string; override;
|
|
end;
|
|
function TFoo.ToString: string;
|
|
begin Result := 'foo!' end;
|
|
function TBar.ToString: string;
|
|
begin Result := 'bar!' end;
|
|
var F: TFoo; B: TFoo;
|
|
begin
|
|
F := TFoo.Create();
|
|
WriteLn(F.ToString());
|
|
B := TBar.Create();
|
|
WriteLn(B.ToString())
|
|
end.
|
|
''';
|
|
|
|
SrcToStringInheritedOverride = '''
|
|
program Prg;
|
|
type
|
|
TFoo = class
|
|
function ToString: string; override;
|
|
end;
|
|
TBar = class(TFoo) end;
|
|
function TFoo.ToString: string;
|
|
begin Result := 'foo override' end;
|
|
var F: TFoo; B: TFoo;
|
|
begin
|
|
F := TFoo.Create();
|
|
WriteLn(F.ToString());
|
|
B := TBar.Create();
|
|
WriteLn(B.ToString())
|
|
end.
|
|
''';
|
|
|
|
SrcInheritsFromBase =
|
|
'''
|
|
program Prg;
|
|
type TBase = class end;
|
|
var B: TBase;
|
|
begin
|
|
B := TBase.Create();
|
|
if B.InheritsFrom(TBase) then
|
|
WriteLn('yes')
|
|
else
|
|
WriteLn('no');
|
|
B.Free();
|
|
end.
|
|
''';
|
|
|
|
SrcInheritsFromParent =
|
|
'''
|
|
program Prg;
|
|
type TBase = class end;
|
|
TChild = class(TBase) end;
|
|
var C: TChild;
|
|
begin
|
|
C := TChild.Create();
|
|
if C.InheritsFrom(TBase) then
|
|
WriteLn('yes')
|
|
else
|
|
WriteLn('no');
|
|
C.Free();
|
|
end.
|
|
''';
|
|
|
|
SrcInheritsFromGrandParent =
|
|
'''
|
|
program Prg;
|
|
type TBase = class end;
|
|
TChild = class(TBase) end;
|
|
TGrandChild = class(TChild) end;
|
|
var G: TGrandChild;
|
|
begin
|
|
G := TGrandChild.Create();
|
|
if G.InheritsFrom(TBase) then
|
|
WriteLn('yes')
|
|
else
|
|
WriteLn('no');
|
|
G.Free();
|
|
end.
|
|
''';
|
|
|
|
SrcInheritsFromUnrelated =
|
|
'''
|
|
program Prg;
|
|
type TBase = class end;
|
|
TUnrelated = class end;
|
|
var B: TBase;
|
|
begin
|
|
B := TBase.Create();
|
|
if B.InheritsFrom(TUnrelated) then
|
|
WriteLn('yes')
|
|
else
|
|
WriteLn('no');
|
|
B.Free();
|
|
end.
|
|
''';
|
|
|
|
SrcInheritsFromReverse =
|
|
'''
|
|
program Prg;
|
|
type TBase = class end;
|
|
TChild = class(TBase) end;
|
|
var B: TBase;
|
|
begin
|
|
B := TBase.Create();
|
|
if B.InheritsFrom(TChild) then
|
|
WriteLn('yes')
|
|
else
|
|
WriteLn('no');
|
|
B.Free();
|
|
end.
|
|
''';
|
|
|
|
SrcInheritsFromClassType =
|
|
'''
|
|
program Prg;
|
|
type TBase = class end;
|
|
TChild = class(TBase) end;
|
|
var C: TChild;
|
|
CT: Pointer;
|
|
begin
|
|
C := TChild.Create();
|
|
CT := C.ClassType;
|
|
if CT.InheritsFrom(TBase) then
|
|
WriteLn('yes')
|
|
else
|
|
WriteLn('no');
|
|
C.Free();
|
|
end.
|
|
''';
|
|
|
|
SrcIsTrue = '''
|
|
program Prg;
|
|
type
|
|
TAnimal = class end;
|
|
TDog = class(TAnimal) end;
|
|
var D: TAnimal;
|
|
begin
|
|
D := TDog.Create();
|
|
if D is TDog then WriteLn('yes');
|
|
D.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcIsFalse = '''
|
|
program Prg;
|
|
type
|
|
TAnimal = class end;
|
|
TDog = class(TAnimal) end;
|
|
TCat = class(TAnimal) end;
|
|
var D: TAnimal;
|
|
begin
|
|
D := TDog.Create();
|
|
if D is TCat then WriteLn('yes') else WriteLn('no');
|
|
D.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcAsDowncast = '''
|
|
program Prg;
|
|
type
|
|
TBase = class
|
|
function Name: string; virtual;
|
|
end;
|
|
TChild = class(TBase)
|
|
FVal: Integer;
|
|
function Name: string; override;
|
|
end;
|
|
function TBase.Name: string;
|
|
begin Result := 'base' end;
|
|
function TChild.Name: string;
|
|
begin Result := 'child' end;
|
|
var B: TBase;
|
|
begin
|
|
B := TChild.Create();
|
|
WriteLn((B as TChild).Name());
|
|
B.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcInherited = '''
|
|
program Prg;
|
|
type
|
|
TBase = class
|
|
function Val: Integer; virtual;
|
|
end;
|
|
TChild = class(TBase)
|
|
function Val: Integer; override;
|
|
end;
|
|
function TBase.Val: Integer;
|
|
begin Result := 10 end;
|
|
function TChild.Val: Integer;
|
|
var B: Integer;
|
|
begin
|
|
inherited Val();
|
|
B := Result;
|
|
Result := B + 5
|
|
end;
|
|
var C: TChild;
|
|
begin
|
|
C := TChild.Create();
|
|
WriteLn(C.Val());
|
|
C.Free()
|
|
end.
|
|
''';
|
|
|
|
{ Regression: an `inherited Method(args)` call whose Self + args occupy more
|
|
than the 6 integer argument registers. The native inherited-call sequence
|
|
only handled the all-in-registers case (it popped every slot into a
|
|
register, walking past the 6 available), so an inherited call with 6+ args
|
|
aborted codegen ("arg register index 6 out of range"). Here Self + 7 ints
|
|
= 8 register slots, forcing the overflow to spill to the stack. TBase.Sum
|
|
= 1+..+7 = 28; TChild.Sum doubles it via inherited => 56. }
|
|
SrcInheritedManyArgs = '''
|
|
program Prg;
|
|
type
|
|
TBase = class
|
|
function Sum(a, b, c, d, e, f, g: Integer): Integer; virtual;
|
|
end;
|
|
TChild = class(TBase)
|
|
function Sum(a, b, c, d, e, f, g: Integer): Integer; override;
|
|
end;
|
|
function TBase.Sum(a, b, c, d, e, f, g: Integer): Integer;
|
|
begin Result := a + b + c + d + e + f + g end;
|
|
function TChild.Sum(a, b, c, d, e, f, g: Integer): Integer;
|
|
begin Result := inherited Sum(a, b, c, d, e, f, g) * 2 end;
|
|
var o: TChild;
|
|
begin
|
|
o := TChild.Create();
|
|
WriteLn(o.Sum(1, 2, 3, 4, 5, 6, 7));
|
|
o.Free()
|
|
end.
|
|
''';
|
|
|
|
{ Regression: `inherited Foo(X)` where the parent method has a var/out param.
|
|
The inherited-call arg loop had no var-param branch, so it passed the
|
|
loaded VALUE (a `w`) where the callee expects an address (`l`) — the parent
|
|
then dereferenced a small integer as a pointer and the program crashed. }
|
|
SrcInheritedVarParam = '''
|
|
program Prg;
|
|
type
|
|
TBase = class
|
|
procedure Bump(var X: Integer); virtual;
|
|
end;
|
|
TDer = class(TBase)
|
|
procedure Bump(var X: Integer); override;
|
|
end;
|
|
procedure TBase.Bump(var X: Integer);
|
|
begin X := X + 10 end;
|
|
procedure TDer.Bump(var X: Integer);
|
|
begin
|
|
inherited Bump(X);
|
|
X := X + 1
|
|
end;
|
|
var
|
|
D: TDer;
|
|
N: Integer;
|
|
begin
|
|
D := TDer.Create();
|
|
N := 5;
|
|
D.Bump(N);
|
|
WriteLn(N);
|
|
D.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcVirtualOverride = '''
|
|
program Prg;
|
|
type
|
|
TShape = class
|
|
function Area: Integer; virtual;
|
|
end;
|
|
TSquare = class(TShape)
|
|
FSide: Integer;
|
|
function Area: Integer; override;
|
|
end;
|
|
function TShape.Area: Integer;
|
|
begin Result := 0 end;
|
|
function TSquare.Area: Integer;
|
|
begin Result := FSide * FSide end;
|
|
var S: TShape;
|
|
begin
|
|
S := TSquare.Create();
|
|
TSquare(S).FSide := 4;
|
|
WriteLn(S.Area());
|
|
S.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcMultiLevelChain = '''
|
|
program Prg;
|
|
type
|
|
TA = class
|
|
function Lvl: Integer; virtual;
|
|
end;
|
|
TB = class(TA)
|
|
function Lvl: Integer; override;
|
|
end;
|
|
TC = class(TB)
|
|
function Lvl: Integer; override;
|
|
end;
|
|
function TA.Lvl: Integer; begin Result := 1 end;
|
|
function TB.Lvl: Integer; begin Result := 2 end;
|
|
function TC.Lvl: Integer; begin Result := 3 end;
|
|
var A: TA;
|
|
begin
|
|
A := TC.Create();
|
|
WriteLn(A.Lvl());
|
|
A.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcIntfDispatch = '''
|
|
program Prg;
|
|
type
|
|
IGreeter = interface
|
|
procedure Greet;
|
|
end;
|
|
THello = class(TObject, IGreeter)
|
|
procedure Greet;
|
|
end;
|
|
procedure THello.Greet;
|
|
begin WriteLn('hello') end;
|
|
var G: IGreeter;
|
|
H: THello;
|
|
begin
|
|
H := THello.Create();
|
|
G := H;
|
|
G.Greet();
|
|
H.Free()
|
|
end.
|
|
''';
|
|
|
|
{ Regression: assigning nil to an interface-typed GLOBAL variable. An
|
|
interface global is emitted as a fat-pointer pair ($G_obj / $G_itab); the
|
|
`:= nil` path previously fell through to a scalar store against a bare $G
|
|
symbol with no data definition, causing an undefined-reference link error.
|
|
Must be an e2e test: the IR-only harness never links, so it cannot see it. }
|
|
SrcIntfGlobalNil = '''
|
|
program Prg;
|
|
type
|
|
ISpeaker = interface
|
|
procedure Speak;
|
|
end;
|
|
TSpeaker = class(TObject, ISpeaker)
|
|
procedure Speak;
|
|
end;
|
|
procedure TSpeaker.Speak;
|
|
begin WriteLn('spoke') end;
|
|
var G: ISpeaker;
|
|
begin
|
|
G := TSpeaker.Create();
|
|
G.Speak();
|
|
G := nil;
|
|
WriteLn('after nil')
|
|
end.
|
|
''';
|
|
|
|
SrcIntfIsAs = '''
|
|
program Prg;
|
|
type
|
|
IPrinter = interface
|
|
procedure Print;
|
|
end;
|
|
TPrinter = class(TObject, IPrinter)
|
|
procedure Print;
|
|
end;
|
|
procedure TPrinter.Print;
|
|
begin WriteLn('printing') end;
|
|
var
|
|
Obj: TObject;
|
|
P: IPrinter;
|
|
begin
|
|
Obj := TPrinter.Create();
|
|
if Obj is IPrinter then
|
|
begin
|
|
P := Obj as IPrinter;
|
|
P.Print()
|
|
end;
|
|
Obj.Free()
|
|
end.
|
|
''';
|
|
|
|
{ Regression: a class METHOD taking a by-value interface parameter. The
|
|
method-codegen path emitted the param as a single `w` slot instead of the
|
|
two-slot fat pointer the standalone-routine path uses, so QBE rejected the
|
|
`storel %_par_X` ("invalid type for first operand") and the program failed
|
|
to compile. The method must receive obj+itab and dispatch through them. }
|
|
SrcIntfMethodParam = '''
|
|
program Prg;
|
|
type
|
|
IGreeter = interface
|
|
function Greet: Integer;
|
|
end;
|
|
THello = class(TObject, IGreeter)
|
|
function Greet: Integer;
|
|
end;
|
|
TUser = class
|
|
function Use(G: IGreeter): Integer;
|
|
end;
|
|
function THello.Greet: Integer;
|
|
begin Result := 42 end;
|
|
function TUser.Use(G: IGreeter): Integer;
|
|
begin Result := G.Greet() + 1 end;
|
|
var
|
|
H: THello;
|
|
I: IGreeter;
|
|
U: TUser;
|
|
begin
|
|
H := THello.Create();
|
|
I := H;
|
|
U := TUser.Create();
|
|
WriteLn(U.Use(I))
|
|
end.
|
|
''';
|
|
|
|
{ Regression (issue #64): class has an interface-typed field 'im' AND the
|
|
program declares a same-named global variable 'im' of the class type.
|
|
Inside the constructor and a method, bare 'im' must resolve to the field
|
|
(Iprinter), not the global (Tmi). Previously the semantic analyser found
|
|
the global first and reported a type-mismatch. }
|
|
SrcIntfFieldShadowsGlobal = '''
|
|
program Prg;
|
|
type
|
|
Iprinter = interface
|
|
procedure print;
|
|
end;
|
|
Toutput = class(TObject, Iprinter)
|
|
procedure print;
|
|
end;
|
|
Tmi = class
|
|
im: Iprinter;
|
|
constructor create(am: Iprinter);
|
|
procedure use;
|
|
end;
|
|
procedure Toutput.print;
|
|
begin
|
|
WriteLn('printed');
|
|
end;
|
|
constructor Tmi.Create(am: Iprinter);
|
|
begin
|
|
im := am;
|
|
end;
|
|
procedure Tmi.use;
|
|
begin
|
|
im.print();
|
|
end;
|
|
var
|
|
im: Tmi;
|
|
begin
|
|
im := Tmi.Create(Toutput.Create());
|
|
im.use();
|
|
end.
|
|
''';
|
|
|
|
SrcSupportsTwoArgRun = '''
|
|
program Prg;
|
|
type
|
|
IGreeter = interface
|
|
procedure Greet;
|
|
end;
|
|
THello = class(TObject, IGreeter)
|
|
procedure Greet;
|
|
end;
|
|
procedure THello.Greet;
|
|
begin WriteLn('hello') end;
|
|
var Obj: TObject;
|
|
begin
|
|
Obj := THello.Create();
|
|
if Supports(Obj, IGreeter) then
|
|
WriteLn('yes')
|
|
else
|
|
WriteLn('no');
|
|
Obj.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcSupportsThreeArgRun = '''
|
|
program Prg;
|
|
type
|
|
IGreeter = interface
|
|
procedure Greet;
|
|
end;
|
|
THello = class(TObject, IGreeter)
|
|
procedure Greet;
|
|
end;
|
|
procedure THello.Greet;
|
|
begin WriteLn('hello') end;
|
|
var Obj: TObject;
|
|
G: IGreeter;
|
|
begin
|
|
Obj := THello.Create();
|
|
if Supports(Obj, IGreeter, G) then
|
|
G.Greet()
|
|
else
|
|
WriteLn('no');
|
|
Obj.Free()
|
|
end.
|
|
''';
|
|
|
|
{ Constructor overload where the 2-arg variant is declared first. The
|
|
1-arg call site must resolve to the 1-arg constructor; otherwise the
|
|
semantic pass rejects the program with "No default value for parameter
|
|
'B' of 'Create'". Picks the body via A only, so the output proves
|
|
the 1-arg constructor body actually ran. }
|
|
{ Regression for issue #43: a class method body must be able to read and
|
|
write a program-level global variable declared above the class type. }
|
|
SrcMethodReadsProgramGlobal =
|
|
'''
|
|
program GlobalAccessBug;
|
|
var
|
|
gValue: Integer;
|
|
type
|
|
TFoo = class
|
|
function GetValue: Integer;
|
|
end;
|
|
function TFoo.GetValue: Integer;
|
|
begin
|
|
Result := gValue
|
|
end;
|
|
var
|
|
Foo: TFoo;
|
|
begin
|
|
gValue := 42;
|
|
Foo := TFoo.Create();
|
|
WriteLn(Foo.GetValue());
|
|
Foo.Free()
|
|
end.
|
|
''';
|
|
|
|
SrcVarParamClassFields =
|
|
'''
|
|
program VarParamClassFields;
|
|
procedure Fill(var V: Int64; var F: Boolean);
|
|
begin
|
|
V := 4096;
|
|
F := True
|
|
end;
|
|
type
|
|
TNode = class
|
|
Value: Int64;
|
|
IsBig: Boolean;
|
|
end;
|
|
var N: TNode;
|
|
begin
|
|
N := TNode.Create();
|
|
Fill(N.Value, N.IsBig);
|
|
WriteLn(N.Value);
|
|
WriteLn(N.IsBig);
|
|
N.Free()
|
|
end.
|
|
''';
|
|
|
|
{ ----- Name-resolution priority (Option A: single-program tests).
|
|
Visibility (private / protected across units) is a follow-up. ----- }
|
|
|
|
{ Level 1 beats level 2: a local procedural-typed variable shadows a
|
|
class method of the same name. This is the use case in
|
|
blaise.testing.TTestCase.RunTest (`var Run: TRunMethod`). }
|
|
SrcResolve_LocalVar_OverOwnMethod =
|
|
'''
|
|
program ResLocalVar;
|
|
function Helper: Integer;
|
|
begin Result := 42 end;
|
|
type
|
|
TFn = function: Integer;
|
|
TFoo = class
|
|
function Compute: Integer;
|
|
function Run: Integer;
|
|
end;
|
|
function TFoo.Compute: Integer;
|
|
begin Result := 100 end;
|
|
function TFoo.Run: Integer;
|
|
var Compute: TFn;
|
|
begin
|
|
Compute := @Helper;
|
|
Result := Compute()
|
|
end;
|
|
var F: TFoo;
|
|
begin
|
|
F := TFoo.Create();
|
|
WriteLn(F.Run());
|
|
F.Free()
|
|
end.
|
|
''';
|
|
|
|
{ Level 2 beats level 3: a class method shadows a program-level
|
|
proc. A subclass with no own method X but with an inherited X
|
|
(and a program-level proc X also in scope) — the unqualified call
|
|
inside the subclass binds to the inherited method, not the
|
|
program-level proc. Pre-fix, the global lookup ran first and
|
|
bound to the program-level Tag (output '1'); post-fix the
|
|
implicit-Self check finds parent.Tag and wins (output '2'). }
|
|
SrcResolve_ParentMethod_OverProgramProc =
|
|
'''
|
|
program ResParentOverProgram;
|
|
function Tag: Integer;
|
|
begin Result := 1 end;
|
|
type
|
|
TParent = class
|
|
function Tag: Integer;
|
|
function Echo: Integer;
|
|
end;
|
|
TChild = class(TParent)
|
|
end;
|
|
function TParent.Tag: Integer;
|
|
begin Result := 2 end;
|
|
function TParent.Echo: Integer;
|
|
begin Result := Tag() end;
|
|
var C: TChild;
|
|
begin
|
|
C := TChild.Create();
|
|
WriteLn(C.Echo());
|
|
C.Free()
|
|
end.
|
|
''';
|
|
|
|
{ `inherited X;` is an explicit qualifier that calls the parent's X
|
|
statically — does NOT go through subclass override, does NOT fall
|
|
through to any program-level X. Statement form is used because
|
|
Blaise doesn't yet parse `inherited X` in expression context;
|
|
parent's body sets Result, which Child.FromInh returns. }
|
|
SrcResolve_InheritedAlwaysParent =
|
|
'''
|
|
program ResInherited;
|
|
type
|
|
TParent = class
|
|
function Tag: Integer;
|
|
end;
|
|
TChild = class(TParent)
|
|
function Tag: Integer;
|
|
function FromInh: Integer;
|
|
end;
|
|
function TParent.Tag: Integer;
|
|
begin Result := 1 end;
|
|
function TChild.Tag: Integer;
|
|
begin Result := 2 end;
|
|
function TChild.FromInh: Integer;
|
|
begin
|
|
inherited Tag()
|
|
end;
|
|
var C: TChild;
|
|
begin
|
|
C := TChild.Create();
|
|
WriteLn(C.FromInh());
|
|
C.Free()
|
|
end.
|
|
''';
|
|
|
|
{ Self.X is an explicit path: it MUST resolve to a member of Self's
|
|
class hierarchy, regardless of any same-named local var that
|
|
would otherwise win in the unqualified priority order. }
|
|
SrcResolve_ExplicitSelf_AlwaysClassMember =
|
|
'''
|
|
program ResExplicitSelf;
|
|
type
|
|
TFoo = class
|
|
function Compute: Integer;
|
|
function Run: Integer;
|
|
end;
|
|
function TFoo.Compute: Integer;
|
|
begin Result := 200 end;
|
|
function TFoo.Run: Integer;
|
|
var Compute: Integer;
|
|
begin
|
|
Compute := 7;
|
|
Result := Self.Compute()
|
|
end;
|
|
var F: TFoo;
|
|
begin
|
|
F := TFoo.Create();
|
|
WriteLn(F.Run());
|
|
F.Free()
|
|
end.
|
|
''';
|
|
|
|
|
|
SrcCtorOverloadArity =
|
|
'''
|
|
program Prg;
|
|
type
|
|
TFoo = class
|
|
FA: Integer;
|
|
constructor Create(A: Integer; B: Integer); overload;
|
|
constructor Create(A: Integer); overload;
|
|
end;
|
|
constructor TFoo.Create(A: Integer; B: Integer);
|
|
begin Self.FA := A + B end;
|
|
constructor TFoo.Create(A: Integer);
|
|
begin Self.FA := A end;
|
|
var F: TFoo;
|
|
begin
|
|
F := TFoo.Create(42);
|
|
WriteLn(F.FA);
|
|
F.Free()
|
|
end.
|
|
''';
|
|
|
|
function LoadMilestoneFile(const APath: string; out ASrc: string): Boolean;
|
|
var Lst: TStringList;
|
|
begin
|
|
Result := False;
|
|
if not FileExists(APath) then Exit;
|
|
Lst := TStringList.Create();
|
|
try
|
|
Lst.LoadFromFile(APath);
|
|
ASrc := Lst.Text;
|
|
Result := True;
|
|
finally
|
|
Lst.Free();
|
|
end;
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Phase2Milestone_Stdout;
|
|
var
|
|
Path, Src, Output: string;
|
|
RCode: Integer;
|
|
Expected: string;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
Path := GetCurrentDir();
|
|
// Walk up to project root looking for tests/phase2_milestone.pas
|
|
while (Path <> '') and
|
|
(not FileExists(Path + '/tests/phase2_milestone.pas')) and
|
|
(ExtractFileDir(Path) <> Path) do
|
|
Path := ExtractFileDir(Path);
|
|
Path := Path + '/tests/phase2_milestone.pas';
|
|
if not LoadMilestoneFile(Path, Src) then
|
|
begin
|
|
Ignore('phase2_milestone.pas not found');
|
|
Exit;
|
|
end;
|
|
AssertTrue('compile+run milestone', CompileAndRun(Src, Output, RCode));
|
|
AssertEquals('milestone exit code', 0, RCode);
|
|
Expected :=
|
|
'count=4' + LE +
|
|
'--- walk ---' + LE +
|
|
' value=40' + LE +
|
|
' tag=0' + LE +
|
|
' marked=False' + LE +
|
|
' value=30' + LE +
|
|
' tag=1' + LE +
|
|
' marked=True' + LE +
|
|
' value=20' + LE +
|
|
' tag=0' + LE +
|
|
' marked=False' + LE +
|
|
' value=10' + LE +
|
|
' tag=0' + LE +
|
|
' marked=False' + LE +
|
|
'pop=40' + LE +
|
|
'pop=30' + LE +
|
|
'count_after_pops=2' + LE;
|
|
AssertEquals('milestone stdout', Expected, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Phase2Milestone_Valgrind;
|
|
var
|
|
Path, Src, Log: string;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
if not ValgrindAvailable() then begin Ignore('valgrind not installed'); Exit; end;
|
|
Path := GetCurrentDir();
|
|
while (Path <> '') and
|
|
(not FileExists(Path + '/tests/phase2_milestone.pas')) and
|
|
(ExtractFileDir(Path) <> Path) do
|
|
Path := ExtractFileDir(Path);
|
|
Path := Path + '/tests/phase2_milestone.pas';
|
|
if not LoadMilestoneFile(Path, Src) then
|
|
begin
|
|
Ignore('phase2_milestone.pas not found');
|
|
Exit;
|
|
end;
|
|
if not RunUnderValgrind(Src, Log) then
|
|
begin
|
|
if Log = '' then Log := '(valgrind produced no output)';
|
|
Fail('valgrind reported errors or leaks:' + LE + Log);
|
|
end;
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Phase3Milestone_Stdout;
|
|
var
|
|
Path, Src, Output: string;
|
|
RCode: Integer;
|
|
Expected: string;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
Path := GetCurrentDir();
|
|
while (Path <> '') and
|
|
(not FileExists(Path + '/tests/phase3_milestone.pas')) and
|
|
(ExtractFileDir(Path) <> Path) do
|
|
Path := ExtractFileDir(Path);
|
|
Path := Path + '/tests/phase3_milestone.pas';
|
|
if not LoadMilestoneFile(Path, Src) then
|
|
begin
|
|
Ignore('phase3_milestone.pas not found');
|
|
Exit;
|
|
end;
|
|
AssertTrue('compile+run milestone', CompileAndRun(Src, Output, RCode));
|
|
AssertEquals('milestone exit code', 0, RCode);
|
|
Expected :=
|
|
'list.count=5' + LE +
|
|
'list[0]=10' + LE +
|
|
'list[4]=50' + LE +
|
|
'count_after_delete=4' + LE +
|
|
'list[1]_after_delete=30' + LE +
|
|
'dict.count=4' + LE +
|
|
'beta=2' + LE +
|
|
'has_gamma=True' + LE +
|
|
'beta_after_update=99' + LE +
|
|
'count_after_remove=3' + LE +
|
|
'has_alpha_after_remove=False' + LE;
|
|
AssertEquals('milestone stdout', Expected, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Phase3Milestone_Valgrind;
|
|
var
|
|
Path, Src, Log: string;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
if not ValgrindAvailable() then begin Ignore('valgrind not installed'); Exit; end;
|
|
Path := GetCurrentDir();
|
|
while (Path <> '') and
|
|
(not FileExists(Path + '/tests/phase3_milestone.pas')) and
|
|
(ExtractFileDir(Path) <> Path) do
|
|
Path := ExtractFileDir(Path);
|
|
Path := Path + '/tests/phase3_milestone.pas';
|
|
if not LoadMilestoneFile(Path, Src) then
|
|
begin
|
|
Ignore('phase3_milestone.pas not found');
|
|
Exit;
|
|
end;
|
|
if not RunUnderValgrind(Src, Log) then
|
|
begin
|
|
if Log = '' then Log := '(valgrind produced no output)';
|
|
Fail('phase3 milestone has leaks or errors:' + LE + Log);
|
|
end;
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MultiTypeBlock_BothClassesWork;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcMultiTypeBlock, Output, RCode));
|
|
AssertEquals('TCounter(3).Double = 6', '6', Trim(Output));
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ToString_DefaultReturnsClassName;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcToStringDefault, 'TFoo' + LE + 'TBar' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ToString_OverrideDispatchedVirtually;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcToStringOverride, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('override reached through static base type',
|
|
'foo!' + LE + 'bar!' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ToString_InheritedOverrideStillReached;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcToStringInheritedOverride, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('inherited override still reached',
|
|
'foo override' + LE + 'foo override' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritsFrom_SameClass_ReturnsTrue;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritsFromBase, 'yes' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritsFrom_Parent_ReturnsTrue;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritsFromParent, 'yes' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritsFrom_GrandParent_ReturnsTrue;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritsFromGrandParent, 'yes' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritsFrom_Unrelated_ReturnsFalse;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritsFromUnrelated, 'no' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritsFrom_Reverse_ReturnsFalse;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritsFromReverse, 'no' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritsFrom_ClassType_Works;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritsFromClassType, 'yes' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Is_CorrectSubclass_True;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIsTrue, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('yes', 'yes' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Is_WrongClass_False;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIsFalse, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('no', 'no' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_As_DowncastCallsMethod;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcAsDowncast, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('child', 'child' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Inherited_CallsParentMethod;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcInherited, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('15', '15' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Inherited_ManyArgs_SpillsToStack;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritedManyArgs, '56' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Inherited_VarParam_PassesByReference;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcInheritedVarParam, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('5+10+1', '16' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Virtual_OverrideDispatch;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcVirtualOverride, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('16', '16' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MultiLevel_Inheritance_Chain;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcMultiLevelChain, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('3', '3' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Interface_Dispatch_CallsImpl;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIntfDispatch, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('hello', 'hello' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Interface_ARC_NoLeak;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIntfDispatch, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Interface_GlobalNil_LinksAndRuns;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIntfGlobalNil, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('spoke then after nil',
|
|
'spoke' + LE + 'after nil' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Interface_Is_As_Roundtrip;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIntfIsAs, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('printing', 'printing' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Interface_MethodParam_ByValue_Dispatches;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIntfMethodParam, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('greet+1', '43' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Supports_TwoArg_BooleanResult;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcSupportsTwoArgRun, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('yes', 'yes' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_Supports_ThreeArg_AssignsAndCalls;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcSupportsThreeArgRun, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('hello', 'hello' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ConstructorOverload_PicksCorrectArity;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcCtorOverloadArity, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('1-arg constructor body ran', '42' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MethodFloatArg_Literal_PassedInXmm;
|
|
begin
|
|
AssertRunsOnAll(
|
|
'''
|
|
program c;
|
|
type TX = class procedure Take(d: Double); end;
|
|
procedure TX.Take(d: Double); begin WriteLn(d); end;
|
|
var x: TX;
|
|
begin x := TX.Create(); x.Take(1.5); end.
|
|
''',
|
|
'1.5' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MethodFloatArg_Variable_PassedInXmm;
|
|
begin
|
|
AssertRunsOnAll(
|
|
'''
|
|
program f;
|
|
type TX = class procedure Take(d: Double); end;
|
|
procedure TX.Take(d: Double); begin WriteLn(d); end;
|
|
var x: TX; y: Double;
|
|
begin x := TX.Create(); y := 1.5; x.Take(y); end.
|
|
''',
|
|
'1.5' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ConstructorFloatArg_Literal_StoredCorrectly;
|
|
begin
|
|
AssertRunsOnAll(
|
|
'''
|
|
program ctl;
|
|
type TN = class V: Double; constructor CreateFloat(d: Double); end;
|
|
constructor TN.CreateFloat(d: Double); begin V := d; end;
|
|
var n: TN;
|
|
begin n := TN.CreateFloat(2.5); WriteLn(n.V); end.
|
|
''',
|
|
'2.5' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ConstructorFloatArg_Variable_StoredCorrectly;
|
|
begin
|
|
AssertRunsOnAll(
|
|
'''
|
|
program ct;
|
|
type TN = class V: Double; constructor CreateFloat(d: Double); end;
|
|
constructor TN.CreateFloat(d: Double); begin V := d; end;
|
|
var n: TN; y: Double;
|
|
begin y := 2.5; n := TN.CreateFloat(y); WriteLn(n.V); end.
|
|
''',
|
|
'2.5' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MethodMixedIntFloatString_RegistersInterleave;
|
|
begin
|
|
{ Exercises int + float + string interleaving: the string and Int64 take
|
|
integer arg registers, the Double takes an xmm register, independently. }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program mix;
|
|
type TX = class procedure M(const s: string; i: Int64; d: Double); end;
|
|
procedure TX.M(const s: string; i: Int64; d: Double);
|
|
begin WriteLn('s=', s, ' i=', i, ' d=', d); end;
|
|
var x: TX;
|
|
begin x := TX.Create(); x.M('hi', 7, 3.5); end.
|
|
''',
|
|
's=hi i=7 d=3.5' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MethodMultipleFloats_UseXmm0AndXmm1;
|
|
begin
|
|
{ Two Double/Single args must land in distinct xmm registers (xmm0, xmm1),
|
|
interleaved with an integer arg that consumes an integer register. }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program mf;
|
|
type TX = class procedure M(a: Double; i: Int64; b: Double; c: Single); end;
|
|
procedure TX.M(a: Double; i: Int64; b: Double; c: Single);
|
|
begin WriteLn('a=', a, ' i=', i, ' b=', b, ' c=', c); end;
|
|
var x: TX;
|
|
begin x := TX.Create(); x.M(1.5, 9, 2.5, 3.5); end.
|
|
''',
|
|
'a=1.5 i=9 b=2.5 c=3.5' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MethodOverflowFloatArgs_Pass;
|
|
begin
|
|
{ 9 args (5 int register, 2 float xmm, 1 int spilled to stack) plus Self:
|
|
exercises the >6-slot overflow path with floats. i6 is the 6th integer arg
|
|
and must reach %r9, not the stack, since the two floats consumed xmm not
|
|
integer registers. }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program ovm;
|
|
type TX = class
|
|
procedure M(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64);
|
|
end;
|
|
procedure TX.M(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64);
|
|
begin WriteLn(i1,' ',i2,' ',i3,' ',i4,' ',i5,' ',d1,' ',d2,' ',i6); end;
|
|
var x: TX;
|
|
begin x := TX.Create(); x.M(1,2,3,4,5, 6.5, 7.5, 8); end.
|
|
''',
|
|
'1 2 3 4 5 6.5 7.5 8' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ConstructorOverflowFloatArgs_Pass;
|
|
begin
|
|
AssertRunsOnAll(
|
|
'''
|
|
program ovc;
|
|
type TN = class
|
|
R: Double;
|
|
constructor Create(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64);
|
|
end;
|
|
constructor TN.Create(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64);
|
|
begin R := d1 + d2 + i6; end;
|
|
var n: TN;
|
|
begin n := TN.Create(1,2,3,4,5, 6.5, 7.5, 8); WriteLn(n.R); end.
|
|
''',
|
|
'22' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritedOverflowFloatArgs_Pass;
|
|
begin
|
|
AssertRunsOnAll(
|
|
'''
|
|
program ovi;
|
|
type
|
|
TBase = class
|
|
procedure M(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64); virtual;
|
|
end;
|
|
TDer = class(TBase)
|
|
procedure M(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64); override;
|
|
end;
|
|
procedure TBase.M(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64);
|
|
begin WriteLn('base ',i1,' ',d1,' ',d2,' ',i6); end;
|
|
procedure TDer.M(i1,i2,i3,i4,i5: Int64; d1,d2: Double; i6: Int64);
|
|
begin inherited M(i1,i2,i3,i4,i5,d1,d2,i6); WriteLn('der ',d1,' ',d2); end;
|
|
var x: TDer;
|
|
begin x := TDer.Create(); x.M(1,2,3,4,5, 6.5, 7.5, 9); end.
|
|
''',
|
|
'base 1 6.5 7.5 9' + LE + 'der 6.5 7.5' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ImplicitSelfVirtual_DispatchesOverride;
|
|
begin
|
|
{ TBase.Run calls Emit() unqualified; Self is a TLeaf, so the override must
|
|
run. A static bind would print BASE. }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program a;
|
|
type
|
|
TBase = class
|
|
procedure Emit; virtual;
|
|
procedure Run;
|
|
end;
|
|
TLeaf = class(TBase)
|
|
procedure Emit; override;
|
|
end;
|
|
procedure TBase.Emit; begin WriteLn('BASE'); end;
|
|
procedure TBase.Run; begin Emit(); end;
|
|
procedure TLeaf.Emit; begin WriteLn('LEAF'); end;
|
|
var b: TBase;
|
|
begin b := TLeaf.Create(); b.Run(); end.
|
|
''',
|
|
'LEAF' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ImplicitSelfAbstractVirtual_LinksAndDispatches;
|
|
begin
|
|
{ Abstract base method has no body; an unqualified Emit(x) must vtable-
|
|
dispatch (else: undefined symbol TBase_Emit at link). }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program a;
|
|
type
|
|
TArg = class end;
|
|
TBase = class
|
|
protected
|
|
procedure Emit(A: TArg); virtual; abstract;
|
|
public
|
|
procedure Run;
|
|
end;
|
|
TLeaf = class(TBase)
|
|
protected
|
|
procedure Emit(A: TArg); override;
|
|
end;
|
|
procedure TBase.Run; var x: TArg; begin x := TArg.Create(); Emit(x); end;
|
|
procedure TLeaf.Emit(A: TArg); begin WriteLn('leaf'); end;
|
|
var b: TBase;
|
|
begin b := TLeaf.Create(); b.Run(); end.
|
|
''',
|
|
'leaf' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ImplicitSelfVirtual_NonVirtualStaysStatic;
|
|
begin
|
|
{ An unqualified call to a NON-virtual method must still resolve (a static
|
|
direct call); this guards against over-eager vtable dispatch. }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program a;
|
|
type TX = class
|
|
procedure Helper;
|
|
procedure Run;
|
|
end;
|
|
procedure TX.Helper; begin WriteLn('helper'); end;
|
|
procedure TX.Run; begin Helper(); end;
|
|
var x: TX;
|
|
begin x := TX.Create(); x.Run(); end.
|
|
''',
|
|
'helper' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ImplicitSelfVirtual_IntfReturn_Dispatches;
|
|
begin
|
|
{ Implicit-Self virtual method returning an interface (sret) must dispatch
|
|
to the override. }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program a;
|
|
type
|
|
IFoo = interface
|
|
function Name: String;
|
|
end;
|
|
TFoo = class(TObject, IFoo)
|
|
function Name: String;
|
|
end;
|
|
TBase = class
|
|
function MakeFoo: IFoo; virtual;
|
|
function Run: String;
|
|
end;
|
|
TLeaf = class(TBase)
|
|
function MakeFoo: IFoo; override;
|
|
end;
|
|
function TFoo.Name: String; begin Result := 'foo'; end;
|
|
function TBase.MakeFoo: IFoo; begin Result := nil; end;
|
|
function TBase.Run: String;
|
|
var f: IFoo;
|
|
begin f := MakeFoo(); if f = nil then Result := 'nil' else Result := f.Name(); end;
|
|
function TLeaf.MakeFoo: IFoo; begin Result := TFoo.Create(); end;
|
|
var b: TBase;
|
|
begin b := TLeaf.Create(); WriteLn(b.Run()); end.
|
|
''',
|
|
'foo' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ImplicitSelfVirtual_RecordReturn_Dispatches;
|
|
begin
|
|
{ Implicit-Self virtual method returning a record (sret) must dispatch to
|
|
the override. }
|
|
AssertRunsOnAll(
|
|
'''
|
|
program a;
|
|
type
|
|
TPt = record X: Int64; end;
|
|
TBase = class
|
|
function Make: TPt; virtual;
|
|
function Run: Int64;
|
|
end;
|
|
TLeaf = class(TBase)
|
|
function Make: TPt; override;
|
|
end;
|
|
function TBase.Make: TPt; begin Result.X := 100; end;
|
|
function TBase.Run: Int64; var p: TPt; begin p := Make(); Result := p.X; end;
|
|
function TLeaf.Make: TPt; begin Result.X := 200; end;
|
|
var b: TBase;
|
|
begin b := TLeaf.Create(); WriteLn(b.Run()); end.
|
|
''',
|
|
'200' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MethodReadsProgramGlobal;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcMethodReadsProgramGlobal, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('global read by method', '42' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_VarParam_ClassFields_WritebackVisible;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
{ Regression for bugs.txt BUG-001 — Fill(N.Value, N.IsBig) where N is a
|
|
class reference must address into the heap object, not into the storage
|
|
slot of N itself. Before the fix the writes landed in unrelated memory
|
|
and the WriteLn calls printed 0 / False. }
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcVarParamClassFields, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('var-param writeback visible through class field', '4096' + LE + 'True' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_LocalVar_ShadowsOwnMethod;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcResolve_LocalVar_OverOwnMethod, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('local var wins over class method', '42' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ParentMethod_ShadowsProgramProc;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcResolve_ParentMethod_OverProgramProc, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('inherited method wins over program-level proc', '2' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ExplicitSelf_AlwaysClassMember;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcResolve_ExplicitSelf_AlwaysClassMember, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('Self.X reaches class method despite local var X', '200' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritedCall_AlwaysParent;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcResolve_InheritedAlwaysParent, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('inherited Tag reaches parent despite subclass override', '1' + LE, Output);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InterfaceField_ShadowsGlobal_Dispatches;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run', CompileAndRun(SrcIntfFieldShadowsGlobal, Output, RCode));
|
|
AssertEquals('exit code 0', 0, RCode);
|
|
AssertEquals('interface dispatch through field shadowing global', 'printed' + LE, Output);
|
|
end;
|
|
|
|
const
|
|
SrcInterfaceProperty = '''
|
|
program Prg;
|
|
type
|
|
IInter = interface
|
|
function GetValue(): Integer;
|
|
procedure SetValue(AValue: Integer);
|
|
property Value: Integer read GetValue write SetValue;
|
|
end;
|
|
IChild = interface(IInter)
|
|
procedure Bump();
|
|
end;
|
|
TFace = class(TObject, IInter, IChild)
|
|
FVal: Integer;
|
|
function GetValue(): Integer;
|
|
procedure SetValue(AValue: Integer);
|
|
procedure Bump();
|
|
property Value: Integer read GetValue write SetValue;
|
|
end;
|
|
function TFace.GetValue(): Integer;
|
|
begin
|
|
Result := FVal;
|
|
end;
|
|
procedure TFace.SetValue(AValue: Integer);
|
|
begin
|
|
FVal := AValue;
|
|
end;
|
|
procedure TFace.Bump();
|
|
begin
|
|
FVal := FVal + 1;
|
|
end;
|
|
var
|
|
C: TFace;
|
|
I: IInter;
|
|
K: IChild;
|
|
begin
|
|
C := TFace.Create();
|
|
C.Value := 13;
|
|
writeln(C.Value);
|
|
I := TFace.Create();
|
|
I.Value := 21;
|
|
writeln(I.Value);
|
|
I.Value := I.Value + 1;
|
|
writeln(I.Value);
|
|
K := TFace.Create();
|
|
K.Value := 40;
|
|
K.Bump();
|
|
writeln(K.Value);
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InterfaceProperty_ReadWrite;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInterfaceProperty,
|
|
'13' + LE + '21' + LE + '22' + LE + '41' + LE, 0);
|
|
end;
|
|
|
|
const
|
|
{ graemeg/blaise#111 — Tchild inherits classValue (a method-backed
|
|
property) from Tbase; the read and write must reach Tbase's accessors. }
|
|
SrcInheritedProperty = '''
|
|
program Prg;
|
|
type
|
|
Tbase = class
|
|
private
|
|
fValue: Integer;
|
|
public
|
|
procedure setValue(AValue: Integer);
|
|
function getValue: Integer;
|
|
property classValue: Integer read getValue write setValue;
|
|
end;
|
|
Tchild = class(Tbase)
|
|
procedure childAct;
|
|
end;
|
|
procedure Tbase.setValue(AValue: Integer);
|
|
begin fValue := AValue end;
|
|
function Tbase.getValue: Integer;
|
|
begin Result := fValue end;
|
|
procedure Tchild.childAct;
|
|
begin writeln('act') end;
|
|
var child: Tchild;
|
|
begin
|
|
child := Tchild.Create();
|
|
child.classValue := 12;
|
|
writeln(child.classValue);
|
|
child.Free()
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InheritedProperty_AccessorsResolveToParent;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcInheritedProperty, '12' + LE, 0);
|
|
end;
|
|
|
|
const
|
|
SrcClassConstInt = '''
|
|
program Prg;
|
|
type TThing = class const MaxCount = 10; end;
|
|
begin WriteLn(TThing.MaxCount) end.
|
|
''';
|
|
|
|
SrcClassConstStr = '''
|
|
program Prg;
|
|
type TThing = class const Tag = 'hi'; end;
|
|
var s: string;
|
|
begin
|
|
s := TThing.Tag + '!';
|
|
WriteLn(s);
|
|
WriteLn(TThing.Tag)
|
|
end.
|
|
''';
|
|
|
|
SrcClassConstInstAndType = '''
|
|
program Prg;
|
|
type
|
|
TThing = class
|
|
const MaxCount = 10;
|
|
function Limit: Integer; begin Result := MaxCount end;
|
|
end;
|
|
var t: TThing;
|
|
begin
|
|
t := TThing.Create;
|
|
WriteLn(t.Limit());
|
|
WriteLn(TThing.MaxCount);
|
|
t := nil
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ClassConst_IntViaType;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcClassConstInt, '10' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ClassConst_StringViaType;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcClassConstStr, 'hi!' + LE + 'hi' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ClassConst_ViaInstanceAndType;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcClassConstInstAndType, '10' + LE + '10' + LE, 0);
|
|
end;
|
|
|
|
const
|
|
SrcIntfPropCaseUses = '''
|
|
program Prg;
|
|
uses classes;
|
|
type
|
|
Iinter = interface
|
|
function GetValue(): Integer;
|
|
procedure SetValue(AValue: Integer);
|
|
property prop: Integer read getValue write setValue;
|
|
end;
|
|
Tface = class(TObject, Iinter)
|
|
fProp: Integer;
|
|
function GetValue(): Integer;
|
|
procedure SetValue(AValue: Integer);
|
|
property prop: Integer read getValue write setValue;
|
|
end;
|
|
function Tface.GetValue(): Integer;
|
|
begin
|
|
Result := fProp;
|
|
end;
|
|
procedure Tface.SetValue(AValue: Integer);
|
|
begin
|
|
fProp := AValue;
|
|
end;
|
|
var
|
|
ift: Tface;
|
|
iit: Iinter;
|
|
begin
|
|
ift := Tface.Create();
|
|
ift.prop := 13;
|
|
writeln(ift.prop);
|
|
iit := Tface.Create();
|
|
iit.prop := 29;
|
|
writeln(iit.prop);
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InterfaceProperty_CaseMismatchAndUses;
|
|
var Output: string; RCode: Integer;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertTrue('compile+run (qbe)',
|
|
CompileAndRunWithRTLDebugOn(beQBE, SrcIntfPropCaseUses, Output, RCode, False));
|
|
AssertEquals('exit code (qbe)', 0, RCode);
|
|
AssertEquals('output (qbe)', '13' + LE + '29' + LE, Output);
|
|
AssertTrue('compile+run (native)',
|
|
CompileAndRunWithRTLDebugOn(beNative, SrcIntfPropCaseUses, Output, RCode, False));
|
|
AssertEquals('exit code (native)', 0, RCode);
|
|
AssertEquals('output (native)', '13' + LE + '29' + LE, Output);
|
|
end;
|
|
|
|
const
|
|
SrcIntfFieldCallStmt = '''
|
|
program Prg;
|
|
type
|
|
IShape = interface
|
|
procedure Note();
|
|
function Area(K: Integer): Integer;
|
|
end;
|
|
TSq = class(TObject, IShape)
|
|
procedure Note();
|
|
function Area(K: Integer): Integer;
|
|
end;
|
|
THolder = class
|
|
S: IShape;
|
|
end;
|
|
procedure TSq.Note();
|
|
begin
|
|
writeln('note');
|
|
end;
|
|
function TSq.Area(K: Integer): Integer;
|
|
begin
|
|
Result := K * K;
|
|
end;
|
|
var H: THolder;
|
|
begin
|
|
H := THolder.Create();
|
|
H.S := TSq.Create();
|
|
writeln(H.S.Area(3));
|
|
H.S.Note();
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_InterfaceFieldCall_StatementPosition;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcIntfFieldCallStmt, '9' + LE + 'note' + LE, 0);
|
|
end;
|
|
|
|
const
|
|
SrcVarParamClass = '''
|
|
program Prg;
|
|
type
|
|
TBox = class
|
|
V: Integer;
|
|
W: Integer;
|
|
end;
|
|
procedure MutB(var B: TBox);
|
|
begin
|
|
B.V := B.V + 98;
|
|
B.W := B.V * 2;
|
|
writeln(B.V);
|
|
end;
|
|
procedure Swap(var B: TBox);
|
|
var T: TBox;
|
|
begin
|
|
T := TBox.Create();
|
|
T.V := 500;
|
|
B := T;
|
|
end;
|
|
var
|
|
Box: TBox;
|
|
begin
|
|
Box := TBox.Create();
|
|
Box.V := 1;
|
|
MutB(Box);
|
|
writeln(Box.V);
|
|
writeln(Box.W);
|
|
Swap(Box);
|
|
writeln(Box.V);
|
|
end.
|
|
''';
|
|
|
|
SrcNestedCaptureParams = '''
|
|
program Prg;
|
|
procedure Outer();
|
|
var
|
|
Total: Integer;
|
|
Name: string;
|
|
procedure Inner(K: Integer; Tag: string);
|
|
begin
|
|
Total := Total + K;
|
|
Name := Name + Tag;
|
|
end;
|
|
begin
|
|
Total := 5;
|
|
Name := 'x';
|
|
Inner(7, 'y');
|
|
Inner(8, 'z');
|
|
writeln(Total);
|
|
writeln(Name);
|
|
end;
|
|
begin
|
|
Outer();
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_VarParamClass_FieldReadWrite;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcVarParamClass,
|
|
'99' + LE + '99' + LE + '198' + LE + '500' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_NestedProc_CaptureAndParams;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcNestedCaptureParams, '20' + LE + 'xyz' + LE, 0);
|
|
end;
|
|
|
|
const
|
|
SrcVarParamFloat = '''
|
|
program Prg;
|
|
procedure SetD(var D: Double);
|
|
begin
|
|
D := 2.5;
|
|
end;
|
|
procedure Outer();
|
|
var
|
|
X: Double;
|
|
procedure Bump(F: Double);
|
|
begin
|
|
X := X + F;
|
|
end;
|
|
begin
|
|
X := 1.0;
|
|
SetD(X);
|
|
writeln(X);
|
|
Bump(0.5);
|
|
Bump(1.0);
|
|
writeln(X);
|
|
end;
|
|
begin
|
|
Outer();
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_VarParamFloat_CapturedFloat;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcVarParamFloat, '2.5' + LE + '4' + LE, 0);
|
|
end;
|
|
|
|
const
|
|
SrcVarParamDynArr = '''
|
|
program Prg;
|
|
type
|
|
TIntArr = array of Integer;
|
|
procedure MutArr(var A: TIntArr);
|
|
begin
|
|
writeln(A[1]);
|
|
A[2] := 99;
|
|
end;
|
|
procedure GrowArr(var A: TIntArr);
|
|
begin
|
|
SetLength(A, 6);
|
|
A[5] := 55;
|
|
end;
|
|
var
|
|
Arr: TIntArr;
|
|
I: Integer;
|
|
begin
|
|
SetLength(Arr, 4);
|
|
for I := 0 to 3 do
|
|
Arr[I] := I * 10;
|
|
MutArr(Arr);
|
|
writeln(Arr[2]);
|
|
GrowArr(Arr);
|
|
writeln(Length(Arr), ' ', Arr[5]);
|
|
end.
|
|
''';
|
|
|
|
SrcVarParamSAPChar = '''
|
|
program Prg;
|
|
type
|
|
TFive = array[0..4] of Integer;
|
|
procedure MutSA(var A: TFive);
|
|
begin
|
|
writeln(A[1]);
|
|
A[2] := 77;
|
|
end;
|
|
procedure MutPC(var P: PChar);
|
|
begin
|
|
P[0] := Chr(88);
|
|
end;
|
|
var
|
|
SA: TFive;
|
|
Buf: string;
|
|
PC: PChar;
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to 4 do
|
|
SA[I] := I * 10;
|
|
MutSA(SA);
|
|
writeln(SA[2]);
|
|
Buf := Chr(97) + Chr(98) + Chr(99);
|
|
PC := PChar(Buf);
|
|
MutPC(PC);
|
|
writeln(Buf);
|
|
end.
|
|
''';
|
|
|
|
SrcVarParamIntf = '''
|
|
program Prg;
|
|
type
|
|
IGreeter = interface
|
|
procedure Greet;
|
|
end;
|
|
THello = class(TObject, IGreeter)
|
|
FCount: Integer;
|
|
procedure Greet;
|
|
begin
|
|
FCount := FCount + 1;
|
|
writeln('hello ', FCount);
|
|
end;
|
|
end;
|
|
procedure UseIntf(var G: IGreeter);
|
|
begin
|
|
G.Greet();
|
|
end;
|
|
procedure Swap(var G: IGreeter; H2: THello);
|
|
begin
|
|
G := H2;
|
|
end;
|
|
var
|
|
H, HB: THello;
|
|
G: IGreeter;
|
|
begin
|
|
H := THello.Create();
|
|
HB := THello.Create();
|
|
HB.FCount := 100;
|
|
G := H;
|
|
UseIntf(G);
|
|
UseIntf(G);
|
|
writeln(H.FCount);
|
|
Swap(G, HB);
|
|
UseIntf(G);
|
|
writeln(HB.FCount);
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_VarParamDynArray_WriteAndGrow;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcVarParamDynArr,
|
|
'10' + LE + '99' + LE + '6 55' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_VarParamStaticArray_PChar;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcVarParamSAPChar,
|
|
'10' + LE + '77' + LE + 'Xbc' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_VarParamInterface_DispatchAndReassign;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcVarParamIntf,
|
|
'hello 1' + LE + 'hello 2' + LE + '2' + LE + 'hello 101' + LE + '101' + LE, 0);
|
|
end;
|
|
|
|
{ ---------- Metaclass-var constructor dispatch tests ---------- }
|
|
|
|
const SrcMetaclassCreateDerived = '''
|
|
program Prg;
|
|
type
|
|
TAnimal = class(TObject)
|
|
constructor Create;
|
|
end;
|
|
TDog = class(TAnimal)
|
|
constructor Create;
|
|
end;
|
|
TAnimalClass = class of TAnimal;
|
|
constructor TAnimal.Create;
|
|
begin WriteLn('animal') end;
|
|
constructor TDog.Create;
|
|
begin WriteLn('dog') end;
|
|
procedure MakeAndGreet(C: TAnimalClass);
|
|
var A: TAnimal;
|
|
begin
|
|
A := C.Create();
|
|
A.Free()
|
|
end;
|
|
begin
|
|
MakeAndGreet(TAnimal);
|
|
MakeAndGreet(TDog)
|
|
end.
|
|
''';
|
|
|
|
const SrcMetaclassCreateArgs = '''
|
|
program Prg;
|
|
type
|
|
TBase = class(TObject)
|
|
FVal: Integer;
|
|
constructor Create(N: Integer);
|
|
end;
|
|
TChild = class(TBase)
|
|
constructor Create(N: Integer);
|
|
end;
|
|
TBaseClass = class of TBase;
|
|
constructor TBase.Create(N: Integer);
|
|
begin FVal := N end;
|
|
constructor TChild.Create(N: Integer);
|
|
begin FVal := N * 10 end;
|
|
procedure Run(C: TBaseClass; N: Integer);
|
|
var B: TBase;
|
|
begin
|
|
B := C.Create(N);
|
|
WriteLn(B.FVal);
|
|
B.Free()
|
|
end;
|
|
begin
|
|
Run(TBase, 3);
|
|
Run(TChild, 3)
|
|
end.
|
|
''';
|
|
|
|
{ Metaclass-var constructor in STATEMENT position (result discarded):
|
|
cls.Create(); must allocate, run the most-derived ctor for its side
|
|
effects, then free the unreachable instance — not crash. Regression:
|
|
the statement-call lowering used to treat the metaclass typeinfo pointer
|
|
as the object and call a garbage vtable slot. Destroy bumps gFreed, so
|
|
the trailing '1' proves the discarded instance was freed, not leaked. }
|
|
const SrcMetaclassCreateStatement = '''
|
|
program Prg;
|
|
type
|
|
TBase = class(TObject)
|
|
constructor Create(N: Integer); virtual;
|
|
destructor Destroy; override;
|
|
end;
|
|
TChild = class(TBase)
|
|
constructor Create(N: Integer); override;
|
|
end;
|
|
TBaseClass = class of TBase;
|
|
var gVal: Integer;
|
|
var gFreed: Integer;
|
|
constructor TBase.Create(N: Integer);
|
|
begin gVal := N end;
|
|
destructor TBase.Destroy;
|
|
begin gFreed := gFreed + 1; inherited Destroy() end;
|
|
constructor TChild.Create(N: Integer);
|
|
begin inherited Create(N); gVal := gVal * 10 end;
|
|
procedure Run(C: TBaseClass; N: Integer);
|
|
begin
|
|
C.Create(N)
|
|
end;
|
|
begin
|
|
Run(TBase, 4); WriteLn(gVal);
|
|
Run(TChild, 4); WriteLn(gVal);
|
|
WriteLn(gFreed)
|
|
end.
|
|
''';
|
|
|
|
const SrcDirectCreateStatic = '''
|
|
program Prg;
|
|
type
|
|
TBase = class(TObject)
|
|
constructor Create;
|
|
end;
|
|
TChild = class(TBase)
|
|
constructor Create;
|
|
end;
|
|
constructor TBase.Create;
|
|
begin WriteLn('base') end;
|
|
constructor TChild.Create;
|
|
begin WriteLn('child') end;
|
|
begin
|
|
TBase.Create().Free();
|
|
TChild.Create().Free()
|
|
end.
|
|
''';
|
|
|
|
const SrcClassCreateStillWorks = '''
|
|
program Prg;
|
|
type
|
|
TFoo = class(TObject)
|
|
constructor Create;
|
|
end;
|
|
TBar = class(TFoo)
|
|
constructor Create;
|
|
end;
|
|
TFooClass = class of TFoo;
|
|
constructor TFoo.Create;
|
|
begin WriteLn('foo') end;
|
|
constructor TBar.Create;
|
|
begin WriteLn('bar') end;
|
|
var C: TFooClass;
|
|
begin
|
|
C := TBar;
|
|
ClassCreate(C).Free();
|
|
ClassCreate(TFoo).Free()
|
|
end.
|
|
''';
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MetaclassCreate_DispatchesToDerived;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcMetaclassCreateDerived,
|
|
'animal' + LE + 'dog' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MetaclassCreate_WithArgs;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcMetaclassCreateArgs,
|
|
'3' + LE + '30' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_MetaclassCreate_StatementDiscardsResult;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcMetaclassCreateStatement,
|
|
'4' + LE + '40' + LE + '2' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_DirectCreate_StaysStatic;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcDirectCreateStatic,
|
|
'base' + LE + 'child' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_ClassCreate_StillWorks;
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcClassCreateStillWorks,
|
|
'bar' + LE + 'foo' + LE, 0);
|
|
end;
|
|
|
|
procedure TE2EClasses2Tests.TestRun_SelfIndexedRecordFieldAssign;
|
|
const
|
|
Src =
|
|
'program test_self_idx_rec;' + LE +
|
|
'type' + LE +
|
|
' TFrame = record' + LE +
|
|
' Count: Integer;' + LE +
|
|
' end;' + LE +
|
|
' TThing = class' + LE +
|
|
' FStack: array of TFrame;' + LE +
|
|
' procedure Go;' + LE +
|
|
' end;' + LE +
|
|
'procedure TThing.Go;' + LE +
|
|
'begin' + LE +
|
|
' SetLength(Self.FStack, 1);' + LE +
|
|
' Self.FStack[0].Count := Self.FStack[0].Count + 1;' + LE +
|
|
' WriteLn(Self.FStack[0].Count)' + LE +
|
|
'end;' + LE +
|
|
'var t: TThing;' + LE +
|
|
'begin' + LE +
|
|
' t := TThing.Create();' + LE +
|
|
' t.Go()' + LE +
|
|
'end.';
|
|
SrcDirect =
|
|
'program test_self_idx_direct;' + LE +
|
|
'type' + LE +
|
|
' TThing = class' + LE +
|
|
' FItems: array of Integer;' + LE +
|
|
' procedure Go;' + LE +
|
|
' end;' + LE +
|
|
'procedure TThing.Go;' + LE +
|
|
'begin' + LE +
|
|
' SetLength(Self.FItems, 2);' + LE +
|
|
' Self.FItems[0] := 42;' + LE +
|
|
' Self.FItems[1] := 99;' + LE +
|
|
' WriteLn(Self.FItems[0]);' + LE +
|
|
' WriteLn(Self.FItems[1])' + LE +
|
|
'end;' + LE +
|
|
'var t: TThing;' + LE +
|
|
'begin' + LE +
|
|
' t := TThing.Create();' + LE +
|
|
' t.Go()' + LE +
|
|
'end.';
|
|
begin
|
|
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
|
AssertRunsOnAll(SrcDirect, '42' + LE + '99' + LE, 0);
|
|
AssertRunsOnAll(Src, '1' + LE, 0);
|
|
end;
|
|
|
|
initialization
|
|
RegisterTest(TE2EClasses2Tests);
|
|
|
|
end.
|