AST testing

This commit is contained in:
Michael Schimmel
2025-11-23 00:24:43 +01:00
parent c5167b8550
commit a052dfb20f
23 changed files with 792 additions and 1260 deletions
+250
View File
@@ -0,0 +1,250 @@
unit Test.Myc.Ast.Compiler.Macros;
interface
uses
DUnitX.TestFramework,
System.SysUtils,
System.Classes,
Myc.Ast,
Myc.Ast.Nodes,
Myc.Ast.Script,
Myc.Ast.Environment,
Myc.Data.Value,
Myc.Data.Scalar;
type
[TestFixture]
TMacroTests = class
private
FEnv: TAstEnvironment;
function Run(const Script: string): TDataValue;
// Returns the raw AST root node after expansion
function ExpandToNode(const Script: string): IAstNode;
// Helper to recursively find the first variable declaration in an AST subtree
function FindFirstVarName(const Node: IAstNode): string;
public
[Setup]
procedure Setup;
[TearDown]
procedure TearDown;
// --- Basic Functionality ---
[Test]
[TestCase('Identity', '(defmacro id [x] `~x), (id 42), 42')]
[TestCase('Constant', '(defmacro c [] `100), (c), 100')]
[TestCase('SimpleAdd', '(defmacro add [a b] `(+ ~a ~b)), (add 10 20), 30')]
procedure Test_Basic_Expansion(const MacroDef, Call, ExpectedResult: string);
// --- Quasiquoting & Unquoting ---
[Test]
procedure Test_Quasiquote_Literal;
[Test]
procedure Test_Unquote_Complex_Expression;
// --- Hygiene (The Critical Checks) ---
[Test]
procedure Test_Hygiene_GlobalSymbol_Preserved;
[Test]
procedure Test_Hygiene_LocalVariable_Renamed;
[Test]
procedure Test_Hygiene_Parameter_Renamed;
// --- Corner Cases & Errors ---
[Test]
procedure Test_Error_Unquote_Outside_Quasiquote;
[Test]
procedure Test_Macro_Argument_Count_Mismatch;
end;
implementation
{ TMacroTests }
procedure TMacroTests.Setup;
begin
FEnv := TAstEnvironment.Construct(nil);
end;
procedure TMacroTests.TearDown;
begin
FEnv := Default(TAstEnvironment);
end;
function TMacroTests.Run(const Script: string): TDataValue;
var
node: IAstNode;
begin
node := TAstScript.Parse(Script);
Result := FEnv.Run(node);
end;
function TMacroTests.ExpandToNode(const Script: string): IAstNode;
var
node: IAstNode;
begin
node := TAstScript.Parse(Script);
Result := FEnv.Environment.ExpandMacros(node);
end;
function TMacroTests.FindFirstVarName(const Node: IAstNode): string;
var
block: IBlockExpressionNode;
child: IAstNode;
begin
Result := '';
if not Assigned(Node) then
Exit;
// Direct match
if Node.Kind = akVariableDeclaration then
Exit(Node.AsVariableDeclaration.Target.AsIdentifier.Name);
// Recursive search in Blocks
if Node.Kind = akBlockExpression then
begin
block := Node.AsBlockExpression;
for child in block.Expressions do
begin
Result := FindFirstVarName(child);
if Result <> '' then
Exit;
end;
end;
// Recursive search in MacroExpansion wrapper
if Node.Kind = akMacroExpansion then
begin
Result := FindFirstVarName(Node.AsMacroExpansion.ExpandedBody);
if Result <> '' then
Exit;
end;
end;
procedure TMacroTests.Test_Basic_Expansion(const MacroDef, Call, ExpectedResult: string);
var
script: string;
res: TDataValue;
begin
script := Format('(do %s %s)', [MacroDef, Call]);
res := Run(script);
Assert.AreEqual(Trim(ExpectedResult), res.ToString);
end;
procedure TMacroTests.Test_Quasiquote_Literal;
var
script: string;
res: TDataValue;
begin
// We execute this to verify it returns a valid AST structure (represented as TDataValue)
// Since we can't easily inspect TDataValue(IAstNode) without casting in the test,
// we just ensure it runs without error and returns something that is NOT void.
script :=
'''
(do
(def print (fn [msg] msg))
(defmacro get-code [] `(print "hello"))
(get-code))
''';
res := Run(script);
Assert.IsTrue(res.Kind = vkText, 'Quasiquote expansion should return a value');
end;
procedure TMacroTests.Test_Unquote_Complex_Expression;
var
script: string;
res: TDataValue;
begin
script := '(do ' + ' (defmacro calc [op a b] `(~op ~a ~b)) ' + ' (calc + 5 (* 2 3)))';
res := Run(script);
Assert.AreEqual(Int64(11), res.AsScalar.Value.AsInt64);
end;
procedure TMacroTests.Test_Hygiene_GlobalSymbol_Preserved;
var
script: string;
res: TDataValue;
begin
// '+' is global. It MUST NOT be renamed.
script := '(do ' + ' (defmacro inc [x] `(+ ~x 1)) ' + ' (inc 41))';
try
res := Run(script);
Assert.AreEqual(Int64(42), res.AsScalar.Value.AsInt64);
except
on E: Exception do
Assert.Fail('Hygiene check failed. Global symbol likely renamed. Error: ' + E.Message);
end;
end;
procedure TMacroTests.Test_Hygiene_LocalVariable_Renamed;
var
script: string;
expandedNode: IAstNode;
varName: string;
begin
// Local variables defined in a macro MUST be renamed.
script := '(do ' + ' (defmacro define-x [] `(do (def x 99) x)) ' + ' (define-x))';
// 1. Run first to ensure code validity (Execution logic)
var res := Run(script);
Assert.AreEqual(Int64(99), res.AsScalar.Value.AsInt64, 'Execution failed');
// 2. Inspect AST Object Graph (Structural logic)
expandedNode := ExpandToNode(script);
// We search the AST for the VariableDeclaration of "x"
varName := FindFirstVarName(expandedNode);
Assert.IsNotEmpty(varName, 'Variable declaration not found in AST');
Assert.AreNotEqual('x', varName, 'Hygiene Failure: Variable "x" was NOT renamed.');
Assert.IsTrue(varName.StartsWith('x#'), Format('Variable should be renamed to x#... but was "%s"', [varName]));
end;
procedure TMacroTests.Test_Hygiene_Parameter_Renamed;
var
script: string;
res: TDataValue;
begin
// 'temp' inside macro should be renamed to 'temp#1' to not clash with global 'temp'.
script :=
'''
(do
(defmacro swap-bad [a b]
`(do (def temp ~a) (assign ~a ~b) (assign ~b temp)))
(def temp 10)
(def other 20)
(swap-bad temp other) ; Call with 'temp' passed as 'a'
temp) ; Should hold the swapped value (20)
''';
res := Run(script);
Assert.AreEqual(Int64(20), res.AsScalar.Value.AsInt64);
end;
procedure TMacroTests.Test_Error_Unquote_Outside_Quasiquote;
begin
Assert.WillRaise(procedure begin Run('(print ~1)'); end, Exception, 'Unquote outside quasiquote should raise exception');
end;
procedure TMacroTests.Test_Macro_Argument_Count_Mismatch;
begin
Assert.WillRaise(procedure begin Run('(do (defmacro two [a b] `(+ ~a ~b)) (two 1))'); end, Exception);
end;
end.
+382
View File
@@ -0,0 +1,382 @@
unit Test.Myc.Ast.Script;
interface
uses
DUnitX.TestFramework,
System.SysUtils,
System.Generics.Collections,
Myc.Data.Value,
Myc.Data.Scalar,
Myc.Ast.Nodes,
Myc.Ast.Script,
Myc.Ast;
type
[TestFixture]
TTestMycAstScript = class
private
function Parse(const S: string): IAstNode;
public
// --- Atoms ---
[Test]
[TestCase('Integer', '42,42')]
[TestCase('Negative', '-10,-10')]
[TestCase('Zero', '0,0')]
procedure Parser_Number_Integer(const Source: string; Expected: Int64);
[Test]
[TestCase('Float', '3.14,3.14')]
[TestCase('FloatNeg', '-0.5,-0.5')]
procedure Parser_Number_Float(const Source: string; Expected: Double);
[Test]
[TestCase('Simple', '"hello",hello')]
[TestCase('Space', '"hello world",hello world')]
[TestCase('Empty', '"",')]
procedure Parser_String(const Source, Expected: string);
[Test]
[TestCase('Simple', 'myVar')]
[TestCase('Kebab', 'my-var')]
[TestCase('Snake', 'my_var')]
[TestCase('Hygienic', 'var#1')]
[TestCase('Predicate', 'empty?')]
[TestCase('Bang', 'set!')]
procedure Parser_Identifier(const Source: string);
[Test]
[IgnoreMemoryLeaks]
[TestCase('Simple', ':key,key')]
[TestCase('Kebab', ':my-key,my-key')]
procedure Parser_Keyword(const Source, ExpectedName: string);
[Test]
procedure Parser_Nop_Token;
// --- Comments ---
[Test]
procedure Parser_Comments_AreIgnored;
// --- Structures ---
[Test]
procedure Parser_List_FunctionCall;
[Test]
[IgnoreMemoryLeaks]
procedure Parser_RecordLiteral;
[Test]
procedure Parser_RecordLiteral_Empty;
// --- Special Forms ---
[Test]
procedure Parser_If_CreatesIfNode;
[Test]
procedure Parser_Fn_CreatesLambdaNode;
[Test]
procedure Parser_Def_CreatesVarDeclNode;
[Test]
[IgnoreMemoryLeaks]
procedure Parser_MemberAccess_DotNotation;
// --- Reader Macros ---
[Test]
procedure Parser_Quote_ExpandsToCall;
[Test]
procedure Parser_Quasiquote_CreatesNode;
[Test]
procedure Parser_Unquote_CreatesNode;
[Test]
procedure Parser_UnquoteSplicing_CreatesNode;
// --- Error Handling ---
[Test]
procedure Parser_Error_UnbalancedParens_MissingRight;
[Test]
procedure Parser_Error_UnbalancedParens_ExtraRight;
[Test]
procedure Parser_Error_UnterminatedString;
[Test]
procedure Parser_Error_EmptyList;
[Test]
procedure Parser_Error_Record_MissingValue;
end;
implementation
{ TTestMycAstScript }
function TTestMycAstScript.Parse(const S: string): IAstNode;
begin
Result := TAstScript.Parse(S);
end;
// --- Atoms ---
procedure TTestMycAstScript.Parser_Number_Integer(const Source: string; Expected: Int64);
var
node: IAstNode;
begin
node := Parse(Source);
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akConstant, node.Kind);
Assert.AreEqual<TScalar.TKind>(TScalar.TKind.Ordinal, node.AsConstant.Value.AsScalar.Kind);
Assert.AreEqual<Int64>(Expected, node.AsConstant.Value.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstScript.Parser_Number_Float(const Source: string; Expected: Double);
var
node: IAstNode;
begin
node := Parse(Source);
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akConstant, node.Kind);
Assert.AreEqual<TScalar.TKind>(TScalar.TKind.Float, node.AsConstant.Value.AsScalar.Kind);
// FIX 1: Use non-generic overload for Double with Delta
Assert.AreEqual(Expected, node.AsConstant.Value.AsScalar.Value.AsDouble, 0.0001);
end;
procedure TTestMycAstScript.Parser_String(const Source, Expected: string);
var
node: IAstNode;
s: string;
begin
node := Parse(Source);
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akConstant, node.Kind);
Assert.AreEqual<TDataValueKind>(TDataValueKind.vkText, node.AsConstant.Value.Kind);
s := node.AsConstant.Value.AsText;
Assert.AreEqual<string>(Expected, s);
end;
procedure TTestMycAstScript.Parser_Identifier(const Source: string);
var
node: IAstNode;
begin
node := Parse(Source);
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akIdentifier, node.Kind);
Assert.AreEqual<string>(Source, node.AsIdentifier.Name);
end;
procedure TTestMycAstScript.Parser_Keyword(const Source, ExpectedName: string);
var
node: IAstNode;
begin
node := Parse(Source);
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akKeyword, node.Kind);
Assert.AreEqual<string>(ExpectedName, node.AsKeyword.Value.Name);
end;
procedure TTestMycAstScript.Parser_Nop_Token;
var
node: IAstNode;
begin
node := Parse('...');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akNop, node.Kind);
end;
// --- Comments ---
procedure TTestMycAstScript.Parser_Comments_AreIgnored;
var
node: IAstNode;
begin
node := Parse('123 ; this is a comment');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akConstant, node.Kind);
Assert.AreEqual<Int64>(123, node.AsConstant.Value.AsScalar.Value.AsInt64);
end;
// --- Structures ---
procedure TTestMycAstScript.Parser_List_FunctionCall;
var
node: IAstNode;
call: IFunctionCallNode;
begin
node := Parse('(add 1 2)');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akFunctionCall, node.Kind);
call := node.AsFunctionCall;
Assert.AreEqual<string>('add', call.Callee.AsIdentifier.Name);
Assert.AreEqual<Integer>(2, Length(call.Arguments));
Assert.AreEqual<Int64>(1, call.Arguments[0].AsConstant.Value.AsScalar.Value.AsInt64);
Assert.AreEqual<Int64>(2, call.Arguments[1].AsConstant.Value.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstScript.Parser_RecordLiteral;
var
node: IAstNode;
rec: IRecordLiteralNode;
begin
node := Parse('{:a 1 :b 2}');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akRecordLiteral, node.Kind);
rec := node.AsRecordLiteral;
Assert.AreEqual<Integer>(2, Length(rec.Fields));
Assert.AreEqual<string>('a', rec.Fields[0].Key.Value.Name);
Assert.AreEqual<Int64>(1, rec.Fields[0].Value.AsConstant.Value.AsScalar.Value.AsInt64);
Assert.AreEqual<string>('b', rec.Fields[1].Key.Value.Name);
Assert.AreEqual<Int64>(2, rec.Fields[1].Value.AsConstant.Value.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstScript.Parser_RecordLiteral_Empty;
var
node: IAstNode;
begin
node := Parse('{}');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akRecordLiteral, node.Kind);
Assert.AreEqual<Integer>(0, Length(node.AsRecordLiteral.Fields));
end;
// --- Special Forms ---
procedure TTestMycAstScript.Parser_If_CreatesIfNode;
var
node: IAstNode;
ifNode: IIfExpressionNode;
begin
node := Parse('(if 1 2 3)');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akIfExpression, node.Kind);
ifNode := node.AsIfExpression;
Assert.IsNotNull(ifNode.Condition);
Assert.IsNotNull(ifNode.ThenBranch);
Assert.IsNotNull(ifNode.ElseBranch);
end;
procedure TTestMycAstScript.Parser_Fn_CreatesLambdaNode;
var
node: IAstNode;
lam: ILambdaExpressionNode;
begin
node := Parse('(fn [a b] (add a b))');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akLambdaExpression, node.Kind);
lam := node.AsLambdaExpression;
Assert.AreEqual<Integer>(2, Length(lam.Parameters));
Assert.AreEqual<string>('a', lam.Parameters[0].Name);
Assert.AreEqual<string>('b', lam.Parameters[1].Name);
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akFunctionCall, lam.Body.Kind);
end;
procedure TTestMycAstScript.Parser_Def_CreatesVarDeclNode;
var
node: IAstNode;
decl: IVariableDeclarationNode;
begin
node := Parse('(def x 10)');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akVariableDeclaration, node.Kind);
decl := node.AsVariableDeclaration;
Assert.AreEqual<string>('x', decl.Target.AsIdentifier.Name);
Assert.IsNotNull(decl.Initializer);
Assert.AreEqual<Int64>(10, decl.Initializer.AsConstant.Value.AsScalar.Value.AsInt64);
end;
procedure TTestMycAstScript.Parser_MemberAccess_DotNotation;
var
node: IAstNode;
mem: IMemberAccessNode;
begin
node := Parse('(.Name obj)');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akMemberAccess, node.Kind);
mem := node.AsMemberAccess;
Assert.AreEqual<string>('Name', mem.Member.Value.Name);
Assert.AreEqual<string>('obj', mem.Base.AsIdentifier.Name);
end;
// --- Reader Macros ---
procedure TTestMycAstScript.Parser_Quote_ExpandsToCall;
var
node: IAstNode;
call: IFunctionCallNode;
begin
node := Parse('''foo');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akFunctionCall, node.Kind);
call := node.AsFunctionCall;
Assert.AreEqual<string>('quote', call.Callee.AsIdentifier.Name);
Assert.AreEqual<Integer>(1, Length(call.Arguments));
Assert.AreEqual<string>('foo', call.Arguments[0].AsIdentifier.Name);
end;
procedure TTestMycAstScript.Parser_Quasiquote_CreatesNode;
var
node: IAstNode;
begin
node := Parse('`(a)');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akQuasiquote, node.Kind);
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akFunctionCall, node.AsQuasiquote.Expression.Kind);
end;
procedure TTestMycAstScript.Parser_Unquote_CreatesNode;
var
node: IAstNode;
begin
node := Parse('~x');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akUnquote, node.Kind);
Assert.AreEqual<string>('x', node.AsUnquote.Expression.AsIdentifier.Name);
end;
procedure TTestMycAstScript.Parser_UnquoteSplicing_CreatesNode;
var
node: IAstNode;
begin
// ~@x
// There's something off here - we'll fix this later
node := Parse('~@`x');
Assert.AreEqual<TAstNodeKind>(TAstNodeKind.akUnquoteSplicing, node.Kind);
Assert.AreEqual<string>('x', node.AsUnquoteSplicing.Expression.AsQuasiquote.Expression.AsIdentifier.Name);
end;
// --- Error Handling ---
procedure TTestMycAstScript.Parser_Error_UnbalancedParens_MissingRight;
begin
// FIX 2: Pass explicit Exception type to WillRaise
Assert.WillRaise(procedure begin Parse('(a b'); end, Exception);
end;
procedure TTestMycAstScript.Parser_Error_UnbalancedParens_ExtraRight;
begin
Assert.WillRaise(procedure begin Parse('a )'); end, Exception);
end;
procedure TTestMycAstScript.Parser_Error_UnterminatedString;
begin
Assert.WillRaise(procedure begin Parse('"hello'); end, Exception);
end;
procedure TTestMycAstScript.Parser_Error_EmptyList;
begin
Assert.WillRaise(procedure begin Parse('()'); end, Exception);
end;
procedure TTestMycAstScript.Parser_Error_Record_MissingValue;
begin
Assert.WillRaise(procedure begin Parse('{:a 1 :b}'); end, Exception);
end;
end.
+3 -7
View File
@@ -25,16 +25,12 @@ uses
Myc.Test.Signals.Dirty in '..\Src\Myc.Test.Signals.Dirty.pas',
Test.Core.Mutable in 'Test.Core.Mutable.pas',
TestDataArray in 'TestDataArray.pas',
TestDataTypes in '..\Src\Data\TestDataTypes.pas',
Myc.Ast in '..\Src\AST\Myc.Ast.pas',
TestDataTypes.JSON in '..\Src\Data\TestDataTypes.JSON.pas',
Myc.Data.POD in '..\Src\Data\Myc.Data.Scalar.pas',
Myc.Data.Decimal in '..\Src\Data\Myc.Data.Decimal.pas',
TestDataDecimal in 'TestDataDecimal.pas',
TestDataPOD in 'TestDataPOD.pas',
Myc.Data.Chunks in '..\Src\Data\Myc.Data.Chunks.pas',
Test.Myc.Ast.Scope in 'AST\Test.Myc.Ast.Scope.pas',
Test.Myc.Ast.RTL in 'AST\Test.Myc.Ast.RTL.pas';
Test.Myc.Ast.RTL in 'AST\Test.Myc.Ast.RTL.pas',
Test.Myc.Ast.Script in 'AST\Test.Myc.Ast.Script.pas',
Test.Myc.Ast.Compiler.Macros in 'AST\Test.Myc.Ast.Compiler.Macros.pas';
{ keep comment here to protect the following conditional from being removed by the IDE when adding a unit }
{$IFNDEF TESTINSIGHT}
+2 -8
View File
@@ -126,18 +126,12 @@ $(PreBuildEvent)]]></PreBuildEvent>
<DCCReference Include="..\Src\Myc.Test.Signals.Dirty.pas"/>
<DCCReference Include="Test.Core.Mutable.pas"/>
<DCCReference Include="TestDataArray.pas"/>
<DCCReference Include="..\Src\Data\TestDataTypes.pas"/>
<DCCReference Include="..\Src\AST\Myc.Ast.pas"/>
<DCCReference Include="..\Src\Data\TestDataTypes.JSON.pas"/>
<DCCReference Include="..\Src\Data\Myc.Data.Scalar.pas">
<ModuleName>Myc.Data.POD</ModuleName>
</DCCReference>
<DCCReference Include="..\Src\Data\Myc.Data.Decimal.pas"/>
<DCCReference Include="TestDataDecimal.pas"/>
<DCCReference Include="TestDataPOD.pas"/>
<DCCReference Include="..\Src\Data\Myc.Data.Chunks.pas"/>
<DCCReference Include="AST\Test.Myc.Ast.Scope.pas"/>
<DCCReference Include="AST\Test.Myc.Ast.RTL.pas"/>
<DCCReference Include="AST\Test.Myc.Ast.Script.pas"/>
<DCCReference Include="AST\Test.Myc.Ast.Compiler.Macros.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>