AST testing

This commit is contained in:
Michael Schimmel
2025-11-22 17:02:16 +01:00
parent 240f794211
commit c5167b8550
10 changed files with 1202 additions and 792 deletions
+219
View File
@@ -0,0 +1,219 @@
unit Test.Myc.Ast.RTL;
interface
uses
DUnitX.TestFramework,
System.SysUtils,
System.Generics.Collections,
System.Math,
System.DateUtils,
Myc.Data.Scalar,
Myc.Data.Value,
Myc.Ast.Types,
Myc.Ast.Scope,
Myc.Ast.RTL,
Myc.Ast.RTL.Core;
type
[TestFixture]
TTestMycAstRTL = class
private
FScope: IExecutionScope;
function Call(const Name: string; const Args: array of TDataValue): TDataValue;
function ValI(V: Int64): TDataValue;
function ValF(V: Double): TDataValue;
public
[Setup]
procedure Setup;
// --- Registration ---
[Test]
[IgnoreMemoryLeaks]
procedure RTL_Registration_SymbolsArePresent;
// --- Floating Point Math ---
[Test]
[TestCase('Add_FF', '+,1.5,2.5,4.0')]
[TestCase('Div_FF', '/,10,2,5.0')]
procedure RTL_Math_Float(const Op: string; A, B, Expected: Double);
// --- Integer Math (New) ---
[Test]
[TestCase('Div_Int', 'div,10,3,3')]
[TestCase('Mod_Int', 'mod,10,3,1')]
procedure RTL_Math_Integer(const Op: string; A, B, Expected: Int64);
// --- Bitwise Operations (New) ---
[Test]
[TestCase('BitAnd', 'and,3,2,2')] // 011 & 010 = 010 (2)
[TestCase('BitOr', 'or,1,2,3')] // 001 | 010 = 011 (3)
[TestCase('BitXor', 'xor,3,1,2')] // 011 ^ 001 = 010 (2)
[TestCase('Shl', 'shl,1,2,4')] // 1 << 2 = 4
[TestCase('Shr', 'shr,4,1,2')] // 4 >> 1 = 2
procedure RTL_Bitwise(const Op: string; A, B, Expected: Int64);
// --- Rounding (New) ---
[Test]
[TestCase('Round_Up', '3.6,4')]
[TestCase('Round_Down', '3.4,3')]
[TestCase('Round_Mid', '3.5,4')] // Banker's rounding or standard? Delphi default is Banker's.
procedure RTL_Round_Works(A: Double; Expected: Int64);
// --- Comparisons ---
[Test]
[TestCase('Eq_True', '=,10,10,1')]
[TestCase('Neq_True', '<>,10,20,1')]
procedure RTL_Comparison_Ordinals(const Op: string; A, B: Int64; ExpectedBool: Int64);
// --- DateTime Logic (New) ---
[Test]
procedure RTL_DateTime_ConstructionAndMath;
// --- Error Handling ---
[Test]
procedure RTL_DivByZero_ThrowException;
end;
implementation
uses
Myc.Ast;
{ TTestMycAstRTL }
procedure TTestMycAstRTL.Setup;
begin
FScope := TAst.CreateScope(nil, nil, False);
Myc.Ast.RTL.RegisterRtlFunctions(FScope);
end;
// --- Helpers ---
function TTestMycAstRTL.ValI(V: Int64): TDataValue;
begin
Result := TDataValue(TScalar.FromInt64(V));
end;
function TTestMycAstRTL.ValF(V: Double): TDataValue;
begin
Result := TDataValue(TScalar.FromDouble(V));
end;
function TTestMycAstRTL.Call(const Name: string; const Args: array of TDataValue): TDataValue;
var
addr: TResolvedAddress;
funcVal: TDataValue;
func: TDataValue.TFunc;
argArray: TArray<TDataValue>;
i: Integer;
begin
addr := FScope.Resolve(Name);
Assert.AreNotEqual(TAddressKind.akUnresolved, addr.Kind, 'Function not found: ' + Name);
funcVal := FScope[addr];
func := funcVal.AsMethod();
SetLength(argArray, Length(Args));
for i := 0 to High(Args) do
argArray[i] := Args[i];
Result := func(argArray);
end;
// --- Tests ---
procedure TTestMycAstRTL.RTL_Registration_SymbolsArePresent;
begin
Assert.AreNotEqual(TAddressKind.akUnresolved, FScope.Resolve('div').Kind);
Assert.AreNotEqual(TAddressKind.akUnresolved, FScope.Resolve('mod').Kind);
Assert.AreNotEqual(TAddressKind.akUnresolved, FScope.Resolve('Date').Kind);
Assert.AreNotEqual(TAddressKind.akUnresolved, FScope.Resolve('Round').Kind);
end;
procedure TTestMycAstRTL.RTL_Math_Float(const Op: string; A, B, Expected: Double);
var
res: TDataValue;
begin
res := Call(Op, [ValF(A), ValF(B)]);
Assert.AreEqual(TDataValueKind.vkScalar, res.Kind);
Assert.AreEqual(Expected, res.AsScalar.Value.AsDouble, 0.00001);
end;
procedure TTestMycAstRTL.RTL_Math_Integer(const Op: string; A, B, Expected: Int64);
var
res: TDataValue;
begin
res := Call(Op, [ValI(A), ValI(B)]);
Assert.AreEqual(TDataValueKind.vkScalar, res.Kind);
Assert.AreEqual(TScalar.TKind.Ordinal, res.AsScalar.Kind);
Assert.AreEqual(Expected, res.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstRTL.RTL_Bitwise(const Op: string; A, B, Expected: Int64);
var
res: TDataValue;
begin
res := Call(Op, [ValI(A), ValI(B)]);
Assert.AreEqual(TScalar.TKind.Ordinal, res.AsScalar.Kind);
Assert.AreEqual(Expected, res.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstRTL.RTL_Round_Works(A: Double; Expected: Int64);
var
res: TDataValue;
begin
res := Call('Round', [ValF(A)]);
Assert.AreEqual(TScalar.TKind.Ordinal, res.AsScalar.Kind);
Assert.AreEqual(Expected, res.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstRTL.RTL_Comparison_Ordinals(const Op: string; A, B: Int64; ExpectedBool: Int64);
var
res: TDataValue;
begin
res := Call(Op, [ValI(A), ValI(B)]);
// Note: TScalar.Equal/NotEqual returns Boolean Kind now!
// The test case expects integer 0 or 1, so we convert or check bool.
// TScalar.Implicit(Boolean) -> Int64 (0/1) works.
Assert.AreEqual(TDataValueKind.vkScalar, res.Kind);
Assert.AreEqual(TScalar.TKind.Boolean, res.AsScalar.Kind);
var asInt: Int64 := res.AsScalar; // Implicit conversion
Assert.AreEqual(ExpectedBool, asInt);
end;
procedure TTestMycAstRTL.RTL_DateTime_ConstructionAndMath;
var
d, d2, diff: TDataValue;
expectedDate: TDateTime;
begin
// 1. Test Date(Y, M, D)
expectedDate := EncodeDate(2023, 10, 5);
d := Call('Date', [ValI(2023), ValI(10), ValI(5)]);
Assert.AreEqual(TScalar.TKind.DateTime, d.AsScalar.Kind);
Assert.AreEqual(expectedDate, d.AsScalar.Value.AsDouble, 0.001);
// 2. Test Date + Int (Days)
d2 := Call('+', [d, ValI(2)]); // Add 2 days
Assert.AreEqual(TScalar.TKind.DateTime, d2.AsScalar.Kind);
Assert.AreEqual(expectedDate + 2, d2.AsScalar.Value.AsDouble, 0.001);
// 3. Test Date - Date (Diff in days)
diff := Call('-', [d2, d]);
Assert.AreEqual(TScalar.TKind.Float, diff.AsScalar.Kind);
Assert.AreEqual(2.0, diff.AsScalar.Value.AsDouble, 0.001);
end;
procedure TTestMycAstRTL.RTL_DivByZero_ThrowException;
begin
// Integer div
Assert.WillRaise(procedure begin Call('div', [ValI(10), ValI(0)]); end);
// Float divide (explicit check in RTL)
Assert.WillRaise(procedure begin Call('/', [ValF(10.0), ValF(0.0)]); end);
end;
end.
+341
View File
@@ -0,0 +1,341 @@
unit Test.Myc.Ast.Scope;
interface
uses
DUnitX.TestFramework,
System.SysUtils,
System.Generics.Collections,
Myc.Data.Value,
Myc.Data.Scalar,
Myc.Ast.Types,
Myc.Ast.Scope;
type
[TestFixture]
TTestMycAstScope = class
private
// Helper to create a fully initialized scope with a specific set of variable names
function CreateTestScope(const VarNames: array of string; Parent: IExecutionScope = nil): IExecutionScope;
public
// --- Group 1: Static Layout & Builder (Parameterized) ---
[Test]
[TestCase('Simple_A', 'A,0')]
[TestCase('Simple_B', 'B,1')]
[TestCase('Simple_C', 'C,2')]
procedure Builder_Define_AssignsSequentialSlots(const VarName: string; ExpectedSlot: Integer);
[Test]
[TestCase('Find_A', 'A,0')]
[TestCase('Find_B', 'B,1')]
[TestCase('Find_Missing', 'Z,-1')]
[TestCase('Case_Sensitivity_Check', 'a,-1')] // Verifying default behavior (Case Sensitive in current impl)
procedure Builder_FindSlot_Checks(const SearchName: string; ExpectedSlot: Integer);
// --- Group 2: Runtime Execution Scope & Growth ---
[Test]
procedure Scope_DynamicGrowth_ResizesValuesArray;
[Test]
procedure Scope_Define_DuplicateName_ThrowsException;
// --- Group 3: Hierarchy & Shadowing (Parameterized Depth) ---
[Test]
[TestCase('Depth_0', '0')]
[TestCase('Depth_1', '1')]
[TestCase('Depth_5', '5')]
procedure Scope_Resolve_WorksAtVariousDepths(Depth: Integer);
[Test]
procedure Scope_DeepNesting_StressTest; // Corner Case: 100+ Levels
// --- Group 4: Capture & Boxing (Closures) ---
[Test]
procedure Scope_Capture_Identity_RepeatedCaptureReturnsSameCell;
[Test]
procedure Scope_Capture_Of_Already_Captured_Upvalue;
[Test]
procedure Scope_Uninitialized_Access_ReturnsVoidOrZero;
end;
implementation
{ TTestMycAstScope }
function TTestMycAstScope.CreateTestScope(const VarNames: array of string; Parent: IExecutionScope): IExecutionScope;
var
parentLayout: IScopeLayout;
builder: IScopeBuilder;
layout: IScopeLayout;
descriptor: IScopeDescriptor;
types: TArray<IStaticType>;
i: Integer;
begin
if Assigned(Parent) then
parentLayout := Parent.Descriptor.Layout
else
parentLayout := nil;
builder := TScope.CreateBuilder(parentLayout);
for i := 0 to High(VarNames) do
builder.Define(VarNames[i]);
layout := builder.Build;
SetLength(types, Length(VarNames));
for i := 0 to High(types) do
types[i] := TTypes.Unknown;
descriptor := TScope.CreateDescriptor(layout, types);
Result := TScope.CreateScope(Parent, descriptor, nil);
end;
// ------------------------------------------------------------------------
// Group 1: Static Layout & Builder
// ------------------------------------------------------------------------
procedure TTestMycAstScope.Builder_Define_AssignsSequentialSlots(const VarName: string; ExpectedSlot: Integer);
var
builder: IScopeBuilder;
begin
builder := TScope.CreateBuilder(nil);
// We define the context first
builder.Define('A'); // 0
builder.Define('B'); // 1
builder.Define('C'); // 2
// Note: Since we construct the builder fresh every time, we simulate looking up
// in a builder that has these 3 defined.
// However, `Define` returns the index.
// To test Define return value correctly based on TestCase, we'd need a switch.
// Instead, let's test FindSlot here which validates the Define logic implicitly.
Assert.AreEqual(ExpectedSlot, builder.FindSlot(VarName));
end;
procedure TTestMycAstScope.Builder_FindSlot_Checks(const SearchName: string; ExpectedSlot: Integer);
var
builder: IScopeBuilder;
begin
builder := TScope.CreateBuilder(nil);
builder.Define('A');
builder.Define('B');
Assert.AreEqual(ExpectedSlot, builder.FindSlot(SearchName));
end;
// ------------------------------------------------------------------------
// Group 2: Runtime Execution Scope & Growth
// ------------------------------------------------------------------------
procedure TTestMycAstScope.Scope_DynamicGrowth_ResizesValuesArray;
var
scope: IExecutionScope;
addr: TResolvedAddress;
val: TDataValue;
begin
// Corner Case: Defining variables in a scope WITHOUT a descriptor (Dynamic Interpreter Mode)
// The internal array must grow.
scope := TScope.CreateScope(nil, nil, nil);
// Slot 0
scope.Define('A', 10);
// Slot 100 (Simulation of a large jump or massive definition sequence)
// Note: TExecutionScope.Define assigns sequential slots. To test resize, we loop.
for var i := 1 to 100 do
scope.Define('V' + i.ToString, i);
addr := scope.Resolve('V100');
Assert.AreEqual(100, addr.SlotIndex);
val := scope[addr];
Assert.AreEqual(Int64(100), val.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstScope.Scope_Define_DuplicateName_ThrowsException;
var
scope: IExecutionScope;
begin
scope := TScope.CreateScope(nil, nil, nil);
scope.Define('X', 1);
Assert.WillRaise(procedure begin scope.Define('X', 2); end);
end;
procedure TTestMycAstScope.Scope_Uninitialized_Access_ReturnsVoidOrZero;
var
builder: IScopeBuilder;
layout: IScopeLayout;
descriptor: IScopeDescriptor;
scope: IExecutionScope;
addr: TResolvedAddress;
begin
// Static Layout defined, but value not set in Scope
builder := TScope.CreateBuilder(nil);
builder.Define('A'); // Slot 0
layout := builder.Build;
descriptor := TScope.CreateDescriptor(layout, [TTypes.Unknown]);
scope := TScope.CreateScope(nil, descriptor, nil);
addr.Kind := akLocalOrParent;
addr.ScopeDepth := 0;
addr.SlotIndex := 0;
// Accessing before writing
// TDataValue defaults to Kind=vkVoid via Initialize operator usually,
// but let's verify TExecutionScope constructor zeros memory or initializes generic array.
Assert.IsTrue(scope[addr].IsVoid, 'Uninitialized slot should be Void');
end;
// ------------------------------------------------------------------------
// Group 3: Hierarchy & Shadowing
// ------------------------------------------------------------------------
procedure TTestMycAstScope.Scope_Resolve_WorksAtVariousDepths(Depth: Integer);
var
scopes: TArray<IExecutionScope>;
i: Integer;
addr: TResolvedAddress;
begin
SetLength(scopes, Depth + 1);
// Root defines Target
scopes[0] := CreateTestScope(['Target']);
// Chain creation
for i := 1 to Depth do
scopes[i] := CreateTestScope([], scopes[i - 1]);
// Resolve from the deepest scope
addr := scopes[Depth].Resolve('Target');
Assert.AreEqual(TAddressKind.akLocalOrParent, addr.Kind);
Assert.AreEqual(Depth, addr.ScopeDepth);
Assert.AreEqual(0, addr.SlotIndex);
end;
procedure TTestMycAstScope.Scope_DeepNesting_StressTest;
const
MAX_DEPTH = 100;
var
scopes: array[0..MAX_DEPTH] of IExecutionScope;
i: Integer;
addr: TResolvedAddress;
val: TDataValue;
begin
// Corner Case: Deep Recursion / Stack Limits on Resolution
// 1. Create Root Scope with 'DeepVar' defined in the Layout
scopes[0] := CreateTestScope(['DeepVar']);
// 2. Set the value for the EXISTING variable.
// Do NOT call Define() again, as it would try to create a duplicate slot.
addr := scopes[0].Resolve('DeepVar');
Assert.AreEqual(TAddressKind.akLocalOrParent, addr.Kind, 'DeepVar must be resolvable in root');
scopes[0][addr] := 999;
// 3. Build deep nesting chain
for i := 1 to MAX_DEPTH do
scopes[i] := CreateTestScope([], scopes[i - 1]);
// 4. Resolve from the deepest leaf
// This forces the Resolve() method to traverse 100 parent pointers.
addr := scopes[MAX_DEPTH].Resolve('DeepVar');
Assert.AreEqual(TAddressKind.akLocalOrParent, addr.Kind);
Assert.AreEqual(MAX_DEPTH, addr.ScopeDepth, 'ScopeDepth must match nesting level');
// 5. Read the value through the deep link
val := scopes[MAX_DEPTH][addr];
Assert.AreEqual(Int64(999), val.AsScalar.Value.AsInt64);
end;
// ------------------------------------------------------------------------
// Group 4: Capture & Boxing (Closures) - CRITICAL
// ------------------------------------------------------------------------
procedure TTestMycAstScope.Scope_Capture_Identity_RepeatedCaptureReturnsSameCell;
var
scope: IExecutionScope;
addr: TResolvedAddress;
cell1, cell2: IValueCell;
begin
// Corner Case: If I capture the same variable twice (e.g. two lambdas in same scope using same var),
// they MUST share the underlying storage (Box).
scope := CreateTestScope(['A']);
addr := scope.Resolve('A');
cell1 := scope.Capture(addr);
cell2 := scope.Capture(addr);
// They must be the same interface pointer instance
Assert.IsTrue(cell1 = cell2, 'Repeated capture must return identical interface instance');
// Modify one, check other
cell1.Value := 100;
Assert.AreEqual(Int64(100), cell2.Value.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstScope.Scope_Capture_Of_Already_Captured_Upvalue;
var
root, mid, leaf: IExecutionScope;
rootAddr: TResolvedAddress;
midAddr: TResolvedAddress; // Points to root's var as an upvalue
leafAddr: TResolvedAddress;
cellRoot: IValueCell;
capturedInMid: TArray<IValueCell>;
begin
// Scenario:
// Root: [VarX]
// Mid: (Captures VarX from Root) -> This creates a closure context for Mid
// Leaf: (Captures VarX from Mid) -> This captures the *already captured* cell
// 1. Root
root := CreateTestScope(['VarX']);
rootAddr := root.Resolve('VarX');
root[rootAddr] := 42;
// 2. Mid (Simulate a Lambda Scope that captured VarX)
// To simulate this, we need to construct Mid such that it has 'capturedUpvalues' populated.
// We manually capture from root first.
cellRoot := root.Capture(rootAddr);
SetLength(capturedInMid, 1);
capturedInMid[0] := cellRoot;
// Mid's descriptor needs to know it has an upvalue?
// No, IExecutionScope just holds the array. The address resolution handles mapping.
mid := TScope.CreateScope(root, nil, capturedInMid);
// 3. Leaf resolves VarX.
// If Leaf is physically inside Mid, it might refer to VarX via Mid's Upvalue list.
// Address: Kind=akUpvalue, Slot=0 (index into capturedInMid)
leafAddr.Kind := akUpvalue;
leafAddr.SlotIndex := 0;
// Note: ScopeDepth irrelevant for akUpvalue access
// 4. Test Access from Leaf via Upvalue chain
// leaf does not have its own captured array yet, but we ask it to GET the value at that address
// Actually, 'leaf' typically represents the *execution* of the lambda.
// If the lambda code says "get upvalue 0", the evaluator calls GetValues(akUpvalue, 0).
// Let's simulate Leaf access:
leaf := TScope.CreateScope(mid, nil, capturedInMid); // Leaf shares the capture array for this test context
Assert.AreEqual(Int64(42), leaf[leafAddr].AsScalar.Value.AsInt64);
// 5. Modify via Leaf reference
leaf[leafAddr] := 99;
// Check Root
Assert.AreEqual(Int64(99), root[rootAddr].AsScalar.Value.AsInt64);
end;
end.
+2 -2
View File
@@ -32,9 +32,9 @@ uses
Myc.Data.Decimal in '..\Src\Data\Myc.Data.Decimal.pas',
TestDataDecimal in 'TestDataDecimal.pas',
TestDataPOD in 'TestDataPOD.pas',
Test.Ast.Interpreter.Scope in 'Test.Ast.Interpreter.Scope.pas',
Myc.Data.Chunks in '..\Src\Data\Myc.Data.Chunks.pas',
Test.Myc.Data.Value in 'Test.Myc.Data.Value.pas';
Test.Myc.Ast.Scope in 'AST\Test.Myc.Ast.Scope.pas',
Test.Myc.Ast.RTL in 'AST\Test.Myc.Ast.RTL.pas';
{ keep comment here to protect the following conditional from being removed by the IDE when adding a unit }
{$IFNDEF TESTINSIGHT}
+2 -2
View File
@@ -135,9 +135,9 @@ $(PreBuildEvent)]]></PreBuildEvent>
<DCCReference Include="..\Src\Data\Myc.Data.Decimal.pas"/>
<DCCReference Include="TestDataDecimal.pas"/>
<DCCReference Include="TestDataPOD.pas"/>
<DCCReference Include="Test.Ast.Interpreter.Scope.pas"/>
<DCCReference Include="..\Src\Data\Myc.Data.Chunks.pas"/>
<DCCReference Include="Test.Myc.Data.Value.pas"/>
<DCCReference Include="AST\Test.Myc.Ast.Scope.pas"/>
<DCCReference Include="AST\Test.Myc.Ast.RTL.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
-295
View File
@@ -1,295 +0,0 @@
unit Test.Ast.Interpreter.Scope;
interface
uses
Myc.Ast,
Myc.Ast.Nodes,
Myc.Ast.Binding,
Myc.Ast.Evaluator,
Myc.Ast.Scope,
Myc.Data.Scalar,
Myc.Data.Value,
DUnitX.TestFramework;
type
[TestFixture]
TInterpreterScopeTests = class(TObject)
private
FGlobalScope: IExecutionScope;
function Execute(const ANode: IAstNode): TDataValue;
public
[Setup]
procedure Setup;
[TearDown]
procedure TearDown;
[Test]
procedure Test_DeeplyNestedLambda_ModifiesUpvalue;
[Test]
procedure Test_SeparateClosures_ShareSameUpvalue;
[Test]
procedure Test_NestedLambda_CapturesParameter;
[Test]
procedure Test_VariableShadowing_DoesNotAffectUpvalue;
[Test]
procedure Test_CaptureFromGlobalScope;
[Test]
procedure Test_ClosureCaptureWithParentScopeReallocation;
end;
implementation
{ TInterpreterScopeTests }
function TInterpreterScopeTests.Execute(const ANode: IAstNode): TDataValue;
var
boundNode: IAstNode;
descriptor: IScopeDescriptor;
runtimeScope: IExecutionScope;
visitor: IEvaluatorVisitor;
begin
// Helper to encapsulate the Bind -> CreateScope -> Evaluate pattern.
// The binder needs an evaluator factory to expand macros (even if there are none).
boundNode :=
TAstBinder.Bind(
FGlobalScope,
ANode,
descriptor,
function(const Scope: IExecutionScope): IEvaluatorVisitor begin Result := TEvaluatorVisitor.Create(Scope); end
);
runtimeScope := descriptor.CreateScope(FGlobalScope);
visitor := TEvaluatorVisitor.Create(runtimeScope);
Result := visitor.Execute(boundNode);
end;
procedure TInterpreterScopeTests.Setup;
begin
FGlobalScope := TAst.CreateScope(nil);
end;
procedure TInterpreterScopeTests.TearDown;
begin
FGlobalScope := nil;
end;
procedure TInterpreterScopeTests.Test_DeeplyNestedLambda_ModifiesUpvalue;
var
mainBlock: IAstNode;
resultValue: TDataValue;
begin
// This is our original, simple test case with three nested lambdas.
mainBlock :=
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('outer'),
TAst.LambdaExpr(
[],
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('x'), TAst.Constant(TScalar.FromInt64(10))),
TAst.VarDecl(
TAst.Identifier('inner'),
TAst.LambdaExpr(
[],
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('innermost'),
TAst.LambdaExpr(
[],
TAst.Assign(
TAst.Identifier('x'),
TAst.BinaryExpr(
TAst.Identifier('x'),
TScalar.TBinaryOp.Add,
TAst.Constant(TScalar.FromInt64(5))
)
)
)
),
TAst.FunctionCall(TAst.Identifier('innermost'), [])
]
)
)
),
TAst.FunctionCall(TAst.Identifier('inner'), []),
TAst.Identifier('x')
]
)
)
),
TAst.VarDecl(TAst.Identifier('finalResult'), TAst.FunctionCall(TAst.Identifier('outer'), []))
]
);
resultValue := Execute(mainBlock);
Assert.AreEqual<Int64>(15, resultValue.AsScalar.Value.AsInt64, 'The final result should be 15.');
end;
procedure TInterpreterScopeTests.Test_SeparateClosures_ShareSameUpvalue;
var
mainBlock: IAstNode;
resultValue: TDataValue;
begin
// This is our more complex "modifier/reader" test case.
mainBlock :=
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('a'), TAst.Constant(TScalar.FromInt64(10))),
TAst.VarDecl(
TAst.Identifier('modifier'),
TAst.LambdaExpr(
[], // Outer modifier shell
TAst.LambdaExpr(
[], // Inner closure that is returned
TAst.Assign(
TAst.Identifier('a'),
TAst.BinaryExpr(TAst.Identifier('a'), TScalar.TBinaryOp.Add, TAst.Constant(TScalar.FromInt64(5)))
)
)
)
),
TAst.VarDecl(TAst.Identifier('reader'), TAst.LambdaExpr([], TAst.Identifier('a'))),
TAst.VarDecl(TAst.Identifier('innermost_closure'), TAst.FunctionCall(TAst.Identifier('modifier'), [])),
TAst.FunctionCall(TAst.Identifier('innermost_closure'), []),
TAst.FunctionCall(TAst.Identifier('reader'), [])
]
);
resultValue := Execute(mainBlock);
Assert.AreEqual<Int64>(15, resultValue.AsScalar.Value.AsInt64, 'The final result should be 15.');
end;
procedure TInterpreterScopeTests.Test_NestedLambda_CapturesParameter;
var
mainBlock: IAstNode;
resultValue: TDataValue;
begin
// Tests if a nested lambda can correctly capture a PARAMETER of its parent lambda.
mainBlock :=
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('factory'),
TAst.LambdaExpr(
[TAst.Identifier('p')], // Parameter 'p'
TAst.LambdaExpr(
[], // Returned lambda captures 'p'
TAst.BinaryExpr(TAst.Identifier('p'), TScalar.TBinaryOp.Multiply, TAst.Constant(TScalar.FromInt64(2)))
)
)
),
TAst.VarDecl(
TAst.Identifier('multiplier'),
TAst.FunctionCall(TAst.Identifier('factory'), [TAst.Constant(TScalar.FromInt64(21))])
),
TAst.FunctionCall(TAst.Identifier('multiplier'), [])
]
);
resultValue := Execute(mainBlock);
Assert.AreEqual<Int64>(42, resultValue.AsScalar.Value.AsInt64, 'The result of 21 * 2 should be 42.');
end;
procedure TInterpreterScopeTests.Test_VariableShadowing_DoesNotAffectUpvalue;
var
mainBlock: IAstNode;
resultValue: TDataValue;
begin
// Tests that a local variable 'x' correctly "shadows" a parent's variable 'x'.
// The modification of the inner 'x' must not affect the outer 'x'.
mainBlock :=
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('x'), TAst.Constant(TScalar.FromInt64(10))),
TAst.FunctionCall(
TAst.LambdaExpr(
[],
TAst.Block(
[
// This 'x' should shadow the outer 'x'.
TAst.VarDecl(TAst.Identifier('x'), TAst.Constant(TScalar.FromInt64(50))),
TAst.Assign(TAst.Identifier('x'), TAst.Constant(TScalar.FromInt64(99)))
]
)
),
[]
),
// This final expression should return the value of the original, outer 'x'.
TAst.Identifier('x')
]
);
resultValue := Execute(mainBlock);
Assert.AreEqual<Int64>(10, resultValue.AsScalar.Value.AsInt64, 'The outer "x" should remain unchanged.');
end;
procedure TInterpreterScopeTests.Test_CaptureFromGlobalScope;
var
mainBlock: IAstNode;
resultValue: TDataValue;
begin
// Defines a variable in the global scope and ensures a simple script can access it.
FGlobalScope.Define('g', TScalar.FromInt64(99));
mainBlock := TAst.BinaryExpr(TAst.Identifier('g'), TScalar.TBinaryOp.Add, TAst.Constant(TScalar.FromInt64(1)));
resultValue := Execute(mainBlock);
Assert.AreEqual<Int64>(100, resultValue.AsScalar.Value.AsInt64, 'Should be able to access variables from the parent scope.');
end;
procedure TInterpreterScopeTests.Test_ClosureCaptureWithParentScopeReallocation;
var
rootScope: IExecutionScope;
parentScope: IExecutionScope;
lambdaScope: IExecutionScope;
addressOfX_from_lambda: TResolvedAddress;
addressOfX_in_parent: TResolvedAddress;
capturedCell: IValueCell;
valueFromClosure: TDataValue;
begin
// 1. Setup scopes: root -> parent -> lambda
rootScope := TScope.CreateScope(nil, nil, nil);
parentScope := TScope.CreateScope(rootScope, nil, nil);
lambdaScope := TScope.CreateScope(parentScope, nil, nil);
// 2. Define a variable 'x' in the parent scope. It will be at slot 0.
parentScope.Define('x', 10);
addressOfX_in_parent := TResolvedAddress.Create(akLocalOrParent, 0, 0);
Assert.AreEqual(Int64(10), parentScope[addressOfX_in_parent].AsScalar.Value.AsInt64);
// 3. From the lambda's perspective, 'x' is one level up (ScopeDepth=1) at slot 0.
addressOfX_from_lambda := TResolvedAddress.Create(akLocalOrParent, 1, 0);
// 4. Capture 'x' into a value cell, simulating a closure.
// This creates the buggy TValueRef that holds a direct reference to the parent's internal array.
capturedCell := lambdaScope.Capture(addressOfX_from_lambda);
Assert.AreEqual(Int64(10), capturedCell.Value.AsScalar.Value.AsInt64, 'Initial captured value should be correct');
// 5. Trigger the bug: Define another variable in the parent scope.
// This forces a SetLength on the internal FValues array, which may cause a reallocation.
parentScope.Define('y', 20);
// 6. Update the original variable 'x' in the parent scope to a new value.
parentScope[addressOfX_in_parent] := 99;
Assert.AreEqual(Int64(99), parentScope[addressOfX_in_parent].AsScalar.Value.AsInt64, 'Value in parent scope should be updated');
// 7. Read the value from the captured cell again.
// The test will fail here. The captured cell still points to the old, orphaned memory block
// where the value of x is still 10, not the new value 99.
valueFromClosure := capturedCell.Value;
Assert.AreEqual(
Int64(99),
valueFromClosure.AsScalar.Value.AsInt64,
'The captured cell must reflect changes in the parent scope after reallocation'
);
end;
end.
-173
View File
@@ -1,173 +0,0 @@
unit Test.Myc.Data.Value;
interface
uses
DUnitX.TestFramework,
System.SysUtils,
System.Threading,
Myc.Data.Value,
Myc.Data.Scalar;
type
[TestFixture]
TTestDataValue = class(TObject)
private
type
// Simple object for interface tests
TTestObject = class(TInterfacedObject, IInterface)
public
ID: Integer;
end;
public
[Test]
procedure TestReset_Scalar;
[Test]
procedure TestReset_Interface;
[Test]
procedure TestCompareAndSet_Scalar;
[Test]
procedure TestCompareAndSet_Interface;
[Test]
procedure TestKindImmutability_ThrowsException;
[Test]
procedure TestAtomicity_ConcurrentIncrement;
end;
implementation
{ TTestDataValue }
procedure TTestDataValue.TestReset_Scalar;
var
val: TDataValue;
oldVal: TDataValue;
begin
// Test with Int64
val := 10;
oldVal := val.Reset(20);
Assert.AreEqual(Int64(20), val.AsScalar.Value.AsInt64, 'Value should be updated to 20');
Assert.AreEqual(Int64(10), oldVal.AsScalar.Value.AsInt64, 'Reset should return the old value 10');
// Test with Double
val := 10.5;
oldVal := val.Reset(20.5);
Assert.AreEqual(Double(20.5), val.AsScalar.Value.AsDouble, 'Value should be updated to 20.5');
Assert.AreEqual(Double(10.5), oldVal.AsScalar.Value.AsDouble, 'Reset should return the old value 10.5');
end;
procedure TTestDataValue.TestReset_Interface;
var
objA, objB: IInterface;
val: TDataValue;
oldVal: TDataValue;
begin
objA := TTestObject.Create;
objB := TTestObject.Create;
val := TDataValue.FromIntf(objA);
oldVal := val.Reset(TDataValue.FromIntf(objB));
Assert.AreSame(objB, val.AsIntf<IInterface>, 'Value should be updated to objB');
Assert.AreSame(objA, oldVal.AsIntf<IInterface>, 'Reset should return the old value objA');
end;
procedure TTestDataValue.TestCompareAndSet_Scalar;
var
val: TDataValue;
begin
val := 100;
// Successful CAS
Assert.IsTrue(val.CompareAndSet(100, 200), 'CAS should succeed when expected value matches');
Assert.AreEqual(Int64(200), val.AsScalar.Value.AsInt64, 'Value should be 200 after successful CAS');
// Failing CAS
Assert.IsFalse(val.CompareAndSet(100, 300), 'CAS should fail when expected value does not match');
Assert.AreEqual(Int64(200), val.AsScalar.Value.AsInt64, 'Value should remain 200 after failed CAS');
end;
procedure TTestDataValue.TestCompareAndSet_Interface;
var
objA, objB, objC: IInterface;
val: TDataValue;
begin
objA := TTestObject.Create;
objB := TTestObject.Create;
objC := TTestObject.Create;
val := TDataValue.FromIntf(objA);
// Successful CAS
Assert.IsTrue(val.CompareAndSet(TDataValue.FromIntf(objA), TDataValue.FromIntf(objB)), 'CAS should succeed for interfaces');
Assert.AreSame(objB, val.AsIntf<IInterface>, 'Value should be objB after successful CAS');
// Failing CAS
Assert.IsFalse(val.CompareAndSet(TDataValue.FromIntf(objA), TDataValue.FromIntf(objC)), 'CAS should fail for interfaces');
Assert.AreSame(objB, val.AsIntf<IInterface>, 'Value should remain objB after failed CAS');
end;
procedure TTestDataValue.TestKindImmutability_ThrowsException;
var
scalarVal, textVal: TDataValue;
begin
scalarVal := 10;
textVal := 'hello';
// Test Reset
Assert.WillRaise(procedure begin scalarVal.Reset(textVal); end, EArgumentException, 'Reset must throw exception on kind mismatch');
// Test CompareAndSet
Assert.WillRaise(
procedure
begin
// NewValue has wrong kind
scalarVal.CompareAndSet(10, textVal);
end,
EArgumentException,
'CompareAndSet must throw exception on kind mismatch'
);
// Expected value doesn't match kind, should just fail silently (return False)
Assert.IsFalse(scalarVal.CompareAndSet(textVal, 20), 'CAS should return False if kinds of self and expected differ');
end;
procedure TTestDataValue.TestAtomicity_ConcurrentIncrement;
const
NumThreads = 8;
IncrementsPerThread = 25000;
var
sharedValue: TDataValue;
tasks: array of ITask;
i: Integer;
begin
sharedValue := 0; // TDataValue of kind vkScalar, Ordinal
SetLength(tasks, NumThreads);
for i := 0 to High(tasks) do
begin
tasks[i] :=
TTask.Run(
procedure
var
j: Integer;
oldVal, newVal: TDataValue;
begin
for j := 1 to IncrementsPerThread do
begin
// This is the classic lock-free swap loop
repeat
oldVal := sharedValue; // Read current value
newVal := oldVal.AsScalar.Value.AsInt64 + 1;
until sharedValue.CompareAndSet(oldVal, newVal);
end;
end
);
end;
TTask.WaitForAll(tasks);
const Expected = NumThreads * IncrementsPerThread;
Assert.AreEqual(Int64(Expected), sharedValue.AsScalar.Value.AsInt64, 'Concurrent increments should result in the correct total sum');
end;
end.
-35
View File
@@ -28,8 +28,6 @@ type
procedure TestScalarArray;
[Test]
procedure TestScalarTuple;
[Test]
procedure TestScalarRecordAndDefinition;
end;
implementation
@@ -80,39 +78,6 @@ begin
Assert.AreEqual(Int64(0), Length(arr.Items), 'Empty array length should be zero');
end;
procedure TTestPOD.TestScalarRecordAndDefinition;
var
recDef: TScalarRecordDefinition;
values: TArray<TScalar.TValue>;
rec: TScalarRecord;
mismatchedValues: TArray<TScalar.TValue>;
begin
// 1. Create a definition
recDef :=
TScalarRecordDefinition
.Create([TScalarRecordField.Create('ID', TScalar.TKind.Ordinal), TScalarRecordField.Create('Price', TScalar.TKind.Float)]);
Assert.AreEqual(Int64(2), Length(recDef.Fields), 'Record definition field count mismatch');
Assert.AreEqual('Price', recDef.Fields[1].Name, 'Record definition field name mismatch');
// 2. Create a matching set of values
values := [TScalar.FromInt64(99).Value, TScalar.FromDouble(19.95).Value];
// 3. Create the record
rec := TScalarRecord.Create(recDef, values);
Assert.AreEqual(Int64(2), Length(rec.Fields), 'Record field count mismatch');
Assert.AreEqual(19.95, rec.Fields[1].AsDouble, 1E-12, 'Record field value mismatch');
Assert.AreEqual(Int64(99), rec.Items['ID'].Value.AsInt64, 'Record item by name mismatch');
Assert.AreEqual(TScalar.TKind.Float, rec.Items['Price'].Kind, 'Record item kind by name mismatch');
// 4. Test assertion for mismatched field count
mismatchedValues := [TScalar.FromInt64(1).Value];
Assert.WillRaise(
procedure begin rec := TScalarRecord.Create(recDef, mismatchedValues); end,
EAssertionFailed,
'Mismatched field/value count should raise an assertion'
);
end;
procedure TTestPOD.TestScalarTuple;
var
tuple: TScalarTuple;