Static specialization WIP

This commit is contained in:
Michael Schimmel
2025-11-19 14:38:40 +01:00
parent c129c1a3ae
commit 138e7ac454
26 changed files with 2349 additions and 1110 deletions
File diff suppressed because one or more lines are too long
+2 -1
View File
@@ -26,7 +26,8 @@ uses
Myc.Ast.Compiler.Lowering in '..\Src\AST\Myc.Ast.Compiler.Lowering.pas',
Myc.Ast.Compiler.TypeChecker in '..\Src\AST\Myc.Ast.Compiler.TypeChecker.pas',
Myc.Ast.Compiler.Macros in '..\Src\AST\Myc.Ast.Compiler.Macros.pas',
Myc.Ast.Environment in '..\Src\AST\Myc.Ast.Environment.pas';
Myc.Ast.Environment in '..\Src\AST\Myc.Ast.Environment.pas',
Myc.Ast.Compiler.Specializer in '..\Src\AST\Myc.Ast.Compiler.Specializer.pas';
{$R *.res}
+1
View File
@@ -157,6 +157,7 @@
<DCCReference Include="..\Src\AST\Myc.Ast.Compiler.TypeChecker.pas"/>
<DCCReference Include="..\Src\AST\Myc.Ast.Compiler.Macros.pas"/>
<DCCReference Include="..\Src\AST\Myc.Ast.Environment.pas"/>
<DCCReference Include="..\Src\AST\Myc.Ast.Compiler.Specializer.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
+1 -1
View File
@@ -196,7 +196,7 @@ object Form1: TForm1
'Unbound'
'Expanded'
'Bound'
'Lowered')
'Specialized')
ItemIndex = 0
Position.X = 672.000000000000000000
Position.Y = 576.000000000000000000
+84 -66
View File
@@ -117,12 +117,12 @@ type
FTriggerTest: TAstEnvironment;
procedure WorkspaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
function CreateEnvironment: TAstEnvironment;
// Helper function to encapsulate the Compile -> Evaluate pattern
function ExecuteAst(const ANode: IAstNode): TDataValue;
procedure UpdateScript;
procedure ShowVizualization(X, Y: Single);
procedure PrintScript(const Node: IAstNode);
function CompileAstStage: IAstNode;
public
{ Public declarations }
end;
@@ -175,7 +175,11 @@ begin
[],
TAst.Assign(
TAst.Identifier('x'),
TAst.BinaryExpr(TAst.Identifier('x'), TScalar.TBinaryOp.Add, TAst.Constant(5))
// --- Ersetzt ---
TAst.FunctionCall(
TAst.Identifier('+'),
[TAst.Identifier('x'), TAst.Constant(5)]
)
)
)
),
@@ -206,19 +210,30 @@ begin
FWorkspace.Repaint;
end;
function TForm1.CompileAstStage: IAstNode;
begin
Result := FCurrUnboundAst;
if CompilerStageBox.ItemIndex > 0 then
begin
Result := FEnvironment.Environment.ExpandMacros(Result);
if CompilerStageBox.ItemIndex > 1 then
begin
var desc: IScopeDescriptor;
Result := FEnvironment.Environment.Bind(Result, desc);
if CompilerStageBox.ItemIndex > 2 then
Result := FEnvironment.Environment.Specialize(Result, desc);
end;
end;
end;
procedure TForm1.CompilerStageBoxChange(Sender: TObject);
begin
ShowVizualization(14, 14);
end;
function TForm1.CreateEnvironment: TAstEnvironment;
begin
if DebugBox.IsChecked then
Result.SetDebugMode(Memo1.Lines, ShowScopeBox.IsChecked)
else
Result.SetStandardMode;
end;
// Simplified ExecuteAst using TEnvironment
function TForm1.ExecuteAst(const ANode: IAstNode): TDataValue;
begin
@@ -232,7 +247,8 @@ begin
FEnvironment.SetStandardMode;
try
FCurrExec := FEnvironment.Compile(ANode);
var funcDef := TAst.LambdaExpr([], ANode);
FCurrExec := FEnvironment.Compile(funcDef).Func;
Result := FCurrExec([]);
except
@@ -247,7 +263,7 @@ end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FEnvironment := CreateEnvironment;
FEnvironment := TAstEnvironment.Construct(TAst.CreateScope(nil));
FWorkspace := TAuraWorkspace.Create(Panel2);
FWorkspace.Parent := Panel2;
@@ -255,8 +271,6 @@ begin
FWorkspace.ClipChildren := true;
FWorkspace.OnMouseDown := WorkspaceMouseDown;
RegisterRtlFunctions(FEnvironment.RootScope);
// Register the SMA factory into the environment
var RegFunc :=
procedure(const Scope: IExecutionScope)
@@ -276,36 +290,45 @@ begin
[
TAst.Assign(
TAst.Identifier('sum'),
TAst.BinaryExpr(TAst.Identifier('sum'), TScalar.TBinaryOp.Add, TAst.Identifier('val'))
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('sum'), TAst.Identifier('val')])
),
TAst.Assign(
TAst.Identifier('count'),
TAst.BinaryExpr(TAst.Identifier('count'), TScalar.TBinaryOp.Add, TAst.Constant(1))
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('count'), TAst.Constant(1)])
),
TAst.Assign(
TAst.Identifier('sum'),
TAst.TernaryExpr(
TAst.BinaryExpr(
TAst.Identifier('count'),
TScalar.TBinaryOp.Greater,
TAst.Identifier('len')
),
TAst.BinaryExpr(
TAst.Identifier('sum'),
TScalar.TBinaryOp.Subtract,
TAst.Indexer(TAst.Identifier('series'), TAst.Identifier('len'))
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('>'), [TAst.Identifier('count'), TAst.Identifier('len')]),
// --- Ersetzt ---
TAst.FunctionCall(
TAst.Identifier('-'),
[
TAst.Identifier('sum'),
TAst.Indexer(TAst.Identifier('series'), TAst.Identifier('len'))
]
),
TAst.Identifier('sum')
)
),
TAst.BinaryExpr(
TAst.Identifier('sum'),
TScalar.TBinaryOp.Divide,
TAst.TernaryExpr(
TAst.BinaryExpr(TAst.Identifier('count'), TScalar.TBinaryOp.Less, TAst.Identifier('len')),
TAst.Identifier('count'),
TAst.Identifier('len')
)
// --- Ersetzt ---
TAst.FunctionCall(
TAst.Identifier('/'),
[
TAst.Identifier('sum'),
TAst.TernaryExpr(
// --- Ersetzt ---
TAst.FunctionCall(
TAst.Identifier('<'),
[TAst.Identifier('count'), TAst.Identifier('len')]
),
TAst.Identifier('count'),
TAst.Identifier('len')
)
]
)
]
)
@@ -590,10 +613,10 @@ begin
raise EJSONParseException.Create('Invalid JSON format.');
try
var unboundAst := converter.Deserialize(jsonObj);
FCurrUnboundAst := converter.Deserialize(jsonObj);
// Run the full pipeline
FCurrExec := FEnvironment.Compile(unboundAst);
FCurrExec := FEnvironment.Compile(FCurrUnboundAst).Func;
Memo1.Lines.Add('AST deserialized and bound successfully from JSON.');
Memo1.Lines.Add('You can now visualize it (Middle Mouse Click) or pretty-print it.');
@@ -658,7 +681,7 @@ begin
end;
// Dump the compiled AST from the executable
TAstDumper.Dump(FCurrUnboundAst, Memo1.Lines);
TAstDumper.Dump(CompileAstStage, Memo1.Lines);
end;
procedure TForm1.FibonacciButtonClick(Sender: TObject);
@@ -676,8 +699,8 @@ begin
(def fib)
(assign fib (fn [n]
(? (< n 2)
n
(+ (fib (- n 1)) (fib (- n 2)))
n
(+ (fib (- n 1)) (fib (- n 2)))
)
))
)
@@ -690,7 +713,7 @@ begin
Memo1.Lines.Add('--- Naive recursive fib with AST---');
var fibExec := TestEnv.Compile(TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(25)]));
var fibExec := TestEnv.Compile(TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(25)])).Func;
sw := TStopwatch.StartNew;
result := fibExec([]);
@@ -705,7 +728,7 @@ begin
memoizeTest.Define('fib', TAstScript.Parse('(Memoize fib)'));
var memoizeExec := memoizeTest.Compile(TAstScript.Parse('(fib 25)'));
var memoizeExec := memoizeTest.Compile(TAstScript.Parse('(fib 25)')).Func;
sw := TStopwatch.StartNew;
result := memoizeExec([]);
@@ -738,12 +761,15 @@ begin
TAst.LambdaExpr(
[TAst.Identifier('n'), TAst.Identifier('acc')],
TAst.TernaryExpr(
TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.LessOrEqual, TAst.Constant(1)),
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('<='), [TAst.Identifier('n'), TAst.Constant(1)]),
TAst.Identifier('acc'), // Base case: return the accumulator
TAst.Recur( // Tail-recursive step
[
TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Subtract, TAst.Constant(1)),
TAst.BinaryExpr(TAst.Identifier('acc'), TScalar.TBinaryOp.Multiply, TAst.Identifier('n'))
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('-'), [TAst.Identifier('n'), TAst.Constant(1)]),
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('*'), [TAst.Identifier('acc'), TAst.Identifier('n')])
]
)
)
@@ -834,7 +860,7 @@ begin
'''
);
var fn := FEnvironment.Compile(FCurrUnboundAst, [TAst.Identifier('txt')]);
var fn := FEnvironment.Compile(FCurrUnboundAst, [TAst.Identifier('txt')]).Func;
fn(['Hello World']);
@@ -865,7 +891,8 @@ begin
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('baseValue'), TAst.Constant(100)),
TAst.BinaryExpr(TAst.Identifier('baseValue'), TScalar.TBinaryOp.Add, TAst.Identifier('offset'))
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('baseValue'), TAst.Identifier('offset')])
]
)
)
@@ -932,7 +959,7 @@ begin
var seriesAddress := env.RootScope.Define('current_series', TDataValue.Void);
var callExec := env.Compile(TAst.FunctionCall(TAst.Identifier('maCrossStrategy'), [TAst.Identifier('current_series')]));
var callExec := env.Compile(TAst.FunctionCall(TAst.Identifier('maCrossStrategy'), [TAst.Identifier('current_series')])).Func;
// Simulation Loop
Memo1.Lines.Clear;
@@ -1007,8 +1034,10 @@ begin
TAst.LambdaExpr(
[TAst.Identifier('n')],
TAst.IfExpr(
TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Greater, TAst.Constant(0)),
TAst.Recur([TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Subtract, TAst.Constant(1))]),
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('>'), [TAst.Identifier('n'), TAst.Constant(0)]),
// --- Ersetzt ---
TAst.Recur([TAst.FunctionCall(TAst.Identifier('-'), [TAst.Identifier('n'), TAst.Constant(1)])]),
TAst.Constant(0)
)
)
@@ -1041,7 +1070,8 @@ begin
[TAst.Identifier('summand')],
TAst.Assign(
TAst.Identifier('X'),
TAst.BinaryExpr(TAst.Identifier('X'), TScalar.TBinaryOp.Add, TAst.Identifier('summand'))
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('X'), TAst.Identifier('summand')])
)
)
)
@@ -1055,7 +1085,8 @@ begin
'tickHandler',
TAst.LambdaExpr(
[TAst.Identifier('summand')],
TAst.Assign(TAst.Identifier('X'), TAst.BinaryExpr(TAst.Identifier('X'), TScalar.TBinaryOp.Add, TAst.Identifier('summand')))
// --- Ersetzt ---
TAst.Assign(TAst.Identifier('X'), TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('X'), TAst.Identifier('summand')]))
)
);
@@ -1142,7 +1173,8 @@ begin
[], // Inner closure that is returned
TAst.Assign(
TAst.Identifier('a'),
TAst.BinaryExpr(TAst.Identifier('a'), TScalar.TBinaryOp.Add, TAst.Constant(5))
// --- Ersetzt ---
TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('a'), TAst.Constant(5)])
)
)
)
@@ -1285,21 +1317,7 @@ begin
if FCurrUnboundAst = nil then
exit;
var ast := FCurrUnboundAst;
if CompilerStageBox.ItemIndex > 0 then
ast := FEnvironment.Environment.ExpandMacros(ast);
if CompilerStageBox.ItemIndex > 1 then
begin
var desc: IScopeDescriptor;
ast := FEnvironment.Environment.Bind(ast, desc);
end;
if CompilerStageBox.ItemIndex > 2 then
ast := FEnvironment.Environment.Lower(ast);
FWorkspace.Build(ast, TPointF.Create(X, Y));
FWorkspace.Build(CompileAstStage, TPointF.Create(X, Y));
//
// if FCurrExec <> nil then
// begin
-117
View File
@@ -80,8 +80,6 @@ type
function VisitConstant(const Node: IConstantNode): TAuraNode; override;
function VisitIdentifier(const Node: IIdentifierNode): TAuraNode; override;
function VisitKeyword(const Node: IKeywordNode): TAuraNode; override;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): TAuraNode; override;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): TAuraNode; override;
function VisitIfExpression(const Node: IIfExpressionNode): TAuraNode; override;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): TAuraNode; override;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TAuraNode; override;
@@ -279,19 +277,6 @@ type
function ReconstructAst(OwnerNode: TAuraNode): IAstNode;
end;
{ TAuraBinaryExpressionNode }
TBinaryExpressionNodeHandler = class(TInterfacedObject, IAuraNodeHandler)
private
FNode: IBinaryExpressionNode;
FLeftNode: TAuraNode; // Stores the visual child
FRightNode: TAuraNode; // Stores the visual child
function GetAstNode: IAstNode;
public
constructor Create(const ANode: IBinaryExpressionNode);
procedure BuildUI(OwnerNode: TAuraNode);
function ReconstructAst(OwnerNode: TAuraNode): IAstNode;
end;
{ TAuraBlockExpressionNode }
TBlockExpressionNodeHandler = class(TInterfacedObject, IAuraNodeHandler)
private
@@ -305,18 +290,6 @@ type
function ReconstructAst(OwnerNode: TAuraNode): IAstNode;
end;
{ TAuraUnaryExpressionNode }
TUnaryExpressionNodeHandler = class(TInterfacedObject, IAuraNodeHandler)
private
FNode: IUnaryExpressionNode;
FChildNode: TAuraNode; // Stores the single child
function GetAstNode: IAstNode;
public
constructor Create(const ANode: IUnaryExpressionNode);
procedure BuildUI(OwnerNode: TAuraNode);
function ReconstructAst(OwnerNode: TAuraNode): IAstNode;
end;
{ TAuraIfExpressionNode }
TIfExpressionNodeHandler = class(TInterfacedObject, IAuraNodeHandler)
private
@@ -648,14 +621,6 @@ begin
Result := TAuraNode.Create(Self, Handler);
end;
function TAstVisualizer.VisitBinaryExpression(const Node: IBinaryExpressionNode): TAuraNode;
var
Handler: IAuraNodeHandler;
begin
Handler := TBinaryExpressionNodeHandler.Create(Node);
Result := TAuraNode.Create(Self, Handler);
end;
function TAstVisualizer.VisitBlockExpression(const Node: IBlockExpressionNode): TAuraNode;
var
Handler: IAuraNodeHandler;
@@ -664,14 +629,6 @@ begin
Result := TAuraNode.Create(Self, Handler);
end;
function TAstVisualizer.VisitUnaryExpression(const Node: IUnaryExpressionNode): TAuraNode;
var
Handler: IAuraNodeHandler;
begin
Handler := TUnaryExpressionNodeHandler.Create(Node);
Result := TAuraNode.Create(Self, Handler);
end;
function TAstVisualizer.VisitIfExpression(const Node: IIfExpressionNode): TAuraNode;
var
Handler: IAuraNodeHandler;
@@ -1404,44 +1361,6 @@ begin
Result := FNode; // Keywords are literals
end;
{ TBinaryExpressionNodeHandler }
constructor TBinaryExpressionNodeHandler.Create(const ANode: IBinaryExpressionNode);
begin
inherited Create;
FNode := ANode;
end;
function TBinaryExpressionNodeHandler.GetAstNode: IAstNode;
begin
Result := FNode;
end;
procedure TBinaryExpressionNodeHandler.BuildUI(OwnerNode: TAuraNode);
var
visu: IAstVisualizer;
begin
visu := OwnerNode.Visualizer.Clone(OwnerNode, OwnerNode.Visualizer.ExprDepth + 1);
OwnerNode.BeginUpdate;
try
OwnerNode.Frameless := true;
OwnerNode.Orientation := loHorizontal;
// Create and store visual children
FLeftNode := visu.CallAccept(FNode.Left);
OwnerNode.AddLabel(OwnerNode, FNode.Operator.ToString);
FRightNode := visu.CallAccept(FNode.Right);
finally
OwnerNode.EndUpdate;
end;
end;
function TBinaryExpressionNodeHandler.ReconstructAst(OwnerNode: TAuraNode): IAstNode;
begin
// Use the stored visual children to reconstruct the AST
Result := TAst.BinaryExpr(FLeftNode.CreateAst, FNode.Operator, FRightNode.CreateAst);
end;
{ TBlockExpressionNodeHandler }
constructor TBlockExpressionNodeHandler.Create(const ANode: IBlockExpressionNode);
@@ -1521,42 +1440,6 @@ begin
Result := TAst.Block(exprs);
end;
{ TUnaryExpressionNodeHandler }
constructor TUnaryExpressionNodeHandler.Create(const ANode: IUnaryExpressionNode);
begin
inherited Create;
FNode := ANode;
end;
function TUnaryExpressionNodeHandler.GetAstNode: IAstNode;
begin
Result := FNode;
end;
procedure TUnaryExpressionNodeHandler.BuildUI(OwnerNode: TAuraNode);
var
visu: IAstVisualizer;
titleLabel: TLabel;
begin
visu := OwnerNode.Visualizer.Clone(OwnerNode, OwnerNode.Visualizer.ExprDepth + 1);
OwnerNode.BeginUpdate;
try
OwnerNode.Frameless := False;
OwnerNode.Orientation := loVertical;
titleLabel := OwnerNode.AddLabel(OwnerNode, 'Unary Op: ' + FNode.Operator.ToString);
titleLabel.Font.Style := titleLabel.Font.Style + [TFontStyle.fsBold];
FChildNode := visu.CallAccept(FNode.Right);
finally
OwnerNode.EndUpdate;
end;
end;
function TUnaryExpressionNodeHandler.ReconstructAst(OwnerNode: TAuraNode): IAstNode;
begin
Result := TAst.UnaryExpr(FNode.Operator, FChildNode.CreateAst);
end;
{ TIfExpressionNodeHandler }
constructor TIfExpressionNodeHandler.Create(const ANode: IIfExpressionNode);
-14
View File
@@ -17,8 +17,6 @@ type
function VisitConstant(const Node: IConstantNode): string; override;
function VisitIdentifier(const Node: IIdentifierNode): string; override;
function VisitKeyword(const Node: IKeywordNode): string; override;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): string; override;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): string; override;
function VisitIfExpression(const Node: IIfExpressionNode): string; override;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): string; override;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): string; override;
@@ -65,13 +63,6 @@ begin
Result := Node.Identifier.Name + ' := ' + Accept(Node.Value);
end;
function TAstToTextVisitor.VisitBinaryExpression(const Node: IBinaryExpressionNode): string;
begin
var leftStr := Accept(Node.Left);
var rightStr := Accept(Node.Right);
Result := '(' + leftStr + ' ' + Node.Operator.ToString + ' ' + rightStr + ')';
end;
function TAstToTextVisitor.VisitBlockExpression(const Node: IBlockExpressionNode): string;
begin
Result := '{...}';
@@ -260,11 +251,6 @@ begin
Result := Format('(%s ? %s : %s)', [condStr, thenStr, elseStr]);
end;
function TAstToTextVisitor.VisitUnaryExpression(const Node: IUnaryExpressionNode): string;
begin
Result := Node.Operator.ToString + ' ' + Accept(Node.Right);
end;
function TAstToTextVisitor.VisitVariableDeclaration(const Node: IVariableDeclarationNode): string;
var
initStr: string;
+72 -20
View File
@@ -11,11 +11,14 @@ uses
Myc.Ast.Nodes,
Myc.Ast.Visitor,
Myc.Ast.Scope,
Myc.Ast.Types,
Myc.Ast.Compiler.Binder.Upvalues,
Myc.Ast;
Myc.Ast,
Myc.Ast.Environment;
type
IAstBinder = interface(IAstVisitor)
// AArgTypes is now passed to the implementation via its constructor
function Execute(const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
end;
@@ -30,6 +33,8 @@ type
FUpvalueStack: TStack<TUpvalueMapping>;
FNestedLambdaCount: Integer;
FBoxedDeclarations: THashSet<IVariableDeclarationNode>;
FArgTypes: TArray<IStaticType>;
FFunctionRegistry: IFunctionDefinitionRegistry;
procedure EnterScope;
procedure ExitScope;
@@ -39,6 +44,7 @@ type
// --- Core Binding Logic (Mutators) ---
function VisitIdentifier(const Node: IIdentifierNode): IAstNode; override;
function VisitVariableDeclaration(const Node: IVariableDeclarationNode): IAstNode; override;
function VisitAssignment(const Node: IAssignmentNode): IAstNode; override;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): IAstNode; override;
// --- Transformation Logic (Restored) ---
@@ -49,14 +55,20 @@ type
function VisitConstant(const Node: IConstantNode): IAstNode; override;
function VisitCreateSeries(const Node: ICreateSeriesNode): IAstNode; override;
public
constructor Create(const AInitialDescriptor: IScopeDescriptor);
constructor Create(
const AInitialDescriptor: IScopeDescriptor;
const AFunctionRegistry: IFunctionDefinitionRegistry;
const AArgTypes: TArray<IStaticType>
);
destructor Destroy; override;
function Execute(const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
class function Bind(
const InitialDescriptor: IScopeDescriptor;
const RootNode: IAstNode;
out Descriptor: IScopeDescriptor
out Descriptor: IScopeDescriptor;
const AFunctionRegistry: IFunctionDefinitionRegistry = nil;
const AArgTypes: TArray<IStaticType> = nil
): IAstNode; static;
end;
@@ -65,7 +77,6 @@ implementation
uses
System.Generics.Defaults,
System.Character,
Myc.Ast.Types, // Added for TTypes.Unknown
Myc.Data.Keyword;
type
@@ -91,12 +102,18 @@ end;
{ TAstBinder }
constructor TAstBinder.Create(const AInitialDescriptor: IScopeDescriptor);
constructor TAstBinder.Create(
const AInitialDescriptor: IScopeDescriptor;
const AFunctionRegistry: IFunctionDefinitionRegistry;
const AArgTypes: TArray<IStaticType>
);
begin
inherited Create;
Assert(Assigned(AInitialDescriptor));
FCurrentDescriptor := AInitialDescriptor;
FFunctionRegistry := AFunctionRegistry;
FArgTypes := AArgTypes;
FUpvalueStack := TObjectStack<TUpvalueMapping>.Create(True); // Use Comparer
FNestedLambdaCount := 0;
FBoxedDeclarations := nil;
@@ -112,10 +129,12 @@ end;
class function TAstBinder.Bind(
const InitialDescriptor: IScopeDescriptor;
const RootNode: IAstNode;
out Descriptor: IScopeDescriptor
out Descriptor: IScopeDescriptor;
const AFunctionRegistry: IFunctionDefinitionRegistry = nil;
const AArgTypes: TArray<IStaticType> = nil
): IAstNode;
begin
var binder := TAstBinder.Create(InitialDescriptor) as IAstBinder;
var binder := TAstBinder.Create(InitialDescriptor, AFunctionRegistry, AArgTypes) as IAstBinder;
Result := binder.Execute(RootNode, Descriptor);
end;
@@ -228,6 +247,7 @@ var
lastNestedLambdaCount: Integer;
newParams: TArray<IIdentifierNode>;
newBody: IAstNode;
paramType: IStaticType;
begin
// We do *not* call inherited, as we must manage the scope manually.
@@ -236,18 +256,26 @@ begin
EnterScope;
try
// Define <self> (slot 0)
FCurrentDescriptor.Define('<self>');
FCurrentDescriptor.Define('<self>', TTypes.Unknown);
// Define parameters
SetLength(newParams, Length(Node.Parameters));
for i := 0 to High(Node.Parameters) do
begin
var paramNode := Node.Parameters[i]; // This is a TIdentifierNode
var slotIndex := FCurrentDescriptor.Define(paramNode.Name);
// Check if this is the root lambda (stack count = 1)
// and we have pre-defined types for it (from specialization)
paramType := TTypes.Unknown;
if (FUpvalueStack.Count = 1) and (FArgTypes <> nil) and (i < Length(FArgTypes)) then
paramType := FArgTypes[i]; // Use the specialized type
// Define the symbol in the descriptor WITH the type
var slotIndex := FCurrentDescriptor.Define(paramNode.Name, paramType);
adr := TResolvedAddress.Create(akLocalOrParent, 0, slotIndex);
// Create a new TIdentifierNode
newParams[i] := TAst.Identifier(paramNode.Name, adr, TTypes.Unknown);
// Create a new TIdentifierNode, now with the correct type
newParams[i] := TAst.Identifier(paramNode.Name, adr, paramType);
end;
// Visit the body *within the new scope*
@@ -326,7 +354,7 @@ begin
// else: It was already an upvalue (e.g. nested lambda), adr is correct.
// --- Replace Node ---
Result := TAst.Identifier(Node.Name, adr, TTypes.Unknown); // TypeChecker will set type
Result := TAst.Identifier(Node.Name, adr, symbol.StaticType);
end
else
begin
@@ -343,27 +371,51 @@ var
newInitializer: IAstNode;
newIdentifier: IIdentifierNode;
begin
// 1. Validate name
if not IsValidIdentifier(Node.Identifier.Name) then
raise Exception.CreateFmt('Invalid identifier name: "%s".', [Node.Identifier.Name]);
// 1. Visit initializer *first*
// 2. Define the symbol in the scope *first*.
// This allows the initializer (e.g., a lambda) to recursively refer to this symbol.
slotIndex := FCurrentDescriptor.Define(Node.Identifier.Name, TTypes.Unknown);
address := TResolvedAddress.Create(akLocalOrParent, 0, slotIndex);
// 3. Visit the Initializer *after* the symbol is defined
if Assigned(Node.Initializer) then
newInitializer := Accept(Node.Initializer)
else
newInitializer := nil;
// 2. Define variable in *current* scope
slotIndex := FCurrentDescriptor.Define(Node.Identifier.Name);
address := TResolvedAddress.Create(akLocalOrParent, 0, slotIndex);
// 3. Create the new bound identifier
// 4. Create the new (bound) identifier node
// The TypeChecker will set the final type
newIdentifier := TAst.Identifier(Node.Identifier.Name, address, TTypes.Unknown);
// 4. Check if this declaration should be boxed
// 5. Check if this declaration needs boxing (from UpvalueAnalyzer pass)
isBoxed := (FBoxedDeclarations <> nil) and FBoxedDeclarations.Contains(Node);
// 5. Create the new immutable node
// 6. Create the new VariableDeclaration node using the factory
Result := TAst.VarDecl(newIdentifier, newInitializer, TTypes.Unknown, isBoxed);
// 7. Store in registry *only if the registry was provided*
// (This must happen *after* visiting the initializer)
if Assigned(FFunctionRegistry) and (newInitializer <> nil) and (newInitializer.Kind = akLambdaExpression) then
FFunctionRegistry.Register(address, newInitializer.AsLambdaExpression);
end;
function TAstBinder.VisitAssignment(const Node: IAssignmentNode): IAstNode;
var
newIdent: IIdentifierNode;
newValue: IAstNode;
begin
Result := inherited VisitAssignment(Node);
newValue := Result.AsAssignment.Value;
newIdent := Result.AsAssignment.Identifier;
if Assigned(FFunctionRegistry) and (newValue <> nil) and (newValue.Kind = akLambdaExpression) then
begin
FFunctionRegistry.Register(newIdent.Address, newValue.AsLambdaExpression);
end;
end;
end.
-57
View File
@@ -27,8 +27,6 @@ type
FBinaryOperators: TDictionary<string, TScalar.TBinaryOp>;
FUnaryOperators: TDictionary<string, TScalar.TUnaryOp>;
protected
// Override to find nodes to lower
function VisitFunctionCall(const Node: IFunctionCallNode): IAstNode; override;
public
constructor Create;
destructor Destroy; override;
@@ -46,9 +44,6 @@ uses
{ TAstLowerer }
constructor TAstLowerer.Create;
var
op: TScalar.TBinaryOp;
uOp: TScalar.TUnaryOp;
begin
inherited Create;
@@ -91,56 +86,4 @@ begin
Result := TAst.Block([]);
end;
function TAstLowerer.VisitFunctionCall(const Node: IFunctionCallNode): IAstNode;
var
calleeIdentifier: IIdentifierNode;
binaryOp: TScalar.TBinaryOp;
unaryOp: TScalar.TUnaryOp;
left, right: IAstNode;
nodeType: IStaticType;
begin
// --- Optimization: Operator Folding ---
if Node.Callee.Kind = akIdentifier then
begin
calleeIdentifier := Node.Callee.AsIdentifier;
nodeType := Node.StaticType; // Get type from (un-lowered) node
if (Length(Node.Arguments) = 2) then
begin
if FBinaryOperators.TryGetValue(calleeIdentifier.Name, binaryOp) then
begin
// Note: We MUST visit children *before* creating the new node
left := Accept(Node.Arguments[0]);
right := Accept(Node.Arguments[1]);
// Call constructor directly, passing the inferred type
Result := TAst.BinaryExpr(left, binaryOp, right, nodeType);
exit;
end;
end;
if (Length(Node.Arguments) = 1) then
begin
if FUnaryOperators.TryGetValue(calleeIdentifier.Name, unaryOp) then
begin
right := Accept(Node.Arguments[0]);
// Call constructor directly, passing the inferred type
Result := TAst.UnaryExpr(unaryOp, right, nodeType);
exit;
end;
if (calleeIdentifier.Name = '-') then
begin
right := Accept(Node.Arguments[0]);
// Call constructor directly, passing the inferred type
Result := TAst.UnaryExpr(TScalar.TUnaryOp.Negate, right, nodeType);
exit;
end;
end;
end;
// If no rewrite matched, continue traversal using the base implementation
Result := inherited VisitFunctionCall(Node);
end;
end.
+1 -1
View File
@@ -496,7 +496,7 @@ begin
// 1. Create the temporary scope for the macro parameters
// It must be parented to the *initial* scope to find other globals.
var expansionScope := TAst.CreateScope(FInitialScope);
var expansionScope := TScope.CreateScope(FInitialScope, nil, nil);
var params := macroDef.Parameters;
if Length(Node.Arguments) <> Length(params) then
raise Exception
+207
View File
@@ -0,0 +1,207 @@
unit Myc.Ast.Compiler.Specializer;
interface
uses
System.SysUtils,
System.Generics.Collections,
Myc.Data.Value,
Myc.Ast,
Myc.Ast.Types,
Myc.Ast.Nodes,
Myc.Ast.Visitor,
Myc.Ast.Scope,
Myc.Ast.Environment,
Myc.Ast.RTL;
type
IAstSpecializer = interface(IAstVisitor)
function Execute(const RootNode: IAstNode): IAstNode;
end;
// This transformer runs *after* TypeChecker
// It specializes all statically resolvable function calls (RTL and user-defined)
// by replacing them with nodes that have a direct StaticTarget.
TStaticSpecializer = class(TAstTransformer, IAstSpecializer)
private
FEnvironment: IEnvironment;
FMonomorphCache: TMonomorphCache;
FFunctionRegistry: IFunctionDefinitionRegistry;
function GetStaticRtlFunction(const AName: string; const AArgTypes: TArray<IStaticType>): TSpecializedMethod;
protected
function VisitFunctionCall(const Node: IFunctionCallNode): IAstNode; override;
public
constructor Create(const AEnvironment: IEnvironment);
function Execute(const RootNode: IAstNode): IAstNode;
class function Specialize(
const AEnvironment: IEnvironment;
const RootNode: IAstNode;
const ADescriptor: IScopeDescriptor
): IAstNode; static;
end;
implementation
{ TStaticSpecializer }
constructor TStaticSpecializer.Create(const AEnvironment: IEnvironment);
begin
inherited Create;
Assert(Assigned(AEnvironment));
FEnvironment := AEnvironment;
FMonomorphCache := AEnvironment.MonomorphCache;
FFunctionRegistry := AEnvironment.FunctionRegistry; // Get registry
Assert(Assigned(FFunctionRegistry));
end;
class function TStaticSpecializer.Specialize(
const AEnvironment: IEnvironment;
const RootNode: IAstNode;
const ADescriptor: IScopeDescriptor
): IAstNode;
begin
// ADescriptor is no longer needed here, the environment has all it needs
var specializer := TStaticSpecializer.Create(AEnvironment) as IAstSpecializer;
Result := specializer.Execute(RootNode);
end;
function TStaticSpecializer.Execute(const RootNode: IAstNode): IAstNode;
begin
Result := Accept(RootNode);
if not Assigned(Result) then
Result := TAst.Block([]);
end;
function TStaticSpecializer.GetStaticRtlFunction(const AName: string; const AArgTypes: TArray<IStaticType>): TSpecializedMethod;
begin
// Helper to query the RTL bootstrap cache
Result := TRtlRegistry.GetStaticSpecialization(AName, AArgTypes);
end;
function TStaticSpecializer.VisitFunctionCall(const Node: IFunctionCallNode): IAstNode;
var
newCallee: IAstNode;
newArgs: TArray<IAstNode>;
i: Integer;
calleeIdent: IIdentifierNode;
argTypes: TArray<IStaticType>;
allTypesKnown: Boolean;
funcName: string;
key: TMonoCacheKey;
specializedMethod: TSpecializedMethod;
funcDef: IFunctionDefinition;
begin
// 1. Specialize children first (bottom-up)
newCallee := Accept(Node.Callee);
newArgs := AcceptNodes(Node.Arguments);
// 2. Check if this call is a candidate for specialization
if newCallee.Kind <> akIdentifier then
begin
if (newCallee = Node.Callee) and (newArgs = Node.Arguments) then
Result := Node
else
Result := TAst.FunctionCall(newCallee, newArgs, Node.StaticType, Node.IsTailCall, nil);
exit;
end;
calleeIdent := newCallee.AsIdentifier;
funcName := calleeIdent.Name;
// 3. Check if all argument types are statically known
allTypesKnown := True;
SetLength(argTypes, Length(newArgs));
for i := 0 to High(newArgs) do
begin
argTypes[i] := newArgs[i].AsTypedNode.StaticType;
if argTypes[i].Kind = stUnknown then
begin
allTypesKnown := False;
break;
end;
end;
if not allTypesKnown then
begin
if (newCallee = Node.Callee) and (newArgs = Node.Arguments) then
Result := Node
else
Result := TAst.FunctionCall(newCallee, newArgs, Node.StaticType, Node.IsTailCall, nil);
exit;
end;
// --- At this point, the call is statically resolvable ---
// 4. Check the Environment (Instance) Cache
key := TMonoCacheKey.Create(calleeIdent.Address, argTypes);
if FMonomorphCache.TryGetValue(key, specializedMethod) then
begin
// 4a. Cache Hit (Environment): Found user-defined or previously specialized fn
Result :=
TAst.FunctionCall(
newCallee,
newArgs,
specializedMethod.ReturnType, // Use the type from the cache
Node.IsTailCall,
specializedMethod.Target // Use the TFunc from the cache
);
exit;
end;
// 5. Check the RTL (Global) Bootstrap Cache
specializedMethod := GetStaticRtlFunction(funcName, argTypes);
if Assigned(specializedMethod.Target) then
begin
// 5a. Cache Hit (RTL): Found a native, static RTL function
FMonomorphCache.Add(key, specializedMethod);
Result :=
TAst.FunctionCall(
newCallee,
newArgs,
specializedMethod.ReturnType, // Use the type from the cache
Node.IsTailCall,
specializedMethod.Target // Use the TFunc from the cache
);
exit;
end;
// 6. Cache Miss (User Code)
funcDef := FFunctionRegistry.Resolve(calleeIdent.Address);
if (funcDef <> nil) then
begin
// 6a. Compile func with KNOWN TYPES
var compiled := FEnvironment.Compile(funcDef, argTypes);
// 6b. Store in cache
// Get the return type from the *full function type* returned by Compile
var returnType := compiled.StaticType.Signatures[0].ReturnType;
specializedMethod := TSpecializedMethod.Create(compiled.Func, returnType);
FMonomorphCache.Add(key, specializedMethod);
// 6e. Return the new node
Result :=
TAst.FunctionCall(
newCallee,
newArgs,
returnType, // Use the extracted return type
Node.IsTailCall,
compiled.Func // Use the compiled TFunc
);
exit;
end;
// 7. Fallback: Not RTL, Not User-Code (oder AST nicht gefunden) -> Dynamic
if (newCallee = Node.Callee) and (newArgs = Node.Arguments) then
Result := Node
else
Result := TAst.FunctionCall(newCallee, newArgs, Node.StaticType, Node.IsTailCall, nil);
end;
end.
+13 -26
View File
@@ -35,10 +35,6 @@ type
function VisitRecurNode(const Node: IRecurNode): IAstNode; override;
function VisitMacroExpansionNode(const Node: IMacroExpansionNode): IAstNode; override;
// Operands are never in tail position.
function VisitBinaryExpression(const Node: IBinaryExpressionNode): IAstNode; override;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): IAstNode; override;
// The core TCO logic
function VisitFunctionCall(const Node: IFunctionCallNode): IAstNode; override;
public
@@ -96,24 +92,6 @@ begin
end;
end;
function TAstTCO.VisitBinaryExpression(const Node: IBinaryExpressionNode): IAstNode;
begin
// Operands are never in tail position.
FNextIsTail := False;
// Call inherited, which will visit Left and Right with FNextIsTail = False
Result := inherited VisitBinaryExpression(Node);
end;
function TAstTCO.VisitUnaryExpression(const Node: IUnaryExpressionNode): IAstNode;
begin
// Operand is never in tail position.
FNextIsTail := False;
// Call inherited, which will visit Right with FNextIsTail = False
Result := inherited VisitUnaryExpression(Node);
end;
function TAstTCO.VisitBlockExpression(const Node: IBlockExpressionNode): IAstNode;
var
isContextTail: Boolean;
@@ -250,13 +228,22 @@ begin
newArgs := AcceptNodes(Node.Arguments);
// CoW check: Create a new node only if children changed OR IsTailCall needs update
// OR StaticTarget is missing (which it shouldn't be, but good to check)
if (newCallee = Node.Callee) and (newArgs = Node.Arguments) and (isTailCall = Node.IsTailCall) then
Result := Node
else
begin
// Use factory to create new node, passing the *new* TCO status
Result := TAst.FunctionCall(newCallee, newArgs, Node.StaticType, isTailCall);
Result := Node;
exit;
end;
// Use factory to create new node, passing the *new* TCO status
Result :=
TAst.FunctionCall(
newCallee,
newArgs,
Node.StaticType,
isTailCall,
Node.StaticTarget // Preserve the static target
);
end;
end.
+141 -77
View File
@@ -36,8 +36,6 @@ type
function VisitBlockExpression(const Node: IBlockExpressionNode): IAstNode; override;
function VisitIfExpression(const Node: IIfExpressionNode): IAstNode; override;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): IAstNode; override;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): IAstNode; override;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): IAstNode; override;
function VisitMemberAccess(const Node: IMemberAccessNode): IAstNode; override;
function VisitIndexer(const Node: IIndexerNode): IAstNode; override;
function VisitRecordLiteral(const Node: IRecordLiteralNode): IAstNode; override;
@@ -137,36 +135,60 @@ var
initType: IStaticType;
newInitializer, newIdent: IAstNode;
adr: TResolvedAddress;
lambdaNode: ILambdaExpressionNode;
placeholderType: IStaticType;
i: Integer;
begin
// 1. Visit Initializer first (if it exists)
// 1. Get the address from the bound identifier (Binder did this)
adr := Node.Identifier.Address;
initType := TTypes.Unknown; // Default
// 2. Check for recursive lambda and bootstrap the type
placeholderType := nil;
if (Node.Initializer <> nil) and (Node.Initializer.Kind = akLambdaExpression) then
begin
lambdaNode := Node.Initializer.AsLambdaExpression;
// Create a placeholder method type based on the *unvisited* lambda's parameter *count*.
var paramTypes: TArray<IStaticType>;
SetLength(paramTypes, Length(lambdaNode.Parameters));
for i := 0 to High(paramTypes) do
paramTypes[i] := TTypes.Unknown;
// Create the placeholder (Return type is also Unknown for now)
placeholderType := TTypes.CreateMethod(paramTypes, TTypes.Unknown);
// 3. *Update the descriptor* with the placeholder *before* visiting the initializer
FCurrentDescriptor.UpdateType(adr.SlotIndex, placeholderType);
initType := placeholderType; // Store this
end;
// 4. Visit Initializer (if it exists)
if Assigned(Node.Initializer) then
newInitializer := Accept(Node.Initializer)
else
newInitializer := nil;
// 2. Get initializer type
// 5. Get the *final* inferred initializer type
if Assigned(newInitializer) then
initType := newInitializer.AsTypedNode.StaticType
else
initType := TTypes.Unknown; // (def fib)
else if not Assigned(placeholderType) then // only if not already set
initType := TTypes.Unknown; // (def f) - no initializer
// 3. Get the address from the bound identifier
adr := Node.Identifier.Address;
// 4. Update the type in the scope descriptor (which was set to Unknown by the binder).
// 6. *Re-update* the type in the scope descriptor with the final, inferred type.
if initType.Kind <> stUnknown then
FCurrentDescriptor.UpdateType(adr.SlotIndex, initType);
// 5. Create the new (typed) identifier node
// 7. Create the new (typed) identifier node
newIdent := TAst.Identifier(Node.Identifier.Name, adr, initType);
// 6. Create the new VariableDeclaration node using the factory
// 8. Create the new VariableDeclaration node using the factory
Result :=
TAst.VarDecl(
newIdent.AsIdentifier,
newInitializer,
initType,
Node.IsBoxed // 7. Copy runtime flags (IsBoxed) via interface
Node.IsBoxed // 9. Copy runtime flags
);
end;
@@ -175,32 +197,65 @@ var
targetType, sourceType: IStaticType;
newIdent, newValue: IAstNode;
adr: TResolvedAddress;
lambdaNode: ILambdaExpressionNode;
placeholderType: IStaticType;
i: Integer;
begin
// 1. Visit children first (Identifier, Value)
newValue := Accept(Node.Value);
// 1. Visit Identifier *first* to get its address and current type
newIdent := Accept(Node.Identifier);
// 2. Get types
targetType := newIdent.AsTypedNode.StaticType;
adr := newIdent.AsIdentifier.Address;
// 2. Check for recursive lambda assignment
placeholderType := nil;
if (Node.Value <> nil) and (Node.Value.Kind = akLambdaExpression) then
begin
lambdaNode := Node.Value.AsLambdaExpression;
// Create a placeholder (only if the target is not already a method type)
if (targetType.Kind <> stMethod) then
begin
var paramTypes: TArray<IStaticType>;
SetLength(paramTypes, Length(lambdaNode.Parameters));
for i := 0 to High(paramTypes) do
paramTypes[i] := TTypes.Unknown; // We infer param types later
placeholderType := TTypes.CreateMethod(paramTypes, TTypes.Unknown);
// 3. *Update the descriptor* with the placeholder *before* visiting the value
FCurrentDescriptor.UpdateType(adr.SlotIndex, placeholderType);
targetType := placeholderType;
end;
end;
// 4. Visit Value
newValue := Accept(Node.Value);
sourceType := newValue.AsTypedNode.StaticType;
// 3. Check assignment
// 5. Check assignment
if not TTypeRules.CanAssign(targetType, sourceType) then
raise ETypeException.CreateFmt('Cannot assign type %s to %s', [sourceType.ToString, targetType.ToString]);
// 4. If the target was 'Unknown' (from 'def'), update the descriptor
// with the new, inferred type. This enables recursion.
if (targetType.Kind = stUnknown) and (sourceType.Kind <> stUnknown) then
begin
adr := newIdent.AsIdentifier.Address;
FCurrentDescriptor.UpdateType(adr.SlotIndex, sourceType);
// If target was unknown, try promoting
if (targetType.Kind = stUnknown) then
begin
if not TTypeRules.CanAssign(sourceType, targetType) then // Check reverse
raise ETypeException.CreateFmt('Cannot assign type %s to %s', [sourceType.ToString, targetType.ToString]);
end
else
raise ETypeException.CreateFmt('Cannot assign type %s to %s', [sourceType.ToString, targetType.ToString]);
end;
// 6. If the target was 'Unknown' or a 'Placeholder', update the descriptor
// with the new, final inferred type.
if ((targetType.Kind = stUnknown) or Assigned(placeholderType)) and (sourceType.Kind <> stUnknown) then
begin
FCurrentDescriptor.UpdateType(adr.SlotIndex, sourceType);
// Re-create the identifier node *with the new type*
newIdent := TAst.Identifier(newIdent.AsIdentifier.Name, adr, sourceType);
targetType := sourceType;
end;
// 5. Create the new Assignment node
// 7. Create the new Assignment node
Result := TAst.Assign(newIdent.AsIdentifier, newValue, targetType);
end;
@@ -255,15 +310,28 @@ end;
function TTypeChecker.VisitFunctionCall(const Node: IFunctionCallNode): IAstNode;
var
calleeType, retType: IStaticType;
i: Integer;
i, j: Integer;
newCallee: IAstNode;
newArgs: TArray<IAstNode>;
argTypes: TArray<IStaticType>;
hasUnknownArgs: Boolean;
bestSig: IMethodSignature;
sig: IMethodSignature;
match: Boolean;
begin
// 1. Visit children first (bottom-up)
newCallee := Accept(Node.Callee);
SetLength(newArgs, Length(Node.Arguments));
SetLength(argTypes, Length(Node.Arguments));
hasUnknownArgs := False;
for i := 0 to High(Node.Arguments) do
begin
newArgs[i] := Accept(Node.Arguments[i]);
argTypes[i] := newArgs[i].AsTypedNode.StaticType;
if argTypes[i].Kind = stUnknown then
hasUnknownArgs := True;
end;
// 2. Get callee type (now inferred)
calleeType := newCallee.AsTypedNode.StaticType;
@@ -272,24 +340,58 @@ begin
// 3. Perform type checking
if calleeType.Kind = TStaticTypeKind.stMethod then
begin
var signature := calleeType.Signature;
if Length(newArgs) <> Length(signature.ParamTypes) then
raise ETypeException.CreateFmt('Function expects %d arguments, but got %d', [Length(signature.ParamTypes), Length(newArgs)]);
retType := signature.ReturnType;
// Check argument types
for i := 0 to High(newArgs) do
// If any argument is Unknown, we cannot resolve overloads.
// The return type remains Unknown.
if not hasUnknownArgs then
begin
var argType := newArgs[i].AsTypedNode.StaticType;
var paramType := signature.ParamTypes[i];
if not TTypeRules.CanAssign(paramType, argType) then
bestSig := nil;
for sig in calleeType.Signatures do
begin
// Check 1: Argument count
if Length(sig.ParamTypes) <> Length(argTypes) then
continue;
// Check 2: Argument types (CanAssign)
match := True;
for j := 0 to High(argTypes) do
begin
if not TTypeRules.CanAssign(sig.ParamTypes[j], argTypes[j]) then
begin
match := False;
break; // This signature doesn't match
end;
end;
// Check 3: Found first match
if match then
begin
// This is the "dumb" checker logic: first match wins.
// A "smarter" checker would find the *best* match.
bestSig := sig;
break;
end;
end; // for sig
// Check 4: Handle results
if Assigned(bestSig) then
begin
retType := bestSig.ReturnType;
end
else
begin
// No signature matched, even with known types. This is an error.
var argsStr: string := '';
for i := 0 to High(argTypes) do
argsStr := argsStr + argTypes[i].ToString + ' ';
raise ETypeException
.CreateFmt('Cannot assign argument %d (type %s) to parameter (type %s)', [i, argType.ToString, paramType.ToString]);
.CreateFmt('No matching signature for call with args (%s) found on method %s', [argsStr, calleeType.ToString]);
end;
end;
// else: hasUnknownArgs is True, so retType remains Unknown (as set in step 2)
end
else if calleeType.Kind <> TStaticTypeKind.stUnknown then
raise ETypeException.CreateFmt('Cannot invoke type %s as a function.', [calleeType.ToString]);
// else: calleeType is Unknown (e.g. recursive call or unbound symbol), retType remains Unknown.
// 4. Create the new (typed) call node using the factory
Result :=
@@ -374,44 +476,6 @@ begin
Result := TAst.TernaryExpr(newCond, newThen, newElse, resultType);
end;
function TTypeChecker.VisitBinaryExpression(const Node: IBinaryExpressionNode): IAstNode;
var
leftType, rightType, resultType: IStaticType;
newLeft, newRight: IAstNode;
begin
// 1. Visit children
newLeft := Accept(Node.Left);
newRight := Accept(Node.Right);
// 2. Get types
leftType := newLeft.AsTypedNode.StaticType;
rightType := newRight.AsTypedNode.StaticType;
// 3. Resolve
resultType := TTypeRules.ResolveBinaryOp(Node.Operator, leftType, rightType);
// 4. Create new node
Result := TAst.BinaryExpr(newLeft, Node.Operator, newRight, resultType);
end;
function TTypeChecker.VisitUnaryExpression(const Node: IUnaryExpressionNode): IAstNode;
var
rightType, resultType: IStaticType;
newRight: IAstNode;
begin
// 1. Visit children
newRight := Accept(Node.Right);
// 2. Get types
rightType := newRight.AsTypedNode.StaticType;
// 3. Resolve
resultType := TTypeRules.ResolveUnaryOp(Node.Operator, rightType);
// 4. Create new node
Result := TAst.UnaryExpr(Node.Operator, newRight, resultType);
end;
function TTypeChecker.VisitMemberAccess(const Node: IMemberAccessNode): IAstNode;
var
baseType, elemType: IStaticType;
+6 -27
View File
@@ -36,8 +36,6 @@ type
function VisitConstant(const Node: IConstantNode): TDataValue; override;
function VisitIdentifier(const Node: IIdentifierNode): TDataValue; override;
function VisitKeyword(const Node: IKeywordNode): TDataValue; override;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; override;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; override;
function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; override;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; override;
function VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; override;
@@ -84,7 +82,12 @@ end;
function TDebugEvaluatorVisitor.VisitFunctionCall(const Node: IFunctionCallNode): TDataValue;
begin
AppendLine('FunctionCall{');
AppendLine(
'FunctionCall ('
+ (if Assigned(Node.StaticTarget) then 'STATIC'
else 'DYNAMIC')
+ ' PATH) {'
);
Indent;
try
ShowScope;
@@ -187,30 +190,6 @@ begin
AppendLine(Format('Identifier "%s" -> %s', [Node.Name, Result.ToString]));
end;
function TDebugEvaluatorVisitor.VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue;
begin
AppendLine(Format('BinaryExpr "%s" {', [Node.Operator.ToString]));
Indent;
try
Result := inherited VisitBinaryExpression(Node);
finally
Unindent;
end;
AppendLine(Format('} -> %s', [Result.ToString]));
end;
function TDebugEvaluatorVisitor.VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue;
begin
AppendLine(Format('UnaryExpr "%s" {', [Node.Operator.ToString]));
Indent;
try
Result := inherited VisitUnaryExpression(Node);
finally
Unindent;
end;
AppendLine(Format('} -> %s', [Result.ToString]));
end;
function TDebugEvaluatorVisitor.VisitIfExpression(const Node: IIfExpressionNode): TDataValue;
begin
AppendLine('IfExpr{');
+87 -51
View File
@@ -27,8 +27,9 @@ type
FIndent: Integer;
procedure Indent;
procedure Unindent;
procedure Log(const Text: string); overload;
procedure LogFmt(const Fmt: string; const Args: array of const); overload;
// Updated Log methods to include the node for type dumping
procedure Log(const Text: string; const Node: IAstNode = nil); overload;
procedure LogFmt(const Fmt: string; const Args: array of const; const Node: IAstNode = nil); overload;
function FormatAddress(const Addr: TResolvedAddress): string;
protected
@@ -36,8 +37,6 @@ type
procedure VisitConstant(const Node: IConstantNode); override;
procedure VisitIdentifier(const Node: IIdentifierNode); override;
procedure VisitKeyword(const Node: IKeywordNode); override;
procedure VisitBinaryExpression(const Node: IBinaryExpressionNode); override;
procedure VisitUnaryExpression(const Node: IUnaryExpressionNode); override;
procedure VisitIfExpression(const Node: IIfExpressionNode); override;
procedure VisitTernaryExpression(const Node: ITernaryExpressionNode); override;
procedure VisitLambdaExpression(const Node: ILambdaExpressionNode); override;
@@ -72,7 +71,8 @@ type
implementation
uses
Myc.Data.Keyword;
Myc.Data.Keyword,
Myc.Ast.Types; // Added for IStaticType.ToString
{ TAstDumper }
@@ -115,14 +115,32 @@ begin
dec(FIndent, 2);
end;
procedure TAstDumper.Log(const Text: string);
procedure TAstDumper.Log(const Text: string; const Node: IAstNode = nil);
var
typeStr: string;
typedNode: IAstTypedNode;
staticType: IStaticType;
begin
FOutput.Add(StringOfChar(' ', FIndent) + Text);
typeStr := '';
// Check if the node is typed
if Assigned(Node) and Node.IsTyped then
begin
typedNode := Node.AsTypedNode;
staticType := typedNode.StaticType;
if Assigned(staticType) then
// Append the static type information
typeStr := Format(' <Type: %s>', [staticType.ToString])
else
typeStr := ' <Type: nil>';
end;
FOutput.Add(StringOfChar(' ', FIndent) + Text + typeStr);
end;
procedure TAstDumper.LogFmt(const Fmt: string; const Args: array of const);
procedure TAstDumper.LogFmt(const Fmt: string; const Args: array of const; const Node: IAstNode = nil);
begin
Log(Format(Fmt, Args));
// Pass the node to the base Log method
Log(Format(Fmt, Args), Node);
end;
function TAstDumper.FormatAddress(const Addr: TResolvedAddress): string;
@@ -138,7 +156,7 @@ end;
procedure TAstDumper.VisitConstant(const Node: IConstantNode);
begin
LogFmt('Constant: %s', [Node.Value.ToString]);
LogFmt('Constant: %s', [Node.Value.ToString], Node);
end;
procedure TAstDumper.VisitIdentifier(const Node: IIdentifierNode);
@@ -148,36 +166,19 @@ begin
adr := Node.Address;
if adr.Kind <> akUnresolved then
LogFmt('Identifier: %s -> %s', [Node.Name, FormatAddress(adr)])
LogFmt('Identifier: %s -> %s', [Node.Name, FormatAddress(adr)], Node)
else
LogFmt('Identifier: %s (unbound)', [Node.Name]);
LogFmt('Identifier: %s (unbound)', [Node.Name], Node);
end;
procedure TAstDumper.VisitKeyword(const Node: IKeywordNode);
begin
LogFmt('Keyword: :%s', [Node.Value.Name]);
end;
procedure TAstDumper.VisitBinaryExpression(const Node: IBinaryExpressionNode);
begin
LogFmt('BinaryExpression: %s', [Node.Operator.ToString]);
Indent;
Node.Left.Accept(Self);
Node.Right.Accept(Self);
Unindent;
end;
procedure TAstDumper.VisitUnaryExpression(const Node: IUnaryExpressionNode);
begin
LogFmt('UnaryExpression: %s', [Node.Operator.ToString]);
Indent;
Node.Right.Accept(Self);
Unindent;
LogFmt('Keyword: :%s', [Node.Value.Name], Node);
end;
procedure TAstDumper.VisitIfExpression(const Node: IIfExpressionNode);
begin
Log('IfExpression');
Log('IfExpression', Node);
Indent;
Log('Condition:');
Node.Condition.Accept(Self);
@@ -193,7 +194,7 @@ end;
procedure TAstDumper.VisitTernaryExpression(const Node: ITernaryExpressionNode);
begin
Log('TernaryExpression');
Log('TernaryExpression', Node);
Indent;
Log('Condition:');
Node.Condition.Accept(Self);
@@ -211,7 +212,7 @@ var
begin
if Assigned(Node.ScopeDescriptor) then
begin
LogFmt('LambdaExpression (HasNested: %s)', [Node.HasNestedLambdas.ToString(TUseBoolStrs.True)]);
LogFmt('LambdaExpression (HasNested: %s)', [Node.HasNestedLambdas.ToString(TUseBoolStrs.True)], Node);
Indent;
Log('Parameters:');
@@ -242,7 +243,7 @@ begin
end
else
begin
Log('LambdaExpression (unbound)');
Log('LambdaExpression (unbound)', Node);
Indent;
Log('Parameters:');
Indent;
@@ -258,8 +259,43 @@ end;
procedure TAstDumper.VisitFunctionCall(const Node: IFunctionCallNode);
var
arg: IAstNode;
staticStatus: string;
sigStr: string; // Added
argTypes: TArray<string>;
i: Integer;
begin
LogFmt('FunctionCall (IsTailCall: %s)', [Node.IsTailCall.ToString(TUseBoolStrs.True)]);
sigStr := ''; // Default to empty
if Assigned(Node.StaticTarget) then
begin
staticStatus := 'Assigned';
// Reconstruct the signature from the available data
SetLength(argTypes, Length(Node.Arguments));
for i := 0 to High(Node.Arguments) do
begin
if Node.Arguments[i].IsTyped then
argTypes[i] := Node.Arguments[i].AsTypedNode.StaticType.ToString
else
argTypes[i] := 'Untyped';
end;
// Node.StaticType holds the return type set by the Specializer
sigStr := Format(' <ResolvedSig: Method(%s): %s>', [string.Join(', ', argTypes), Node.StaticType.ToString]);
end
else
begin
staticStatus := 'nil';
end;
LogFmt(
'FunctionCall (IsTailCall: %s, StaticTarget: %s%s)',
[
Node.IsTailCall.ToString(TUseBoolStrs.True),
staticStatus,
sigStr // Added the signature string
],
Node
); // Pass Node to LogFmt to append the <Type: ...>
Indent;
Log('Callee:');
@@ -276,7 +312,7 @@ procedure TAstDumper.VisitMacroExpansionNode(const Node: IMacroExpansionNode);
var
arg: IAstNode;
begin
Log('MacroExpansion');
Log('MacroExpansion', Node);
Indent;
Log('Original Call:');
@@ -303,7 +339,7 @@ var
arg: IAstNode;
begin
// 'recur' must be a tail call, which is enforced by the binder.
Log('Recur');
Log('Recur', Node);
Indent;
LogFmt('Arguments (%d):', [Length(Node.Arguments)]);
Indent;
@@ -317,7 +353,7 @@ procedure TAstDumper.VisitBlockExpression(const Node: IBlockExpressionNode);
var
expr: IAstNode;
begin
Log('BlockExpression');
Log('BlockExpression', Node);
Indent;
for expr in Node.Expressions do
expr.Accept(Self);
@@ -326,7 +362,7 @@ end;
procedure TAstDumper.VisitVariableDeclaration(const Node: IVariableDeclarationNode);
begin
LogFmt('VariableDeclaration (IsBoxed: %s)', [Node.IsBoxed.ToString(TUseBoolStrs.True)]);
LogFmt('VariableDeclaration (IsBoxed: %s)', [Node.IsBoxed.ToString(TUseBoolStrs.True)], Node);
Indent;
Node.Identifier.Accept(Self);
@@ -340,7 +376,7 @@ end;
procedure TAstDumper.VisitAssignment(const Node: IAssignmentNode);
begin
Log('Assignment');
Log('Assignment', Node);
Indent;
Node.Identifier.Accept(Self);
Log('Value:');
@@ -350,7 +386,7 @@ end;
procedure TAstDumper.VisitMacroDefinition(const Node: IMacroDefinitionNode);
begin
Log('MacroDefinition');
Log('MacroDefinition', Node); // Macros are not IAstTypedNode
Indent;
Log('Name:');
@@ -374,7 +410,7 @@ end;
procedure TAstDumper.VisitQuasiquote(const Node: IQuasiquoteNode);
begin
Log('Quasiquote');
Log('Quasiquote', Node); // Not IAstTypedNode
Indent;
Node.Expression.Accept(Self);
Unindent;
@@ -382,7 +418,7 @@ end;
procedure TAstDumper.VisitUnquote(const Node: IUnquoteNode);
begin
Log('Unquote');
Log('Unquote', Node); // Not IAstTypedNode
Indent;
Node.Expression.Accept(Self);
Unindent;
@@ -390,7 +426,7 @@ end;
procedure TAstDumper.VisitUnquoteSplicing(const Node: IUnquoteSplicingNode);
begin
Log('UnquoteSplicing');
Log('UnquoteSplicing', Node); // Not IAstTypedNode
Indent;
Node.Expression.Accept(Self);
Unindent;
@@ -398,7 +434,7 @@ end;
procedure TAstDumper.VisitIndexer(const Node: IIndexerNode);
begin
Log('Indexer');
Log('Indexer', Node);
Indent;
Log('Base:');
Node.Base.Accept(Self);
@@ -409,7 +445,7 @@ end;
procedure TAstDumper.VisitMemberAccess(const Node: IMemberAccessNode);
begin
Log('MemberAccess');
Log('MemberAccess', Node);
Indent;
Log('Base:');
Node.Base.Accept(Self);
@@ -422,7 +458,7 @@ procedure TAstDumper.VisitRecordLiteral(const Node: IRecordLiteralNode);
var
field: TRecordFieldLiteral;
begin
LogFmt('RecordLiteral (%d fields)', [Length(Node.Fields)]);
LogFmt('RecordLiteral (%d fields)', [Length(Node.Fields)], Node);
Indent;
for field in Node.Fields do
begin
@@ -436,12 +472,12 @@ end;
procedure TAstDumper.VisitCreateSeries(const Node: ICreateSeriesNode);
begin
LogFmt('CreateSeries: %s', [Node.Definition]);
LogFmt('CreateSeries: %s', [Node.Definition], Node);
end;
procedure TAstDumper.VisitAddSeriesItem(const Node: IAddSeriesItemNode);
begin
Log('AddSeriesItem');
Log('AddSeriesItem', Node);
Indent;
Log('Series:');
Node.Series.Accept(Self);
@@ -457,12 +493,12 @@ end;
procedure TAstDumper.VisitNop(const Node: INopNode);
begin
Log('Nop');
Log('Nop', Node);
end;
procedure TAstDumper.VisitSeriesLength(const Node: ISeriesLengthNode);
begin
Log('SeriesLength');
Log('SeriesLength', Node);
Indent;
Log('Series:');
Node.Series.Accept(Self);
+277 -41
View File
@@ -6,15 +6,49 @@ uses
System.SysUtils,
System.Classes,
System.Generics.Collections,
System.Generics.Defaults,
Myc.Data.Value,
Myc.Ast,
Myc.Ast.Nodes,
Myc.Ast.Scope;
Myc.Ast.Scope,
Myc.Ast.RTL,
Myc.Ast.Types;
type
IMacroRegistry = interface; // Forward
IEnvironment = interface; // Forward
IExecutionStrategy = interface; // Forward
IMacroRegistry = interface;
IEnvironment = interface;
IExecutionStrategy = interface;
IFunctionDefinitionRegistry = interface;
// --- Monomorphization Cache Definitions ---
// The key for the specialization cache.
// (Function Address/ID, [Argument Types])
TMonoCacheKey = record
public
Address: TResolvedAddress;
ArgTypes: TArray<IStaticType>;
constructor Create(const AAddress: TResolvedAddress; const AArgTypes: TArray<IStaticType>);
end;
// Comparer for the cache key
TMonoCacheKeyComparer = class(TEqualityComparer<TMonoCacheKey>)
public
function Equals(const Left, Right: TMonoCacheKey): Boolean; override;
function GetHashCode(const Value: TMonoCacheKey): Integer; override; // Updated
end;
// The cache dictionary itself.
// Verwendet den generischen TSpecializedMethod-Record aus Myc.Ast.Types
TMonomorphCache = TDictionary<TMonoCacheKey, TSpecializedMethod>;
// This record holds the executable function and its inferred static type.
TCompiledFunction = record
public
Func: TDataValue.TFunc;
StaticType: IStaticType; // The full static type of the compiled function (e.g., Method(Ord):Method():Ord)
constructor Create(const AFunc: TDataValue.TFunc; const AStaticType: IStaticType);
end;
// Defines the Strategy for creating an Evaluator.
IExecutionStrategy = interface
@@ -33,25 +67,39 @@ type
property Parent: IMacroRegistry read GetParent;
end;
IFunctionDefinitionRegistry = interface
procedure Register(const Address: TResolvedAddress; const ADef: IFunctionDefinition);
function Resolve(const Address: TResolvedAddress): IFunctionDefinition;
end;
// Defines the central environment for compilation and execution.
IEnvironment = interface
{$region 'private'}
function GetRootScope: IExecutionScope;
function GetMacroRegistry: IMacroRegistry;
function GetMonomorphCache: TMonomorphCache;
function GetFunctionRegistry: IFunctionDefinitionRegistry;
{$endregion}
procedure SetExecutionStrategy(const AStrategy: IExecutionStrategy);
function ExpandMacros(const Node: IAstNode): IAstNode;
function Bind(const Node: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
function Lower(const Node: IAstNode): IAstNode;
function Bind(const Node: IAstNode; out Descriptor: IScopeDescriptor; const AArgTypes: TArray<IStaticType> = []): IAstNode;
function Specialize(const Node: IAstNode; const ADescriptor: IScopeDescriptor): IAstNode;
function Compile(const ANode: IAstNode; const Params: TArray<IIdentifierNode> = []): TDataValue.TFunc;
function Compile(
const ANode: IAstNode;
const Params: TArray<IIdentifierNode> = [];
const AArgTypes: TArray<IStaticType> = []
): TCompiledFunction; overload;
function Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType> = []): TCompiledFunction; overload;
function CreateEnvironment: IEnvironment;
property RootScope: IExecutionScope read GetRootScope;
property MacroRegistry: IMacroRegistry read GetMacroRegistry;
property MonomorphCache: TMonomorphCache read GetMonomorphCache;
property FunctionRegistry: IFunctionDefinitionRegistry read GetFunctionRegistry;
end;
// Interface Helper for IEnvironment
@@ -63,7 +111,8 @@ type
public
constructor Create(const AEnvironment: IEnvironment);
class operator Initialize(out Dest: TAstEnvironment);
class function Construct(const Scope: IExecutionScope): TAstEnvironment; static;
class operator Implicit(const A: IEnvironment): TAstEnvironment;
class operator Implicit(const A: TAstEnvironment): IEnvironment;
@@ -73,7 +122,12 @@ type
procedure SetDebugMode(ALog: TStrings; AShowScope: Boolean);
function Run(const ANode: IAstNode; const Params: TArray<IIdentifierNode> = []; const Args: TArray<TDataValue> = []): TDataValue;
function Compile(const ANode: IAstNode; const Params: TArray<IIdentifierNode> = []): TDataValue.TFunc;
function Compile(
const Node: IAstNode;
const Params: TArray<IIdentifierNode> = [];
const ArgTypes: TArray<IStaticType> = []
): TCompiledFunction; overload; experimental;
function Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType> = []): TCompiledFunction; overload;
procedure Define(const Name: String; const AScript: IAstNode);
@@ -85,15 +139,83 @@ type
implementation
uses
Myc.Ast.RTL,
System.Hash,
Myc.Ast.Evaluator,
Myc.Ast.Debugger,
Myc.Ast.Compiler.Macros,
Myc.Ast.Compiler.Binder,
Myc.Ast.Compiler.TypeChecker,
Myc.Ast.Compiler.Lowering,
Myc.Ast.Compiler.Specializer,
Myc.Ast.Compiler.TCO;
{ TMonoCacheKey }
constructor TMonoCacheKey.Create(const AAddress: TResolvedAddress; const AArgTypes: TArray<IStaticType>);
begin
Address := AAddress;
ArgTypes := AArgTypes;
end;
{ TMonoCacheKeyComparer }
function TMonoCacheKeyComparer.Equals(const Left, Right: TMonoCacheKey): Boolean;
var
i: Integer;
begin
if not (Left.Address = Right.Address) then // Use operator =
exit(False);
if Length(Left.ArgTypes) <> Length(Right.ArgTypes) then
exit(False);
// Compare types
for i := 0 to High(Left.ArgTypes) do
begin
if not Left.ArgTypes[i].IsEqual(Right.ArgTypes[i]) then
exit(False);
end;
Result := True;
end;
function TMonoCacheKeyComparer.GetHashCode(const Value: TMonoCacheKey): Integer;
var
i: Integer;
hash: Integer;
typeHash: Integer; // Changed from ptrHash
adr: TResolvedAddress;
begin
adr := Value.Address;
// 1. Hash the TResolvedAddress components
hash := THashBobJenkins.GetHashValue(adr.Kind, SizeOf(TAddressKind), 0);
hash := THashBobJenkins.GetHashValue(adr.ScopeDepth, SizeOf(Integer), hash);
hash := THashBobJenkins.GetHashValue(adr.SlotIndex, SizeOf(Integer), hash);
// 2. Iteratively combine the hash of each argument type
for i := 0 to High(Value.ArgTypes) do
begin
// Get the hash code from the type itself (consistent with IsEqual)
if Assigned(Value.ArgTypes[i]) then
typeHash := Value.ArgTypes[i].GetHashCode
else
typeHash := 0;
// Combine the new hash (typeHash) with the existing hash (hash)
hash := THashBobJenkins.GetHashValue(typeHash, SizeOf(Integer), hash);
end;
Result := hash;
end;
{ TCompiledFunction }
constructor TCompiledFunction.Create(const AFunc: TDataValue.TFunc; const AStaticType: IStaticType);
begin
Func := AFunc;
StaticType := AStaticType;
end;
type
{ TStandardExecutionStrategy }
TStandardExecutionStrategy = class(TInterfacedObject, IExecutionStrategy)
@@ -125,14 +247,28 @@ type
function CreateChildRegistry: IMacroRegistry;
end;
TFunctionDefinitionRegistry = class(TInterfacedObject, IFunctionDefinitionRegistry)
private
FMap: TDictionary<TResolvedAddress, IFunctionDefinition>;
public
constructor Create;
destructor Destroy; override;
procedure Register(const Address: TResolvedAddress; const ADef: IFunctionDefinition);
function Resolve(const Address: TResolvedAddress): IFunctionDefinition;
end;
{ TEnvironment }
TEnvironment = class(TInterfacedObject, IEnvironment)
private
FRootScope: IExecutionScope;
FMacroRegistry: IMacroRegistry;
FExecutionStrategy: IExecutionStrategy;
FMonomorphCache: TMonomorphCache;
FFunctionRegistry: IFunctionDefinitionRegistry;
function GetRootScope: IExecutionScope;
function GetMacroRegistry: IMacroRegistry;
function GetMonomorphCache: TMonomorphCache;
function GetFunctionRegistry: IFunctionDefinitionRegistry;
public
constructor Create(
const ARootScope: IExecutionScope;
@@ -146,22 +282,17 @@ type
procedure SetExecutionStrategy(const AStrategy: IExecutionStrategy);
function ExpandMacros(const Node: IAstNode): IAstNode;
function Bind(const Node: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
function Lower(const Node: IAstNode): IAstNode;
function Bind(const Node: IAstNode; out Descriptor: IScopeDescriptor; const ArgTypes: TArray<IStaticType>): IAstNode;
function Specialize(const Node: IAstNode; const ADescriptor: IScopeDescriptor): IAstNode;
function Compile(const Node: IAstNode; const Params: TArray<IIdentifierNode>): TDataValue.TFunc;
function Compile(
const Node: IAstNode;
const Params: TArray<IIdentifierNode>;
const ArgTypes: TArray<IStaticType>
): TCompiledFunction; overload;
function Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType>): TCompiledFunction; overload;
end;
// --- Factory Implementations ---
{ TAstEnvironment }
class operator TAstEnvironment.Initialize(out Dest: TAstEnvironment);
begin
Dest.FEnvironment :=
TEnvironment.Create(TScope.CreateScope(nil, nil, nil), TMacroRegistryImpl.Create(nil), TStandardExecutionStrategy.Create);
end;
constructor TAstEnvironment.Create(const AEnvironment: IEnvironment);
begin
FEnvironment := AEnvironment;
@@ -187,9 +318,36 @@ begin
Result := A.FEnvironment;
end;
function TAstEnvironment.Compile(const ANode: IAstNode; const Params: TArray<IIdentifierNode> = []): TDataValue.TFunc;
function TAstEnvironment.Compile(
const Node: IAstNode;
const Params: TArray<IIdentifierNode> = [];
const ArgTypes: TArray<IStaticType> = []
): TCompiledFunction;
begin
Result := FEnvironment.Compile(ANode, Params);
Result := FEnvironment.Compile(Node, Params, ArgTypes);
end;
function TAstEnvironment.Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType> = []): TCompiledFunction;
begin
Result := FEnvironment.Compile(Node, ArgTypes);
end;
class function TAstEnvironment.Construct(const Scope: IExecutionScope): TAstEnvironment;
var
RootScope: IExecutionScope;
begin
// When constructing the *very first* environment:
// 1. Create a root scope (parented to nil).
// 2. Explicitly request library registration (ARegisterLibraries = True).
RootScope := TAst.CreateScope(nil, nil, True);
Result.Create(
TEnvironment.Create(
RootScope, // Use the new root scope
TMacroRegistryImpl.Create(nil),
TStandardExecutionStrategy.Create
)
);
end;
function TAstEnvironment.CreateEnvironment: TAstEnvironment;
@@ -199,8 +357,8 @@ end;
procedure TAstEnvironment.Define(const Name: String; const AScript: IAstNode);
begin
var exec := Compile(AScript);
RootScope.Define(Name, exec([]));
var compiled := Compile(AScript);
RootScope.Define(Name, compiled.Func([]));
end;
function TAstEnvironment.GetRootScope: IExecutionScope;
@@ -219,8 +377,8 @@ function TAstEnvironment.Run(
const Args: TArray<TDataValue> = []
): TDataValue;
begin
var exec := Compile(ANode, Params);
Result := exec(Args);
var compiled := Compile(ANode, Params);
Result := compiled.Func(Args);
end;
{ TStandardExecutionStrategy }
@@ -288,6 +446,31 @@ begin
Result := TMacroRegistryImpl.Create(Self);
end;
{ TFunctionDefinitionRegistry }
constructor TFunctionDefinitionRegistry.Create;
begin
inherited Create;
// We can use the comparer from Myc.Ast.Scope
FMap := TDictionary<TResolvedAddress, IFunctionDefinition>.Create(TResolvedAddressComparer.Create);
end;
destructor TFunctionDefinitionRegistry.Destroy;
begin
FMap.Free;
inherited Destroy;
end;
procedure TFunctionDefinitionRegistry.Register(const Address: TResolvedAddress; const ADef: IFunctionDefinition);
begin
FMap.AddOrSetValue(Address, ADef);
end;
function TFunctionDefinitionRegistry.Resolve(const Address: TResolvedAddress): IFunctionDefinition;
begin
FMap.TryGetValue(Address, Result);
end;
{ TEnvironment }
constructor TEnvironment.Create(
@@ -300,16 +483,25 @@ begin
FRootScope := ARootScope;
FMacroRegistry := AMacroRegistry;
FExecutionStrategy := AExecutionStrategy;
// Create the isolated, instance-specific cache
FMonomorphCache := TMonomorphCache.Create(TMonoCacheKeyComparer.Create);
FFunctionRegistry := TFunctionDefinitionRegistry.Create;
end;
destructor TEnvironment.Destroy;
begin
FMonomorphCache.Free;
inherited Destroy;
end;
function TEnvironment.Bind(const Node: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
function TEnvironment.GetMonomorphCache: TMonomorphCache;
begin
var boundAst := TAstBinder.Bind(FRootScope.CreateDescriptor, Node, Descriptor);
Result := FMonomorphCache;
end;
function TEnvironment.Bind(const Node: IAstNode; out Descriptor: IScopeDescriptor; const ArgTypes: TArray<IStaticType>): IAstNode;
begin
var boundAst := TAstBinder.Bind(FRootScope.CreateDescriptor, Node, Descriptor, FFunctionRegistry, ArgTypes);
var typedAst := TTypeChecker.CheckTypes(boundAst, Descriptor);
Result := typedAst;
@@ -332,31 +524,69 @@ end;
function TEnvironment.CreateEnvironment: IEnvironment;
begin
Result := TEnvironment.Create(TScope.CreateScope(FRootScope, nil, nil), TMacroRegistryImpl.Create(FMacroRegistry), FExecutionStrategy);
// Create a new child environment. It inherits the parent scope (FRootScope) and does *not* re-register the RTL.
Result := TEnvironment.Create(TAst.CreateScope(FRootScope), TMacroRegistryImpl.Create(FMacroRegistry), FExecutionStrategy);
end;
function TEnvironment.Compile(const Node: IAstNode; const Params: TArray<IIdentifierNode>): TDataValue.TFunc;
function TEnvironment.Compile(
const Node: IAstNode;
const Params: TArray<IIdentifierNode>;
const ArgTypes: TArray<IStaticType>
): TCompiledFunction;
var
desc: IScopeDescriptor;
funcType: IStaticType;
finalFunc: TDataValue.TFunc;
begin
var prg := TAst.LambdaExpr(Params, Node);
var expanded := ExpandMacros(prg);
var bound := Bind(expanded, desc);
var lowered := Lower(bound);
var bound := Bind(expanded, desc, ArgTypes);
var tcoOptimized := TAstTCO.Optimize(lowered);
Assert(bound.IsTyped);
funcType := bound.AsTypedNode.StaticType;
var specialized := Specialize(bound, desc);
var tcoOptimized := TAstTCO.Optimize(specialized);
var visitor := FExecutionStrategy.CreateVisitor(desc.CreateScope(FRootScope));
var func := tcoOptimized.Accept(visitor).AsMethod;
Result :=
finalFunc :=
function(const Args: TArray<TDataValue>): TDataValue
begin
Result := func(Args);
TEvaluatorVisitor.HandleTCO(Result);
end;
Result := TCompiledFunction.Create(finalFunc, funcType);
end;
function TEnvironment.Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType>): TCompiledFunction;
var
desc: IScopeDescriptor;
funcType: IStaticType;
finalFunc: TDataValue.TFunc;
begin
var expanded := ExpandMacros(Node);
var bound := Bind(expanded, desc, ArgTypes);
funcType := bound.AsTypedNode.StaticType;
var specialized := Specialize(bound, desc);
var tcoOptimized := TAstTCO.Optimize(specialized);
var visitor := FExecutionStrategy.CreateVisitor(desc.CreateScope(FRootScope));
var func := tcoOptimized.Accept(visitor).AsMethod;
finalFunc :=
function(const Args: TArray<TDataValue>): TDataValue
begin
Result := func(Args);
TEvaluatorVisitor.HandleTCO(Result);
end;
Result := TCompiledFunction.Create(finalFunc, funcType);
end;
function TEnvironment.ExpandMacros(const Node: IAstNode): IAstNode;
@@ -371,9 +601,15 @@ begin
);
end;
function TEnvironment.Lower(const Node: IAstNode): IAstNode;
function TEnvironment.GetFunctionRegistry: IFunctionDefinitionRegistry;
begin
Result := TAstLowerer.Lower(Node);
Result := FFunctionRegistry;
end;
function TEnvironment.Specialize(const Node: IAstNode; const ADescriptor: IScopeDescriptor): IAstNode;
begin
// Call the new Specializer, passing the environment for cache access
Result := TStaticSpecializer.Specialize(Self, Node, ADescriptor);
end;
end.
+42 -54
View File
@@ -25,8 +25,6 @@ type
function VisitConstant(const Node: IConstantNode): TDataValue; virtual;
function VisitIdentifier(const Node: IIdentifierNode): TDataValue; virtual;
function VisitKeyword(const Node: IKeywordNode): TDataValue; virtual;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; virtual;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; virtual;
function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; virtual;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; virtual;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; virtual;
@@ -270,27 +268,54 @@ function TEvaluatorVisitor.VisitFunctionCall(const Node: IFunctionCallNode): TDa
var
calleeValue: TDataValue;
argValues: TArray<TDataValue>;
i: Integer;
argNodes: TArray<IAstNode>;
begin
calleeValue := Node.Callee.Accept(Self);
if calleeValue.Kind <> vkMethod then
raise EArgumentException.Create('Expression is not invokable in this context.');
var argNodes := Node.Arguments;
SetLength(argValues, Length(argNodes));
for var i := 0 to High(argNodes) do
argValues[i] := argNodes[i].Accept(Self);
if Node.IsTailCall then
if Assigned(Node.StaticTarget) then
begin
// This is a tail call. Return a thunk to be processed by the trampoline.
Result := TDataValue.FromGeneric<TThunk>(TThunk.Create(calleeValue, argValues, false));
// --- Static Path (Optimized) ---
// 1. Evaluate arguments
argNodes := Node.Arguments;
SetLength(argValues, Length(argNodes));
for i := 0 to High(argNodes) do
begin
Assert(argNodes[i].IsTyped and (argNodes[i].AsTypedNode.StaticType <> TTypes.Unknown), 'Static call argument is not typed.');
argValues[i] := argNodes[i].Accept(Self);
end;
// 2. Call the static target directly
// The target is a TDataValue.TFunc expecting TArray<TDataValue>
Result := Node.StaticTarget(argValues);
// 3. Handle TCO
// If the static target itself was a compiled lambda ending in 'recur',
// it will return a Thunk, which we must handle.
HandleTCO(Result);
end
else
begin
// This is a non-tail call. It must execute the call and act as the trampoline.
Result := (calleeValue.AsMethod)(argValues);
// --- Dynamic Path (Default) ---
calleeValue := Node.Callee.Accept(Self);
if calleeValue.Kind <> vkMethod then
raise EArgumentException.Create('Expression is not invokable in this context.');
HandleTCO(Result);
argNodes := Node.Arguments;
SetLength(argValues, Length(argNodes));
for i := 0 to High(argNodes) do
argValues[i] := argNodes[i].Accept(Self);
if Node.IsTailCall then
begin
// This is a tail call. Return a thunk to be processed by the trampoline.
Result := TDataValue.FromGeneric<TThunk>(TThunk.Create(calleeValue, argValues, false));
end
else
begin
// This is a non-tail call. It must execute the call and act as the trampoline.
Result := (calleeValue.AsMethod)(argValues);
HandleTCO(Result);
end;
end;
end;
@@ -558,43 +583,6 @@ begin
end;
end;
function TEvaluatorVisitor.VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue;
var
leftValue, rightValue: TDataValue;
resScalar: TScalar;
begin
leftValue := Node.Left.Accept(Self);
rightValue := Node.Right.Accept(Self);
// Standard scalar operations
if (leftValue.Kind <> vkScalar) or (rightValue.Kind <> vkScalar) then
raise ENotSupportedException.Create('Binary operations are only supported for scalar types.');
if not TScalar.TryBinaryOperation(Node.Operator, leftValue.AsScalar, rightValue.AsScalar, resScalar) then
raise ENotSupportedException.Create(
'Binary operation not supported for scalar types '
+ leftValue.AsScalar.Kind.ToString
+ ' and '
+ rightValue.AsScalar.Kind.ToString
+ ' .');
Result := TDataValue(resScalar); // Explicit cast
end;
function TEvaluatorVisitor.VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue;
var
rightValue: TDataValue;
begin
rightValue := Node.Right.Accept(Self);
if rightValue.Kind <> vkScalar then
raise ENotSupportedException.Create('Unary operations are only supported for scalar types.');
var res: TScalar;
if not TScalar.TryUnaryOperation(Node.Operator, rightValue.AsScalar, res) then
raise ENotSupportedException.Create('Unary operation not supported for scalar type' + rightValue.AsScalar.Kind.ToString + '.');
Result := TDataValue(res); // Explicit cast
end;
function TEvaluatorVisitor.VisitIfExpression(const Node: IIfExpressionNode): TDataValue;
begin
if IsTruthy(Node.Condition.Accept(Self)) then
-69
View File
@@ -30,8 +30,6 @@ type
function JsonToConstantNode(const AObj: TJSONObject): IConstantNode;
function JsonToIdentifierNode(const AObj: TJSONObject): IIdentifierNode;
function JsonToKeywordNode(const AObj: TJSONObject): IKeywordNode;
function JsonToBinaryExprNode(const AObj: TJSONObject): IBinaryExpressionNode;
function JsonToUnaryExprNode(const AObj: TJSONObject): IUnaryExpressionNode;
function JsonToIfExprNode(const AObj: TJSONObject): IIfExpressionNode;
function JsonToTernaryExprNode(const AObj: TJSONObject): ITernaryExpressionNode;
function JsonToLambdaExprNode(const AObj: TJSONObject): ILambdaExpressionNode;
@@ -58,8 +56,6 @@ type
function VisitConstant(const Node: IConstantNode): TJSONObject; override;
function VisitIdentifier(const Node: IIdentifierNode): TJSONObject; override;
function VisitKeyword(const Node: IKeywordNode): TJSONObject; override;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): TJSONObject; override;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): TJSONObject; override;
function VisitIfExpression(const Node: IIfExpressionNode): TJSONObject; override;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): TJSONObject; override;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TJSONObject; override;
@@ -162,32 +158,6 @@ begin
Result.AddPair('Name', TJSONString.Create(Node.Value.Name));
end;
function TJsonAstConverter.VisitBinaryExpression(const Node: IBinaryExpressionNode): TJSONObject;
var
leftObj, rightObj: TJSONObject;
begin
leftObj := Accept(Node.Left);
rightObj := Accept(Node.Right);
Result := TJSONObject.Create;
Result.AddPair('NodeType', TJSONString.Create('BinaryExpr'));
Result.AddPair('Operator', TJSONString.Create(Node.Operator.ToString));
Result.AddPair('Left', leftObj);
Result.AddPair('Right', rightObj);
end;
function TJsonAstConverter.VisitUnaryExpression(const Node: IUnaryExpressionNode): TJSONObject;
var
rightObj: TJSONObject;
begin
rightObj := Accept(Node.Right);
Result := TJSONObject.Create;
Result.AddPair('NodeType', TJSONString.Create('UnaryExpr'));
Result.AddPair('Operator', TJSONString.Create(Node.Operator.ToString));
Result.AddPair('Right', rightObj);
end;
function TJsonAstConverter.VisitIfExpression(const Node: IIfExpressionNode): TJSONObject;
var
condObj, thenObj, elseObj: TJSONObject;
@@ -517,41 +487,6 @@ begin
Result := TAst.Keyword(AObj.GetValue<string>('Name'));
end;
function TJsonAstConverter.JsonToBinaryExprNode(const AObj: TJSONObject): IBinaryExpressionNode;
var
opStr: string;
op: TScalar.TBinaryOp;
leftNode, rightNode: IAstNode;
begin
opStr := AObj.GetValue<string>('Operator');
for op := Low(TScalar.TBinaryOp) to High(TScalar.TBinaryOp) do
if SameText(op.ToString, opStr) then
begin
leftNode := JsonToNode(AObj.GetValue('Left'));
rightNode := JsonToNode(AObj.GetValue('Right'));
Result := TAst.BinaryExpr(leftNode, op, rightNode);
exit;
end;
raise EInvalidOpException.CreateFmt('Unknown binary operator "%s"', [opStr]);
end;
function TJsonAstConverter.JsonToUnaryExprNode(const AObj: TJSONObject): IUnaryExpressionNode;
var
opStr: string;
op: TScalar.TUnaryOp;
rightNode: IAstNode;
begin
opStr := AObj.GetValue<string>('Operator');
for op := Low(TScalar.TUnaryOp) to High(TScalar.TUnaryOp) do
if SameText(op.ToString, opStr) then
begin
rightNode := JsonToNode(AObj.GetValue('Right'));
Result := TAst.UnaryExpr(op, rightNode);
exit;
end;
raise EInvalidOpException.CreateFmt('Unknown unary operator "%s"', [opStr]);
end;
function TJsonAstConverter.JsonToIfExprNode(const AObj: TJSONObject): IIfExpressionNode;
var
condNode, thenNode, elseNode: IAstNode;
@@ -792,10 +727,6 @@ begin
Result := JsonToIdentifierNode(obj)
else if nodeType = 'Keyword' then
Result := JsonToKeywordNode(obj)
else if nodeType = 'BinaryExpr' then
Result := JsonToBinaryExprNode(obj)
else if nodeType = 'UnaryExpr' then
Result := JsonToUnaryExprNode(obj)
else if nodeType = 'IfExpr' then
Result := JsonToIfExprNode(obj)
else if nodeType = 'TernaryExpr' then
+12 -29
View File
@@ -15,11 +15,10 @@ type
// --- Forward Declarations to break cycles ---
IAstVisitor = interface;
IAstNode = interface;
IFunctionDefinition = interface;
IIdentifierNode = interface;
IConstantNode = interface;
IKeywordNode = interface;
IBinaryExpressionNode = interface;
IUnaryExpressionNode = interface;
IIfExpressionNode = interface;
ITernaryExpressionNode = interface;
ILambdaExpressionNode = interface;
@@ -47,8 +46,6 @@ type
akConstant,
akIdentifier,
akKeyword,
akBinaryExpression,
akUnaryExpression,
akIfExpression,
akTernaryExpression,
akLambdaExpression,
@@ -90,8 +87,6 @@ type
function VisitConstant(const Node: IConstantNode): TDataValue;
function VisitIdentifier(const Node: IIdentifierNode): TDataValue;
function VisitKeyword(const Node: IKeywordNode): TDataValue;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue;
function VisitIfExpression(const Node: IIfExpressionNode): TDataValue;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue;
@@ -124,8 +119,6 @@ type
function AsConstant: IConstantNode;
function AsIdentifier: IIdentifierNode;
function AsKeyword: IKeywordNode;
function AsBinaryExpression: IBinaryExpressionNode;
function AsUnaryExpression: IUnaryExpressionNode;
function AsIfExpression: IIfExpressionNode;
function AsTernaryExpression: ITernaryExpressionNode;
function AsLambdaExpression: ILambdaExpressionNode;
@@ -160,6 +153,16 @@ type
property StaticType: IStaticType read GetStaticType;
end;
// The abstract definition of a callable function body
IFunctionDefinition = interface(IAstTypedNode)
{$region 'private'}
function GetBody: IAstNode;
function GetParameters: TArray<IIdentifierNode>;
{$endregion}
property Body: IAstNode read GetBody;
property Parameters: TArray<IIdentifierNode> read GetParameters;
end;
INopNode = interface(IAstTypedNode)
// A placeholder node for the UI (e.g., drag target).
end;
@@ -190,26 +193,6 @@ type
property Value: IKeyword read GetValue;
end;
IBinaryExpressionNode = interface(IAstTypedNode)
{$region 'private'}
function GetLeft: IAstNode;
function GetOperator: TScalar.TBinaryOp;
function GetRight: IAstNode;
{$endregion}
property Left: IAstNode read GetLeft;
property Operator: TScalar.TBinaryOp read GetOperator;
property Right: IAstNode read GetRight;
end;
IUnaryExpressionNode = interface(IAstTypedNode)
{$region 'private'}
function GetOperator: TScalar.TUnaryOp;
function GetRight: IAstNode;
{$endregion}
property Operator: TScalar.TUnaryOp read GetOperator;
property Right: IAstNode read GetRight;
end;
IIfExpressionNode = interface(IAstTypedNode)
{$region 'private'}
function GetCondition: IAstNode;
@@ -232,7 +215,7 @@ type
property ElseBranch: IAstNode read GetElseBranch;
end;
ILambdaExpressionNode = interface(IAstTypedNode)
ILambdaExpressionNode = interface(IFunctionDefinition)
{$region 'private'}
function GetParameters: TArray<IIdentifierNode>;
function GetBody: IAstNode;
+414 -21
View File
@@ -12,68 +12,193 @@ type
// Contains the "pure" native implementations.
TRtlFunctions = record
public
[TRtlFunction('+')]
// (* --- Dynamic Fallbacks --- *)
[TRtlExport('+')]
class function Add(const Args: TArray<TDataValue>): TDataValue; overload; static;
[TRtlFunction('-')]
[TRtlExport('-')]
class function Subtract(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('*')]
[TRtlExport('*')]
class function Multiply(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('/')]
[TRtlExport('/')]
class function Divide(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('=')]
[TRtlExport('=')]
class function Equal(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('<>')]
[TRtlExport('<>')]
class function NotEqual(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('<')]
[TRtlExport('<')]
class function LessThan(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('<=')]
[TRtlExport('<=')]
class function LessThanOrEqual(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('>')]
[TRtlExport('>')]
class function GreaterThan(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('>=')]
[TRtlExport('>=')]
class function GreaterThanOrEqual(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('not')]
[TRtlExport('not')]
class function LogicalNot(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('Abs')]
// (* Dynamic fallbacks for TScalar input *)
[TRtlExport('Abs')]
class function Abs(const Arg: TScalar): TScalar; static;
[TRtlFunction('Trunc')]
[TRtlExport('Trunc')]
class function Trunc(const Arg: TScalar): TScalar; static;
[TRtlFunction('Ceil')]
[TRtlExport('Ceil')]
class function Ceil(const Arg: TScalar): TScalar; static;
[TRtlFunction('Floor')]
[TRtlExport('Floor')]
class function Floor(const Arg: TScalar): TScalar; static;
[TRtlFunction('Sign')]
[TRtlExport('Sign')]
class function Sign(const Arg: TScalar): TScalar; static;
[TRtlFunction('Memoize')]
// (* Other dynamic functions *)
[TRtlExport('Memoize')]
class function Memoize(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('Map')]
[TRtlExport('Map')]
class function Map(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('Reduce')]
[TRtlExport('Reduce')]
class function Reduce(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('Where')]
[TRtlExport('Where')]
class function Where(const Args: TArray<TDataValue>): TDataValue; static;
[TRtlFunction('Any')]
[TRtlExport('Any')]
class function Any(const Args: TArray<TDataValue>): TDataValue; static;
// (* --- Static Specializations (for Monomorphization) --- *)
// (* Schema: FunctionName_Arg1_ArgN_Return *)
// Add
[TRtlExport('+', True)]
class function Add_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('+', True)]
class function Add_Float_Float_Float(A, B: Double): Double; static;
[TRtlExport('+', True)]
class function Add_Ordinal_Float_Float(A: Int64; B: Double): Double; static;
[TRtlExport('+', True)]
class function Add_Float_Ordinal_Float(A: Double; B: Int64): Double; static;
// Subtract
[TRtlExport('-', True)]
class function Subtract_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('-', True)]
class function Subtract_Float_Float_Float(A, B: Double): Double; static;
[TRtlExport('-', True)]
class function Subtract_Ordinal_Float_Float(A: Int64; B: Double): Double; static;
[TRtlExport('-', True)]
class function Subtract_Float_Ordinal_Float(A: Double; B: Int64): Double; static;
// Multiply
[TRtlExport('*', True)]
class function Multiply_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('*', True)]
class function Multiply_Float_Float_Float(A, B: Double): Double; static;
[TRtlExport('*', True)]
class function Multiply_Ordinal_Float_Float(A: Int64; B: Double): Double; static;
[TRtlExport('*', True)]
class function Multiply_Float_Ordinal_Float(A: Double; B: Int64): Double; static;
// Divide (NOT pure due to DivByZero)
[TRtlExport('/')]
class function Divide_Ordinal_Ordinal_Float(A, B: Int64): Double; static;
[TRtlExport('/')]
class function Divide_Float_Float_Float(A, B: Double): Double; static;
[TRtlExport('/')]
class function Divide_Ordinal_Float_Float(A: Int64; B: Double): Double; static;
[TRtlExport('/')]
class function Divide_Float_Ordinal_Float(A: Double; B: Int64): Double; static;
// Comparisons (Return Ordinal)
[TRtlExport('=', True)]
class function Equal_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('=', True)]
class function Equal_Float_Float_Ordinal(A, B: Double): Int64; static;
[TRtlExport('=', True)]
class function Equal_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64; static;
[TRtlExport('=', True)]
class function Equal_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64; static;
[TRtlExport('=', True)]
class function Equal_Keyword_Keyword_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('<>', True)]
class function NotEqual_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('<>', True)]
class function NotEqual_Float_Float_Ordinal(A, B: Double): Int64; static;
[TRtlExport('<>', True)]
class function NotEqual_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64; static;
[TRtlExport('<>', True)]
class function NotEqual_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64; static;
[TRtlExport('<>', True)]
class function NotEqual_Keyword_Keyword_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('<', True)]
class function Less_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('<', True)]
class function Less_Float_Float_Ordinal(A, B: Double): Int64; static;
[TRtlExport('<', True)]
class function Less_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64; static;
[TRtlExport('<', True)]
class function Less_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64; static;
[TRtlExport('<=', True)]
class function LessOrEqual_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('<=', True)]
class function LessOrEqual_Float_Float_Ordinal(A, B: Double): Int64; static;
[TRtlExport('<=', True)]
class function LessOrEqual_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64; static;
[TRtlExport('<=', True)]
class function LessOrEqual_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64; static;
[TRtlExport('>', True)]
class function Greater_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('>', True)]
class function Greater_Float_Float_Ordinal(A, B: Double): Int64; static;
[TRtlExport('>', True)]
class function Greater_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64; static;
[TRtlExport('>', True)]
class function Greater_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64; static;
[TRtlExport('>=', True)]
class function GreaterOrEqual_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64; static;
[TRtlExport('>=', True)]
class function GreaterOrEqual_Float_Float_Ordinal(A, B: Double): Int64; static;
[TRtlExport('>=', True)]
class function GreaterOrEqual_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64; static;
[TRtlExport('>=', True)]
class function GreaterOrEqual_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64; static;
// Unary
[TRtlExport('-', True)]
class function Negate_Ordinal_Ordinal(A: Int64): Int64; static;
[TRtlExport('-', True)]
class function Negate_Float_Float(A: Double): Double; static;
[TRtlExport('not', True)]
class function Not_Ordinal_Ordinal(A: Int64): Int64; static;
// Standard functions
[TRtlExport('Abs', True)]
class function Abs_Ordinal_Ordinal(A: Int64): Int64; static;
[TRtlExport('Abs', True)]
class function Abs_Float_Float(A: Double): Double; static;
[TRtlExport('Trunc', True)]
class function Trunc_Ordinal_Ordinal(A: Int64): Int64; static;
[TRtlExport('Trunc', True)]
class function Trunc_Float_Ordinal(A: Double): Int64; static;
end;
implementation
@@ -456,4 +581,272 @@ begin
Result := TScalar.FromInt64(0);
end;
{ TRtlFunctions - Static Specializations }
// --- Add ---
class function TRtlFunctions.Add_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := A + B;
end;
class function TRtlFunctions.Add_Float_Float_Float(A, B: Double): Double;
begin
Result := A + B;
end;
class function TRtlFunctions.Add_Ordinal_Float_Float(A: Int64; B: Double): Double;
begin
Result := A + B;
end;
class function TRtlFunctions.Add_Float_Ordinal_Float(A: Double; B: Int64): Double;
begin
Result := A + B;
end;
// --- Subtract ---
class function TRtlFunctions.Subtract_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := A - B;
end;
class function TRtlFunctions.Subtract_Float_Float_Float(A, B: Double): Double;
begin
Result := A - B;
end;
class function TRtlFunctions.Subtract_Ordinal_Float_Float(A: Int64; B: Double): Double;
begin
Result := A - B;
end;
class function TRtlFunctions.Subtract_Float_Ordinal_Float(A: Double; B: Int64): Double;
begin
Result := A - B;
end;
// --- Multiply ---
class function TRtlFunctions.Multiply_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := A * B;
end;
class function TRtlFunctions.Multiply_Float_Float_Float(A, B: Double): Double;
begin
Result := A * B;
end;
class function TRtlFunctions.Multiply_Ordinal_Float_Float(A: Int64; B: Double): Double;
begin
Result := A * B;
end;
class function TRtlFunctions.Multiply_Float_Ordinal_Float(A: Double; B: Int64): Double;
begin
Result := A * B;
end;
// --- Divide ---
class function TRtlFunctions.Divide_Ordinal_Ordinal_Float(A, B: Int64): Double;
begin
if B = 0 then
raise EDivByZero.Create('Division by zero.');
Result := A / B;
end;
class function TRtlFunctions.Divide_Float_Float_Float(A, B: Double): Double;
begin
if B = 0.0 then
raise EDivByZero.Create('Division by zero.');
Result := A / B;
end;
class function TRtlFunctions.Divide_Ordinal_Float_Float(A: Int64; B: Double): Double;
begin
if B = 0.0 then
raise EDivByZero.Create('Division by zero.');
Result := A / B;
end;
class function TRtlFunctions.Divide_Float_Ordinal_Float(A: Double; B: Int64): Double;
begin
if B = 0 then
raise EDivByZero.Create('Division by zero.');
Result := A / B;
end;
// --- Comparisons ---
(* Delphi bools: 0=False, 1=True. We return Int64 (0 or 1) *)
class function TRtlFunctions.Equal_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := Ord(A = B);
end;
class function TRtlFunctions.Equal_Float_Float_Ordinal(A, B: Double): Int64;
begin
Result := Ord(A = B); // Note: Standard float comparison
end;
class function TRtlFunctions.Equal_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64;
begin
Result := Ord(A = B);
end;
class function TRtlFunctions.Equal_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64;
begin
Result := Ord(A = B);
end;
class function TRtlFunctions.Equal_Keyword_Keyword_Ordinal(A, B: Int64): Int64;
begin
// Keywords are passed as their Int64 index
Result := Ord(A = B);
end;
class function TRtlFunctions.NotEqual_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := Ord(A <> B);
end;
class function TRtlFunctions.NotEqual_Float_Float_Ordinal(A, B: Double): Int64;
begin
Result := Ord(A <> B);
end;
class function TRtlFunctions.NotEqual_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64;
begin
Result := Ord(A <> B);
end;
class function TRtlFunctions.NotEqual_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64;
begin
Result := Ord(A <> B);
end;
class function TRtlFunctions.NotEqual_Keyword_Keyword_Ordinal(A, B: Int64): Int64;
begin
Result := Ord(A <> B);
end;
class function TRtlFunctions.Less_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := Ord(A < B);
end;
class function TRtlFunctions.Less_Float_Float_Ordinal(A, B: Double): Int64;
begin
Result := Ord(A < B);
end;
class function TRtlFunctions.Less_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64;
begin
Result := Ord(A < B);
end;
class function TRtlFunctions.Less_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64;
begin
Result := Ord(A < B);
end;
class function TRtlFunctions.LessOrEqual_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := Ord(A <= B);
end;
class function TRtlFunctions.LessOrEqual_Float_Float_Ordinal(A, B: Double): Int64;
begin
Result := Ord(A <= B);
end;
class function TRtlFunctions.LessOrEqual_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64;
begin
Result := Ord(A <= B);
end;
class function TRtlFunctions.LessOrEqual_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64;
begin
Result := Ord(A <= B);
end;
class function TRtlFunctions.Greater_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := Ord(A > B);
end;
class function TRtlFunctions.Greater_Float_Float_Ordinal(A, B: Double): Int64;
begin
Result := Ord(A > B);
end;
class function TRtlFunctions.Greater_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64;
begin
Result := Ord(A > B);
end;
class function TRtlFunctions.Greater_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64;
begin
Result := Ord(A > B);
end;
class function TRtlFunctions.GreaterOrEqual_Ordinal_Ordinal_Ordinal(A, B: Int64): Int64;
begin
Result := Ord(A >= B);
end;
class function TRtlFunctions.GreaterOrEqual_Float_Float_Ordinal(A, B: Double): Int64;
begin
Result := Ord(A >= B);
end;
class function TRtlFunctions.GreaterOrEqual_Ordinal_Float_Ordinal(A: Int64; B: Double): Int64;
begin
Result := Ord(A >= B);
end;
class function TRtlFunctions.GreaterOrEqual_Float_Ordinal_Ordinal(A: Double; B: Int64): Int64;
begin
Result := Ord(A >= B);
end;
// --- Unary ---
class function TRtlFunctions.Negate_Ordinal_Ordinal(A: Int64): Int64;
begin
Result := -A;
end;
class function TRtlFunctions.Negate_Float_Float(A: Double): Double;
begin
Result := -A;
end;
class function TRtlFunctions.Not_Ordinal_Ordinal(A: Int64): Int64;
begin
// Lisp-style 'not': 0 -> 1, everything else -> 0
Result := Ord(A = 0);
end;
// --- Standard functions ---
class function TRtlFunctions.Abs_Ordinal_Ordinal(A: Int64): Int64;
begin
Result := System.Abs(A);
end;
class function TRtlFunctions.Abs_Float_Float(A: Double): Double;
begin
Result := System.Abs(A);
end;
class function TRtlFunctions.Trunc_Ordinal_Ordinal(A: Int64): Int64;
begin
Result := A; // No-op
end;
class function TRtlFunctions.Trunc_Float_Ordinal(A: Double): Int64;
begin
Result := System.Trunc(A);
end;
end.
+654 -97
View File
@@ -7,19 +7,128 @@ interface
uses
System.SysUtils,
System.Generics.Collections,
System.Generics.Defaults,
System.Rtti,
Myc.Data.Scalar,
Myc.Data.Value,
Myc.Ast,
Myc.Ast.Scope,
Myc.Ast.Nodes;
Myc.Ast.Nodes,
Myc.Ast.Types;
type
// This attribute is used by the RTTI-based registry to identify
// and register native functions in the runtime scope.
TRtlFunctionAttribute = class(TCustomAttribute)
// Defines the export parameters for a native RTL function.
TRtlExportAttribute = class(TCustomAttribute)
public
Name: string;
constructor Create(const AName: string);
IsPure: Boolean;
constructor Create(const AName: string); overload;
constructor Create(const AName: string; AIsPure: Boolean); overload;
end;
// Defines the key for the static bootstrap cache.
type
TStaticSignatureKey = record
public
Name: string;
ArgTypes: TArray<IStaticType>;
constructor Create(const AName: string; const AArgTypes: TArray<IStaticType>);
end;
// Comparer for the static signature key
TStaticSignatureKeyComparer = class(TEqualityComparer<TStaticSignatureKey>)
public
function Equals(const Left, Right: TStaticSignatureKey): Boolean; override;
function GetHashCode(const Value: TStaticSignatureKey): Integer; override;
end;
TSpecializedMethod = record
public
Target: TDataValue.TFunc;
ReturnType: IStaticType;
constructor Create(const ATarget: TDataValue.TFunc; const AReturnType: IStaticType);
end;
// The cache holding TDataValue.TFunc wrappers for static native functions.
// Verwendet den generischen TSpecializedMethod-Record aus Myc.Ast.Types
TStaticBootstrapCache = TDictionary<TStaticSignatureKey, TSpecializedMethod>;
TRtlFunctionInfo = class
public
DynamicWrapper: TDataValue.TFunc;
Signatures: TList<IMethodSignature>;
constructor Create;
destructor Destroy; override;
end;
TRtlFunctionMap = TDictionary<string, TRtlFunctionInfo>;
//--------------------------------------------------------------------------------------------------
//== Library Registration (RTTI-based)
//--------------------------------------------------------------------------------------------------
// A helper record to encapsulate the RTTI-based registration logic.
TRtlRegistry = record
type
// --- Static Wrapper Signatures ---
TNativeFunc_O_O = function(A: Int64): Int64;
TNativeFunc_F_F = function(A: Double): Double;
TNativeFunc_F_O = function(A: Double): Int64;
TNativeFunc_OO_O = function(A, B: Int64): Int64;
TNativeFunc_OO_F = function(A, B: Int64): Double;
TNativeFunc_FF_F = function(A, B: Double): Double;
TNativeFunc_FF_O = function(A, B: Double): Int64;
TNativeFunc_OF_F = function(A: Int64; B: Double): Double;
TNativeFunc_OF_O = function(A: Int64; B: Double): Int64;
TNativeFunc_FO_F = function(A: Double; B: Int64): Double;
TNativeFunc_FO_O = function(A: Double; B: Int64): Int64;
private
class var
FStaticBootstrap: TStaticBootstrapCache;
class var
FStaticFuncMap: TRtlFunctionMap;
class constructor Create;
class destructor Destroy;
// --- Wrapper Creation Helpers ---
class function CreateWrapper_O_O(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_F_F(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_F_O(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_OO_O(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_OO_F(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_FF_F(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_FF_O(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_OF_F(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_OF_O(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_FO_F(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_FO_O(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateStaticWrapper(
method: TRttiMethod;
retType: IStaticType;
argTypes: TArray<IStaticType>;
rttiParams: TArray<TRttiParameter>
): TDataValue.TFunc; static;
// --- RTTI Helpers ---
class function RttiTypeToStaticType(const AType: TRttiType): IStaticType; static;
class function ParseStaticSuffix(
const AMethodName: string;
out AArgTypes: TArray<IStaticType>;
out AReturnType: IStaticType
): Boolean; static;
public
class procedure RegisterAll(const AScope: IExecutionScope); static;
// Public accessor for the TStaticSpecializer
class function GetStaticSpecialization(const AName: string; const AArgTypes: TArray<IStaticType>): TSpecializedMethod; static;
class procedure RegisterStaticSpecialization(
const AName: string;
const AArgTypes: TArray<IStaticType>;
const AMethod: TSpecializedMethod
); static;
end;
procedure RegisterRtlFunctions(const AScope: IExecutionScope);
@@ -27,152 +136,600 @@ procedure RegisterRtlFunctions(const AScope: IExecutionScope);
implementation
uses
System.Rtti,
System.TypInfo,
System.Hash,
System.StrUtils,
Myc.Ast.RTL.Core;
type
TNativeDataValueFunc = function(const Args: TArray<TDataValue>): TDataValue;
TNativeScalarFunc = function(Arg: TScalar): TScalar;
//--------------------------------------------------------------------------------------------------
//== Native Function Implementation (Core Logic)
//--------------------------------------------------------------------------------------------------
constructor TRtlFunctionAttribute.Create(const AName: string);
constructor TRtlExportAttribute.Create(const AName: string);
begin
inherited Create;
Self.Name := AName;
Self.IsPure := False; // Default to impure
end;
//--------------------------------------------------------------------------------------------------
//== Library Registration (RTTI-based)
//--------------------------------------------------------------------------------------------------
constructor TRtlExportAttribute.Create(const AName: string; AIsPure: Boolean);
begin
inherited Create;
Self.Name := AName;
Self.IsPure := AIsPure;
end;
type
// Defines a pointer to the static class function signature for scalar->scalar functions.
TNativeScalarFunc = function(Arg: TScalar): TScalar;
{ TStaticSignatureKey }
// A helper record to encapsulate the RTTI-based registration logic.
TRtlRegistry = record
private
class function GetSingleNumericArg(
const AName: string;
const AArgs: TArray<TDataValue>;
out AArg: TScalar
): Boolean; static; inline;
public
class procedure RegisterAll(const AScope: IExecutionScope); static;
constructor TStaticSignatureKey.Create(const AName: string; const AArgTypes: TArray<IStaticType>);
begin
Name := AName;
ArgTypes := AArgTypes;
end;
{ TStaticSignatureKeyComparer }
function TStaticSignatureKeyComparer.Equals(const Left, Right: TStaticSignatureKey): Boolean;
var
i: Integer;
begin
if Left.Name <> Right.Name then
exit(False);
if Length(Left.ArgTypes) <> Length(Right.ArgTypes) then
exit(False);
// Compare types
for i := 0 to High(Left.ArgTypes) do
begin
if not Left.ArgTypes[i].IsEqual(Right.ArgTypes[i]) then
exit(False);
end;
{ TRtlRegistry }
class function TRtlRegistry.GetSingleNumericArg(const AName: string; const AArgs: TArray<TDataValue>; out AArg: TScalar): Boolean;
begin
// This is the validation logic used by the generated wrappers.
if Length(AArgs) <> 1 then
raise EArgumentException.CreateFmt('%s requires exactly one argument.', [AName]);
if AArgs[0].Kind <> vkScalar then
raise EArgumentException.CreateFmt('%s requires a scalar argument.', [AName]);
AArg := AArgs[0].AsScalar;
// The check for specific numeric kinds is no longer necessary,
// as TScalar can only be Ordinal or Float.
Result := True;
end;
// Main registration method. Uses RTTI to find and register all functions from TRtlFunctions.
class procedure TRtlRegistry.RegisterAll(const AScope: IExecutionScope);
type
TNativeDataValueFunc1 = function(const Args: TArray<TDataValue>): TDataValue;
function TStaticSignatureKeyComparer.GetHashCode(const Value: TStaticSignatureKey): Integer;
var
i: Integer;
hash: Integer;
ptrHash: Integer;
begin
// 1. Hash the function name to get the initial value
hash := THashBobJenkins.GetHashValue(Value.Name);
// 2. Iteratively combine the hash of each argument type
for i := 0 to High(Value.ArgTypes) do
begin
if Assigned(Value.ArgTypes[i]) then
ptrHash := Value.ArgTypes[i].GetHashCode
else
ptrHash := 0;
hash := THashBobJenkins.GetHashValue(ptrHash, SizeOf(Integer), hash);
end;
Result := hash;
end;
{ TRtlFunctionInfo }
constructor TRtlFunctionInfo.Create;
begin
inherited Create;
Signatures := TList<IMethodSignature>.Create;
DynamicWrapper := nil;
end;
destructor TRtlFunctionInfo.Destroy;
begin
Signatures.Free;
inherited Destroy;
end;
{ TRtlRegistry }
class constructor TRtlRegistry.Create;
var
ctx: TRttiContext;
rtlType: TRttiType;
method: TRttiMethod;
attribute: TCustomAttribute;
rtlAttribute: TRtlFunctionAttribute;
param: TRttiParameter;
wrapper: TDataValue.TFunc;
exportAttr: TRtlExportAttribute;
rtlName: string;
argTypes: TArray<IStaticType>;
retType: IStaticType;
methodRecord: TSpecializedMethod;
funcInfo: TRtlFunctionInfo;
rttiParams: TArray<TRttiParameter>;
isDynamic: Boolean;
i: Integer;
begin
// 1. Create global caches
FStaticBootstrap := TStaticBootstrapCache.Create(TStaticSignatureKeyComparer.Create);
FStaticFuncMap := TRtlFunctionMap.Create;
// 2. Perform RTTI Scan (formerly Pass 1 of RegisterAll)
ctx := TRttiContext.Create;
try
rtlType := ctx.GetType(TypeInfo(TRtlFunctions));
for method in rtlType.GetMethods do
begin
// Find functions marked with our custom attribute
if method.MethodKind <> mkClassFunction then
continue;
exportAttr := nil;
for attribute in method.GetAttributes do
begin
if not (attribute is TRtlFunctionAttribute) then
continue;
if method.MethodKind <> mkClassFunction then
continue;
rtlAttribute := attribute as TRtlFunctionAttribute;
wrapper := nil;
// --- Signature Dispatcher ---
// Decide which wrapper to generate based on the method signature.
if (Length(method.GetParameters) = 1) and (method.ReturnType.Handle = TypeInfo(TScalar)) then
if attribute is TRtlExportAttribute then
begin
param := method.GetParameters[0];
if param.ParamType.Handle = TypeInfo(TScalar) then
begin
// Signature matches: class function(Arg: TScalar): TScalar;
// Build a factory that captures the method's name and CodeAddress.
var wrapperFactory :=
function(AName: string; CodeAddress: Pointer): TDataValue.TFunc
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
argScalar: TScalar;
begin
GetSingleNumericArg(AName, Args, argScalar);
Result := TDataValue(TNativeScalarFunc(CodeAddress)(argScalar));
end;
end;
exportAttr := attribute as TRtlExportAttribute;
break;
end;
end;
wrapper := wrapperFactory(rtlAttribute.Name, method.CodeAddress);
if not Assigned(exportAttr) then
continue;
rtlName := exportAttr.Name;
if not FStaticFuncMap.TryGetValue(rtlName, funcInfo) then
begin
funcInfo := TRtlFunctionInfo.Create;
FStaticFuncMap.Add(rtlName, funcInfo);
end;
// Check Signature Type (Dynamic vs Static)
rttiParams := method.GetParameters;
isDynamic :=
(Length(rttiParams) = 1)
and (method.ReturnType.Handle = TypeInfo(TDataValue))
and (rttiParams[0].ParamType.Handle = TypeInfo(TArray<TDataValue>));
if isDynamic then
begin
if Assigned(funcInfo.DynamicWrapper) and Assigned(funcInfo.DynamicWrapper) then
raise EInvalidOpException.CreateFmt('Duplicate dynamic fallback defined for %s', [rtlName]);
var wrapperFactory :=
function(CodeAddress: Pointer): TDataValue.TFunc
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
begin
Result := TNativeDataValueFunc(CodeAddress)(Args);
end;
end;
end
else if (Length(method.GetParameters) = 1) and (method.ReturnType.Handle = TypeInfo(TDataValue)) then
funcInfo.DynamicWrapper := wrapperFactory(method.CodeAddress);
end
else
begin
// This is a STATIC SPECIALIZATION
if not ParseStaticSuffix(method.Name, argTypes, retType) then
begin
param := method.GetParameters[0];
if (pfConst in param.Flags) and (param.ParamType.Handle = TypeInfo(TArray<TDataValue>)) then
begin
// Signature matches: class function(const Args: TArray<TDataValue>): TDataValue;
// Build a factory that captures the method's CodeAddress.
var wrapperFactory :=
function(CodeAddress: Pointer): TDataValue.TFunc
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
begin
Result := TNativeDataValueFunc1(CodeAddress)(Args);
end;
end;
// Create the wrapper
wrapper := wrapperFactory(method.CodeAddress);
end;
SetLength(argTypes, Length(rttiParams));
for i := 0 to High(rttiParams) do
argTypes[i] := RttiTypeToStaticType(rttiParams[i].ParamType);
retType := RttiTypeToStaticType(method.ReturnType);
end;
var sig := TMethodSignature.Create(argTypes, retType);
funcInfo.Signatures.Add(sig);
var wrapper := CreateStaticWrapper(method, retType, argTypes, rttiParams);
if Assigned(wrapper) then
begin
AScope.Define(rtlAttribute.Name, TDataValue(wrapper));
break; // Found our attribute, proceed to next method
methodRecord := TSpecializedMethod.Create(wrapper, retType);
// Use renamed static helper
RegisterStaticSpecialization(rtlName, argTypes, methodRecord);
end
else
raise ENotImplemented.CreateFmt('Native method wrapper for %s() not implemented', [method.Name]);
raise ENotImplemented.CreateFmt('Static native method wrapper for %s() not implemented', [method.Name]);
end;
end;
finally
ctx.Free;
end;
end;
class destructor TRtlRegistry.Destroy;
var
funcInfo: TRtlFunctionInfo;
begin
for funcInfo in FStaticFuncMap.Values do
funcInfo.Free;
FStaticFuncMap.Free;
FStaticBootstrap.Free;
end;
class function TRtlRegistry.GetStaticSpecialization(const AName: string; const AArgTypes: TArray<IStaticType>): TSpecializedMethod;
var
key: TStaticSignatureKey;
begin
key.Name := AName;
key.ArgTypes := AArgTypes;
FStaticBootstrap.TryGetValue(key, Result);
end;
class procedure TRtlRegistry.RegisterStaticSpecialization(
const AName: string;
const AArgTypes: TArray<IStaticType>;
const AMethod: TSpecializedMethod
);
var
key: TStaticSignatureKey;
begin
key := TStaticSignatureKey.Create(AName, AArgTypes);
// This allows multiple RTTI scans (e.g. in tests) without crashing,
// though only the class constructor should call this now.
FStaticBootstrap.AddOrSetValue(key, AMethod);
end;
class function TRtlRegistry.RttiTypeToStaticType(const AType: TRttiType): IStaticType;
begin
if not Assigned(AType) then
exit(TTypes.Unknown);
if AType.Handle = TypeInfo(Int64) then
Result := TTypes.Ordinal
else if AType.Handle = TypeInfo(Double) then
Result := TTypes.Float
else if AType.Handle = TypeInfo(string) then
Result := TTypes.Text
else if (AType.Handle = TypeInfo(TScalar)) or (AType.Handle = TypeInfo(TDataValue)) then
Result := TTypes.Unknown
else
Result := TTypes.Unknown;
end;
class function TRtlRegistry.ParseStaticSuffix(
const AMethodName: string;
out AArgTypes: TArray<IStaticType>;
out AReturnType: IStaticType
): Boolean;
var
parts: TArray<string>;
i: Integer;
t: IStaticType;
function ParseType(const S: string): IStaticType;
begin
if SameText(S, 'Ordinal') then
Result := TTypes.Ordinal
else if SameText(S, 'Float') then
Result := TTypes.Float
else if SameText(S, 'Keyword') then
Result := TTypes.Keyword
else
Result := TTypes.Unknown;
end;
begin
Result := False;
AReturnType := TTypes.Unknown;
AArgTypes := nil;
parts := AMethodName.Split(['_']);
if Length(parts) < 2 then
exit;
AReturnType := ParseType(parts[High(parts)]);
if AReturnType.Kind = stUnknown then
exit;
SetLength(AArgTypes, Length(parts) - 2);
if Length(AArgTypes) = 0 then
begin
Result := True;
exit;
end;
for i := 1 to High(parts) - 1 do
begin
t := ParseType(parts[i]);
if t.Kind = stUnknown then
begin
AArgTypes := nil;
AReturnType := TTypes.Unknown;
exit(False);
end;
AArgTypes[i - 1] := t;
end;
Result := True;
end;
class procedure TRtlRegistry.RegisterAll(const AScope: IExecutionScope);
var
rtlName: string;
funcInfo: TRtlFunctionInfo;
staticType: IStaticType;
pair: TPair<string, TRtlFunctionInfo>;
begin
for pair in FStaticFuncMap do
begin
rtlName := pair.Key;
funcInfo := pair.Value;
if funcInfo.Signatures.Count > 0 then
staticType := TTypes.CreateMethodSet(funcInfo.Signatures.ToArray)
else
staticType := nil;
var wrapper := funcInfo.DynamicWrapper; // Default is Void
AScope.Define(rtlName, wrapper, staticType);
end;
end;
// --- Wrapper Generation ---
class function TRtlRegistry.CreateWrapper_O_O(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A: Int64;
Res: Int64;
begin
A := Args[0].AsScalar.Value.AsInt64;
Res := TNativeFunc_O_O(CodeAddress)(A);
Result := TDataValue(TScalar.FromInt64(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_F_F(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A: Double;
Res: Double;
begin
A := Args[0].AsScalar.Value.AsDouble;
Res := TNativeFunc_F_F(CodeAddress)(A);
Result := TDataValue(TScalar.FromDouble(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_F_O(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A: Double;
Res: Int64;
begin
A := Args[0].AsScalar.Value.AsDouble;
Res := TNativeFunc_F_O(CodeAddress)(A);
Result := TDataValue(TScalar.FromInt64(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_OO_O(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A, B, Res: Int64;
begin
A := Args[0].AsScalar.Value.AsInt64;
B := Args[1].AsScalar.Value.AsInt64;
Res := TNativeFunc_OO_O(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromInt64(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_OO_F(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A, B: Int64;
Res: Double;
begin
A := Args[0].AsScalar.Value.AsInt64;
B := Args[1].AsScalar.Value.AsInt64;
Res := TNativeFunc_OO_F(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromDouble(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_FF_F(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A, B, Res: Double;
begin
A := Args[0].AsScalar.Value.AsDouble;
B := Args[1].AsScalar.Value.AsDouble;
Res := TNativeFunc_FF_F(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromDouble(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_FF_O(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A, B: Double;
Res: Int64;
begin
A := Args[0].AsScalar.Value.AsDouble;
B := Args[1].AsScalar.Value.AsDouble;
Res := TNativeFunc_FF_O(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromInt64(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_OF_F(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A: Int64;
B: Double;
Res: Double;
begin
A := Args[0].AsScalar.Value.AsInt64;
B := Args[1].AsScalar.Value.AsDouble;
Res := TNativeFunc_OF_F(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromDouble(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_OF_O(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A: Int64;
B: Double;
Res: Int64;
begin
A := Args[0].AsScalar.Value.AsInt64;
B := Args[1].AsScalar.Value.AsDouble;
Res := TNativeFunc_OF_O(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromInt64(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_FO_F(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A: Double;
B: Int64;
Res: Double;
begin
A := Args[0].AsScalar.Value.AsDouble;
B := Args[1].AsScalar.Value.AsInt64;
Res := TNativeFunc_FO_F(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromDouble(Res));
end;
end;
class function TRtlRegistry.CreateWrapper_FO_O(CodeAddress: Pointer): TDataValue.TFunc;
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
A: Double;
B: Int64;
Res: Int64;
begin
A := Args[0].AsScalar.Value.AsDouble;
B := Args[1].AsScalar.Value.AsInt64;
Res := TNativeFunc_FO_O(CodeAddress)(A, B);
Result := TDataValue(TScalar.FromInt64(Res));
end;
end;
class function TRtlRegistry.CreateStaticWrapper(
method: TRttiMethod;
retType: IStaticType;
argTypes: TArray<IStaticType>;
rttiParams: TArray<TRttiParameter>
): TDataValue.TFunc;
var
ptr: Pointer;
begin
Result := nil;
ptr := method.CodeAddress;
// --- 1-Argument Functions ---
if Length(argTypes) = 1 then
begin
if (argTypes[0].Kind = stOrdinal) and (retType.Kind = stOrdinal) then
Result := CreateWrapper_O_O(ptr)
else if (argTypes[0].Kind = stFloat) and (retType.Kind = stFloat) then
Result := CreateWrapper_F_F(ptr)
else if (argTypes[0].Kind = stFloat) and (retType.Kind = stOrdinal) then
Result := CreateWrapper_F_O(ptr)
else if (argTypes[0].Kind = stUnknown) and (rttiParams[0].ParamType.Handle = TypeInfo(TScalar)) then
begin
// This is the wrapper for: class function(Arg: TScalar): TScalar;
var wrapperFactory :=
function(CodeAddress: Pointer): TDataValue.TFunc
begin
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
argScalar: TScalar;
begin
if (Length(Args) <> 1) or (Args[0].Kind <> vkScalar) then
raise EArgumentException.Create('Invalid argument for TScalar function.');
argScalar := Args[0].AsScalar;
Result := TDataValue(TNativeScalarFunc(CodeAddress)(argScalar));
end;
end;
Result := wrapperFactory(ptr);
end;
end
// --- 2-Argument Functions ---
else if Length(argTypes) = 2 then
begin
var k1 := argTypes[0].Kind;
var k2 := argTypes[1].Kind;
var rk := retType.Kind;
if (k1 = stOrdinal) and (k2 = stOrdinal) then
begin
if rk = stOrdinal then
Result := CreateWrapper_OO_O(ptr)
else if rk = stFloat then
Result := CreateWrapper_OO_F(ptr); // Divide
end
else if (k1 = stFloat) and (k2 = stFloat) then
begin
if rk = stFloat then
Result := CreateWrapper_FF_F(ptr)
else if rk = stOrdinal then
Result := CreateWrapper_FF_O(ptr); // Comparisons
end
else if (k1 = stOrdinal) and (k2 = stFloat) then
begin
if rk = stFloat then
Result := CreateWrapper_OF_F(ptr)
else if rk = stOrdinal then
Result := CreateWrapper_OF_O(ptr); // Comparisons
end
else if (k1 = stFloat) and (k2 = stOrdinal) then
begin
if rk = stFloat then
Result := CreateWrapper_FO_F(ptr)
else if rk = stOrdinal then
Result := CreateWrapper_FO_O(ptr); // Comparisons
end
else if (k1 = stKeyword) and (k2 = stKeyword) and (rk = stOrdinal) then
begin
// Keywords are passed as Int64 (index)
Result := CreateWrapper_OO_O(ptr); // e.g. Equal_Keyword_Keyword
end;
end;
end;
procedure RegisterRtlFunctions(const AScope: IExecutionScope);
begin
TRtlRegistry.RegisterAll(AScope);
end;
constructor TSpecializedMethod.Create(const ATarget: TDataValue.TFunc; const AReturnType: IStaticType);
begin
Target := ATarget;
ReturnType := AReturnType;
end;
initialization
// Register this library's functions with the central AST factory.
TAst.RegisterLibrary(RegisterRtlFunctions);
+92 -32
View File
@@ -5,6 +5,7 @@ interface
uses
System.SysUtils,
System.Generics.Collections,
System.Generics.Defaults,
System.Classes,
Myc.Data.Value,
Myc.Ast.Types;
@@ -26,6 +27,12 @@ type
class operator Equal(const A: TResolvedAddress; B: TResolvedAddress): Boolean;
end;
TResolvedAddressComparer = class(TEqualityComparer<TResolvedAddress>)
public
function Equals(const Left, Right: TResolvedAddress): Boolean; override;
function GetHashCode(const Value: TResolvedAddress): Integer; override;
end;
// A resolved symbol, containing its runtime address and static type.
TResolvedSymbol = record
Address: TResolvedAddress;
@@ -50,7 +57,7 @@ type
{$endregion}
// Defines a symbol and returns its runtime address
function Define(const Name: string; const Value: TDataValue): TResolvedAddress;
function Define(const Name: string; const Value: TDataValue; const AStaticType: IStaticType = nil): TResolvedAddress;
// Defines a variable at a given address and stores it directly in a shared cell (boxing).
procedure DefineBoxed(SlotIndex: Integer; const Value: TDataValue);
@@ -104,7 +111,7 @@ type
implementation
uses
System.Generics.Defaults,
System.Hash,
System.SyncObjs;
type
@@ -128,8 +135,8 @@ type
private
FParent: IExecutionScope;
FDescriptor: IScopeDescriptor;
FValues: TArray<TScopeItem>;
FDescriptor: IScopeDescriptor; // (* Will store static types *)
FValues: TArray<TScopeItem>; // (* Runtime values *)
FCapturedUpvalues: TArray<IValueCell>;
FNames: TDictionary<string, Integer>;
FNameStrings: TList<string>;
@@ -148,7 +155,7 @@ type
function GetNameID(const Name: String): Integer;
function Resolve(const Name: string): TResolvedAddress;
function Dump: string;
function Define(const Name: string; const Value: TDataValue): TResolvedAddress;
function Define(const Name: string; const Value: TDataValue; const AStaticType: IStaticType = nil): TResolvedAddress;
procedure DefineBoxed(SlotIndex: Integer; const Value: TDataValue);
function Capture(const Address: TResolvedAddress): IValueCell;
function CreateDescriptor: IScopeDescriptor;
@@ -163,7 +170,6 @@ type
private
FParent: IScopeDescriptor;
FSymbols: TDictionary<string, Integer>;
// FMacros: TDictionary<string, IMacroDefinitionNode>; // Entfernt
FSlotTypes: TArray<IStaticType>; // Stores types by SlotIndex
function GetParent: IScopeDescriptor;
function GetSlotCount: Integer;
@@ -175,14 +181,30 @@ type
class function CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor; static;
function Define(const Name: string; const AType: IStaticType): Integer;
procedure UpdateType(SlotIndex: Integer; const AType: IStaticType = nil);
// procedure DefineMacro(const Name: string; const Node: IMacroDefinitionNode); // Entfernt
function FindSymbol(const Name: string): TResolvedSymbol;
// function FindMacro(const Name: string): IMacroDefinitionNode; // Entfernt
function CreateScope(const Parent: IExecutionScope): IExecutionScope;
procedure PopulateFromScope(Scope: TExecutionScope);
property Symbols: TDictionary<string, Integer> read FSymbols;
end;
{ TResolvedAddressComparer }
function TResolvedAddressComparer.Equals(const Left, Right: TResolvedAddress): Boolean;
begin
Result := (Left = Right); // Use the record's operator
end;
function TResolvedAddressComparer.GetHashCode(const Value: TResolvedAddress): Integer;
var
adr: TResolvedAddress;
begin
adr := Value;
// Use THashBobJenkins as requested
Result := THashBobJenkins.GetHashValue(adr.Kind, SizeOf(TAddressKind), 0);
Result := THashBobJenkins.GetHashValue(adr.ScopeDepth, SizeOf(Integer), Result);
Result := THashBobJenkins.GetHashValue(adr.SlotIndex, SizeOf(Integer), Result);
end;
{ TResolvedAddress }
constructor TResolvedAddress.Create(AKind: TAddressKind; AScopeDepth, ASlotIndex: Integer);
@@ -246,7 +268,14 @@ constructor TExecutionScope.Create(
begin
inherited Create;
FParent := AParent;
FDescriptor := ADescriptor;
// Ensure FDescriptor is always assigned
if Assigned(ADescriptor) then
FDescriptor := ADescriptor
else if Assigned(AParent) then
FDescriptor := AParent.CreateDescriptor // Inherit descriptor if nil
else
FDescriptor := TScope.CreateDescriptor(nil); // Create new root descriptor
FValues := [];
FCapturedUpvalues := ACapturedUpvalues;
@@ -262,7 +291,8 @@ begin
FNameStrings := TList<string>.Create;
end;
if ADescriptor <> nil then
// Pre-allocate the runtime value array based on the compile-time descriptor's size.
if Assigned(ADescriptor) then
SetLength(FValues, ADescriptor.SlotCount);
end;
@@ -337,25 +367,45 @@ end;
function TExecutionScope.CreateDescriptor: IScopeDescriptor;
begin
// We create a *copy* to prevent modification of the live descriptor
// TScopeDescriptor.CreateDescriptor(Self) will do this.
Result := TScopeDescriptor.CreateDescriptor(Self);
end;
function TExecutionScope.Define(const Name: string; const Value: TDataValue): TResolvedAddress;
// (* MODIFIED: Signature changed, logic added *)
function TExecutionScope.Define(const Name: string; const Value: TDataValue; const AStaticType: IStaticType = nil): TResolvedAddress;
var
id: Integer;
index: Integer;
staticType: IStaticType;
begin
NeedNameToIndex;
id := GetNameID(Name);
if FNameToIndex.ContainsKey(id) then
raise Exception.CreateFmt('Variable "%s" is already defined in this scope.', [Name]);
// 1. Determine the static type
if Assigned(AStaticType) then
staticType := AStaticType
else
staticType := TTypes.Unknown; // Default if not provided
// 2. Define in the runtime storage (FValues)
index := Length(FValues);
SetLength(FValues, index + 1);
FValues[index].Value := Value;
FValues[index].IsBoxed := False;
FNameToIndex.Add(id, index);
// 3. Define in the compile-time descriptor (FDescriptor)
// This stores the static type information for the Binder/TypeChecker.
// Note: This relies on FDescriptor being non-nil (ensured in constructor)
var descSlot := FDescriptor.Define(Name, staticType);
// 4. Ensure runtime slot matches descriptor slot
// This is critical for root scope initialization.
Assert(descSlot = index, 'Scope descriptor slot mismatch during Define');
// Return the address
Result.Kind := akLocalOrParent;
Result.ScopeDepth := 0;
@@ -573,28 +623,36 @@ begin
inherited Create;
FParent := AParent;
FSymbols := TDictionary<string, Integer>.Create;
// FMacros := TDictionary<string, IMacroDefinitionNode>.Create; // Entfernt
FSlotTypes := [];
end;
destructor TScopeDescriptor.Destroy;
begin
FSlotTypes := nil;
// FMacros.Free; // Entfernt
FSymbols.Free;
inherited;
end;
class function TScopeDescriptor.CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor;
begin
if Scope is TExecutionScope then
// Create a *copy* of the descriptor chain
if (Scope is TExecutionScope) and (Assigned(Scope.Parent)) then
begin
// Recursively create parent descriptors
var res := TScopeDescriptor.Create(CreateDescriptor(Scope.Parent));
// Populate this descriptor level
res.PopulateFromScope(Scope as TExecutionScope);
Result := res;
end
else if (Scope is TExecutionScope) then
begin
// This is the root scope
var res := TScopeDescriptor.Create(nil);
res.PopulateFromScope(Scope as TExecutionScope);
Result := res;
end
else
Result := TScopeDescriptor.Create(nil);
Result := TScopeDescriptor.Create(nil); // Default empty descriptor
end;
function TScopeDescriptor.CreateScope(const Parent: IExecutionScope): IExecutionScope;
@@ -626,9 +684,11 @@ var
currentDescriptor: IScopeDescriptor;
slotIndex: Integer;
begin
// (* MODIFIED: Initialize StaticType *)
Result.StaticType := TTypes.Unknown;
Result.Address.Kind := akUnresolved;
Result.Address.ScopeDepth := 0;
Result.StaticType := TTypes.Unknown;
currentDescriptor := Self;
while Assigned(currentDescriptor) do
begin
@@ -636,12 +696,13 @@ begin
begin
Result.Address.Kind := akLocalOrParent;
Result.Address.SlotIndex := slotIndex;
Result.StaticType := currentDescriptor.GetType(slotIndex);
Result.StaticType := currentDescriptor.GetType(slotIndex); // (* Read type *)
exit;
end;
inc(Result.Address.ScopeDepth);
currentDescriptor := currentDescriptor.Parent;
end;
// (* If not found, Result.StaticType remains TTypes.Unknown *)
end;
function TScopeDescriptor.GetParent: IScopeDescriptor;
@@ -670,24 +731,23 @@ procedure TScopeDescriptor.PopulateFromScope(Scope: TExecutionScope);
var
i: Integer;
begin
// Recreate descriptor by iterating all defined symbols in the runtime scope.
SetLength(FSlotTypes, Length(Scope.ValuesArray)); // Size the array
for i := 0 to High(FSlotTypes) do
FSlotTypes[i] := TTypes.Unknown; // Fill with Unknown
// (* MODIFIED: We are populating 'Self' from 'Scope's *internal* descriptor *)
// We must cast to access the descriptor implementation
if not (Scope.FDescriptor is TScopeDescriptor) then
exit; // Cannot populate from an unknown descriptor type
for var pair in Scope.NameToIndex do
var scopeDesc := (Scope.FDescriptor as TScopeDescriptor);
// Recreate descriptor by copying all defined symbols and types.
SetLength(Self.FSlotTypes, Length(scopeDesc.FSlotTypes));
for i := 0 to High(Self.FSlotTypes) do
Self.FSlotTypes[i] := scopeDesc.FSlotTypes[i]; // Copy static type
for var pair in scopeDesc.FSymbols do
begin
var name := Scope.NameStrings[pair.Key];
var slotIndex := pair.Value;
// Add to variable symbol table.
if not FSymbols.ContainsKey(name) then
FSymbols.Add(name, slotIndex);
// We cannot recover the static type from the runtime scope.
// FSlotTypes[slotIndex] remains TTypes.Unknown.
// Makro-Logik hier entfernt
if not Self.FSymbols.ContainsKey(pair.Key) then
Self.FSymbols.Add(pair.Key, pair.Value);
end;
end;
-20
View File
@@ -201,8 +201,6 @@ type
procedure VisitConstant(const Node: IConstantNode); override;
procedure VisitIdentifier(const Node: IIdentifierNode); override;
procedure VisitKeyword(const Node: IKeywordNode); override;
procedure VisitBinaryExpression(const Node: IBinaryExpressionNode); override;
procedure VisitUnaryExpression(const Node: IUnaryExpressionNode); override;
procedure VisitIfExpression(const Node: IIfExpressionNode); override;
procedure VisitTernaryExpression(const Node: ITernaryExpressionNode); override;
procedure VisitLambdaExpression(const Node: ILambdaExpressionNode); override;
@@ -823,24 +821,6 @@ begin
Append(':' + Node.Value.Name);
end;
procedure TPrettyPrintVisitor.VisitBinaryExpression(const Node: IBinaryExpressionNode);
begin
Append('(' + Node.Operator.ToString);
Append(' ');
Node.Left.Accept(Self);
Append(' ');
Node.Right.Accept(Self);
Append(')');
end;
procedure TPrettyPrintVisitor.VisitUnaryExpression(const Node: IUnaryExpressionNode);
begin
Append('(' + Node.Operator.ToString);
Append(' ');
Node.Right.Accept(Self);
Append(')');
end;
procedure TPrettyPrintVisitor.VisitIfExpression(const Node: IIfExpressionNode);
begin
Append('(if ');
+225 -54
View File
@@ -39,6 +39,7 @@ type
{$endregion}
property ParamTypes: TArray<IStaticType> read GetParamTypes;
property ReturnType: IStaticType read GetReturnType;
function GetHashCode: Integer;
end;
// Defines a mapping for generic record fields (Key -> StaticType)
@@ -50,7 +51,8 @@ type
{$region 'private'}
function GetKind: TStaticTypeKind;
function GetElementType: IStaticType;
function GetSignature: IMethodSignature;
// function GetSignature: IMethodSignature; // (* REMOVED *)
function GetSignatures: TArray<IMethodSignature>; // (* ADDED *)
function GetDefinition: IScalarRecordDefinition;
function GetGenericDefinition: IGenericRecordDefinition;
{$endregion}
@@ -59,8 +61,12 @@ type
property Kind: TStaticTypeKind read GetKind;
// The element type (if Kind = stSeries)
property ElementType: IStaticType read GetElementType;
// The signature (if Kind = stMethod)
property Signature: IMethodSignature read GetSignature;
// The signatures (if Kind = stMethod).
// This array contains one entry for simple methods,
// and multiple entries for overloaded functions (like RTL).
property Signatures: TArray<IMethodSignature> read GetSignatures;
// The definition (if Kind = stRecord or stRecordSeries)
property Definition: IScalarRecordDefinition read GetDefinition;
// The definition (if Kind = stGenericRecord)
@@ -69,6 +75,7 @@ type
// Checks for type equality
function IsEqual(const Other: IStaticType): Boolean;
function ToString: string;
function GetHashCode: Integer;
end;
ETypeException = class(Exception);
@@ -102,6 +109,7 @@ type
// Factory functions for complex types
class function CreateSeries(const AElementType: IStaticType): IStaticType; static;
class function CreateMethod(const AParamTypes: TArray<IStaticType>; const AReturnType: IStaticType): IStaticType; static;
class function CreateMethodSet(const ASignatures: TArray<IMethodSignature>): IStaticType; static;
class function CreateRecord(const ADef: IScalarRecordDefinition): IStaticType; static;
class function CreateRecordSeries(const ADef: IScalarRecordDefinition): IStaticType; static;
class function CreateGenericRecord(const ADef: IGenericRecordDefinition): IStaticType; static;
@@ -123,10 +131,22 @@ type
class function ResolveUnaryOp(Op: TScalar.TUnaryOp; const Right: IStaticType): IStaticType; static;
end;
TMethodSignature = class(TInterfacedObject, IMethodSignature)
private
FParamTypes: TArray<IStaticType>;
FReturnType: IStaticType;
function GetParamTypes: TArray<IStaticType>;
function GetReturnType: IStaticType;
public
constructor Create(const AParamTypes: TArray<IStaticType>; const AReturnType: IStaticType);
function GetHashCode: Integer; override;
end;
implementation
uses
System.Generics.Defaults;
System.Generics.Defaults,
System.Hash; // Added for TStringBuilder in TMethodType.ToString
{ TStaticTypeKindHelper }
@@ -157,10 +177,11 @@ type
// IStaticType (default implementations for non-applicable properties)
function GetKind: TStaticTypeKind; virtual; abstract;
function GetElementType: IStaticType; virtual;
function GetSignature: IMethodSignature; virtual;
function GetSignatures: TArray<IMethodSignature>; virtual; // (* CHANGED *)
function GetDefinition: IScalarRecordDefinition; virtual;
function GetGenericDefinition: IGenericRecordDefinition; virtual;
function IsEqual(const Other: IStaticType): Boolean; virtual;
function GetHashCode: Integer; override; abstract;
function ToString: string; override;
end;
@@ -169,9 +190,9 @@ begin
Result := nil;
end;
function TAbstractStaticType.GetSignature: IMethodSignature;
function TAbstractStaticType.GetSignatures: TArray<IMethodSignature>; // (* CHANGED *)
begin
Result := nil;
Result := nil; // (* CHANGED *)
end;
function TAbstractStaticType.GetDefinition: IScalarRecordDefinition;
@@ -208,6 +229,7 @@ type
public
constructor Create(AKind: TStaticTypeKind);
function GetKind: TStaticTypeKind; override;
function GetHashCode: Integer; override;
end;
constructor TSimpleStaticType.Create(AKind: TStaticTypeKind);
@@ -221,6 +243,12 @@ begin
Result := FKind;
end;
function TSimpleStaticType.GetHashCode: Integer;
begin
// Simple types only hash their kind
Result := Ord(FKind);
end;
// --- Complex Type Implementations ---
type
@@ -232,6 +260,7 @@ type
function GetKind: TStaticTypeKind; override;
function GetElementType: IStaticType; override;
function IsEqual(const Other: IStaticType): Boolean; override;
function GetHashCode: Integer; override;
function ToString: string; override;
end;
@@ -256,22 +285,24 @@ begin
Result := (Assigned(Other)) and (Other.Kind = stSeries) and (Self.FElementType.IsEqual(Other.ElementType));
end;
function TSeriesType.GetHashCode: Integer;
begin
// Consistent with IsEqual
Result := Ord(stSeries);
if Assigned(FElementType) then
begin
// Combine hash of stSeries with hash of element type
var hash := FElementType.GetHashCode;
Result := THashBobJenkins.GetHashValue(Hash, SizeOf(Integer), Result);
end;
end;
function TSeriesType.ToString: string;
begin
Result := 'Series<' + FElementType.ToString + '>';
end;
// ---
type
TMethodSignature = class(TInterfacedObject, IMethodSignature)
private
FParamTypes: TArray<IStaticType>;
FReturnType: IStaticType;
function GetParamTypes: TArray<IStaticType>;
function GetReturnType: IStaticType;
public
constructor Create(const AParamTypes: TArray<IStaticType>; const AReturnType: IStaticType);
end;
{ TMethodSignature }
constructor TMethodSignature.Create(const AParamTypes: TArray<IStaticType>; const AReturnType: IStaticType);
begin
@@ -290,23 +321,46 @@ begin
Result := FReturnType;
end;
function TMethodSignature.GetHashCode: Integer;
var
i: Integer;
begin
// Consistent with TMethodType.IsEqual
Result := 0;
if Assigned(FReturnType) then
Result := FReturnType.GetHashCode;
for i := 0 to High(FParamTypes) do
begin
if Assigned(FParamTypes[i]) then
begin
var hash := FParamTypes[i].GetHashCode;
Result := THashBobJenkins.GetHashValue(hash, SizeOf(Integer), Result);
end;
end;
end;
// ---
type
// (* ENTIRE TMethodType IMPLEMENTATION REPLACED *)
TMethodType = class(TAbstractStaticType)
private
FSignature: IMethodSignature;
FSignatures: TArray<IMethodSignature>;
function SignatureToString(const Sig: IMethodSignature): string;
public
constructor Create(AParamTypes: TArray<IStaticType>; AReturnType: IStaticType);
constructor Create(const ASignatures: TArray<IMethodSignature>);
function GetKind: TStaticTypeKind; override;
function GetSignature: IMethodSignature; override;
function GetSignatures: TArray<IMethodSignature>; override;
function IsEqual(const Other: IStaticType): Boolean; override;
function GetHashCode: Integer; override;
function ToString: string; override;
end;
constructor TMethodType.Create(AParamTypes: TArray<IStaticType>; AReturnType: IStaticType);
constructor TMethodType.Create(const ASignatures: TArray<IMethodSignature>);
begin
inherited Create;
FSignature := TMethodSignature.Create(AParamTypes, AReturnType);
Assert(Length(ASignatures) > 0, 'Cannot create a method type with zero signatures');
FSignatures := ASignatures;
end;
function TMethodType.GetKind: TStaticTypeKind;
@@ -314,47 +368,106 @@ begin
Result := stMethod;
end;
function TMethodType.GetSignature: IMethodSignature;
function TMethodType.GetSignatures: TArray<IMethodSignature>;
begin
Result := FSignature;
Result := FSignatures;
end;
function TMethodType.IsEqual(const Other: IStaticType): Boolean;
var
i: Integer;
begin
if (not Assigned(Other)) or (Other.Kind <> stMethod) then
exit(False);
var otherSig := Other.Signature;
if not Self.FSignature.ReturnType.IsEqual(otherSig.ReturnType) then
exit(False);
if Length(Self.FSignature.ParamTypes) <> Length(otherSig.ParamTypes) then
exit(False);
for i := 0 to High(Self.FSignature.ParamTypes) do
begin
if not Self.FSignature.ParamTypes[i].IsEqual(otherSig.ParamTypes[i]) then
exit(False);
end;
Result := True;
end;
function TMethodType.ToString: string;
function TMethodType.SignatureToString(const Sig: IMethodSignature): string;
var
i: Integer;
paramStr: string;
begin
paramStr := '';
for i := 0 to High(FSignature.ParamTypes) do
for i := 0 to High(Sig.ParamTypes) do
begin
paramStr := paramStr + FSignature.ParamTypes[i].ToString;
if i < High(FSignature.ParamTypes) then
paramStr := paramStr + Sig.ParamTypes[i].ToString;
if i < High(Sig.ParamTypes) then
paramStr := paramStr + ', ';
end;
Result := Format('Method(%s): %s', [paramStr, FSignature.ReturnType.ToString]);
Result := Format('Method(%s): %s', [paramStr, Sig.ReturnType.ToString]);
end;
function TMethodType.IsEqual(const Other: IStaticType): Boolean;
var
i, j: Integer;
begin
if (not Assigned(Other)) or (Other.Kind <> stMethod) then
exit(False);
var otherSigs := Other.Signatures;
if Length(Self.FSignatures) <> Length(otherSigs) then
exit(False);
// This is complex. For now, assume equality means identical sets,
// which requires comparing O(N^2) signatures if order doesn't matter.
// Let's assume order *does* matter for equality to keep this simple (O(N)).
// Note: A better IsEqual would compare hashes of signatures.
for i := 0 to High(Self.FSignatures) do
begin
var sig1 := Self.FSignatures[i];
var sig2 := otherSigs[i];
if not sig1.ReturnType.IsEqual(sig2.ReturnType) then
exit(False);
if Length(sig1.ParamTypes) <> Length(sig2.ParamTypes) then
exit(False);
for j := 0 to High(sig1.ParamTypes) do
begin
if not sig1.ParamTypes[j].IsEqual(sig2.ParamTypes[j]) then
exit(False);
end;
end;
Result := True;
end;
function TMethodType.GetHashCode: Integer;
var
sig: IMethodSignature;
begin
// Consistent with IsEqual
Result := Ord(stMethod);
for sig in FSignatures do
begin
if Assigned(sig) then
begin
var hash := sig.GetHashCode;
Result := THashBobJenkins.GetHashValue(hash, SizeOf(Integer), Result);
end;
end;
end;
function TMethodType.ToString: string;
var
sb: TStringBuilder;
sig: IMethodSignature;
begin
if Length(FSignatures) = 1 then
begin
Result := SignatureToString(FSignatures[0]);
end
else
begin
// Handle overloaded methods
sb := TStringBuilder.Create;
try
sb.Append('Method{');
for sig in FSignatures do
begin
sb.Append('(');
sb.Append(SignatureToString(sig));
sb.Append('), ');
end;
sb.Remove(sb.Length - 2, 2); // Remove last ', '
sb.Append('}');
Result := sb.ToString;
finally
sb.Free;
end;
end;
end;
// ---
@@ -369,6 +482,7 @@ type
function GetKind: TStaticTypeKind; override;
function GetDefinition: IScalarRecordDefinition; override;
function IsEqual(const Other: IStaticType): Boolean; override;
function GetHashCode: Integer; override; // Added
function ToString: string; override;
end;
@@ -414,6 +528,26 @@ begin
Result := True;
end;
function TRecordType.GetHashCode: Integer;
var
field: TPair<IKeyword, TScalar.TKind>;
begin
// Consistent with IsEqual
Result := Ord(GetKind);
if Assigned(FDefinition) then
begin
for field in FDefinition.Fields do
begin
// Hash the Keyword pointer (fast, from flyweight)
var hash := TEqualityComparer<IKeyword>.Default.GetHashCode(field.Key);
Result := THashBobJenkins.GetHashValue(hash, SizeOf(Pointer), Result);
// Hash the TScalar.TKind value
var data := Ord(field.Value);
Result := THashBobJenkins.GetHashValue(data, SizeOf(Byte), Result);
end;
end;
end;
function TRecordType.ToString: string;
var
i: Integer;
@@ -441,6 +575,7 @@ type
function GetKind: TStaticTypeKind; override;
function GetGenericDefinition: IGenericRecordDefinition; override;
function IsEqual(const Other: IStaticType): Boolean; override;
function GetHashCode: Integer; override; // Added
function ToString: string; override;
end;
@@ -485,6 +620,29 @@ begin
Result := True;
end;
function TGenericRecordType.GetHashCode: Integer;
var
field: TPair<IKeyword, IStaticType>;
begin
// Consistent with IsEqual
Result := Ord(stGenericRecord);
if Assigned(FDefinition) then
begin
for field in FDefinition.Fields do
begin
// Hash the Keyword pointer (fast, from flyweight)
var data := TEqualityComparer<IKeyword>.Default.GetHashCode(field.Key);
Result := THashBobJenkins.GetHashValue(data, SizeOf(Pointer), Result);
// Hash the IStaticType value
if Assigned(field.Value) then
begin
var hash := field.Value.GetHashCode;
Result := THashBobJenkins.GetHashValue(hash, SizeOf(Integer), Result);
end;
end;
end;
end;
function TGenericRecordType.ToString: string;
var
i: Integer;
@@ -516,8 +674,21 @@ begin
end;
class function TTypes.CreateMethod(const AParamTypes: TArray<IStaticType>; const AReturnType: IStaticType): IStaticType;
var
sig: IMethodSignature;
sigs: TArray<IMethodSignature>;
begin
Result := TMethodType.Create(AParamTypes, AReturnType);
// This is now a convenience helper for CreateMethodSet
sig := TMethodSignature.Create(AParamTypes, AReturnType);
SetLength(sigs, 1);
sigs[0] := sig;
Result := TMethodType.Create(sigs);
end;
class function TTypes.CreateMethodSet(const ASignatures: TArray<IMethodSignature>): IStaticType;
begin
// This is the new primary factory for method types
Result := TMethodType.Create(ASignatures);
end;
class function TTypes.CreateRecord(const ADef: IScalarRecordDefinition): IStaticType;
-61
View File
@@ -17,8 +17,6 @@ type
function IAstVisitor.VisitConstant = DoVisitConstant;
function IAstVisitor.VisitIdentifier = DoVisitIdentifier;
function IAstVisitor.VisitKeyword = DoVisitKeyword;
function IAstVisitor.VisitBinaryExpression = DoVisitBinaryExpression;
function IAstVisitor.VisitUnaryExpression = DoVisitUnaryExpression;
function IAstVisitor.VisitIfExpression = DoVisitIfExpression;
function IAstVisitor.VisitTernaryExpression = DoVisitTernaryExpression;
function IAstVisitor.VisitLambdaExpression = DoVisitLambdaExpression;
@@ -44,8 +42,6 @@ type
function DoVisitConstant(const Node: IConstantNode): TDataValue;
function DoVisitIdentifier(const Node: IIdentifierNode): TDataValue;
function DoVisitKeyword(const Node: IKeywordNode): TDataValue;
function DoVisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue;
function DoVisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue;
function DoVisitIfExpression(const Node: IIfExpressionNode): TDataValue;
function DoVisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue;
function DoVisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue;
@@ -74,8 +70,6 @@ type
function VisitConstant(const Node: IConstantNode): T; virtual; abstract;
function VisitIdentifier(const Node: IIdentifierNode): T; virtual; abstract;
function VisitKeyword(const Node: IKeywordNode): T; virtual; abstract;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): T; virtual; abstract;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): T; virtual; abstract;
function VisitIfExpression(const Node: IIfExpressionNode): T; virtual; abstract;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): T; virtual; abstract;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): T; virtual; abstract;
@@ -106,8 +100,6 @@ type
function VisitConstant(const Node: IConstantNode): IAstNode; override;
function VisitIdentifier(const Node: IIdentifierNode): IAstNode; override;
function VisitKeyword(const Node: IKeywordNode): IAstNode; override;
function VisitBinaryExpression(const Node: IBinaryExpressionNode): IAstNode; override;
function VisitUnaryExpression(const Node: IUnaryExpressionNode): IAstNode; override;
function VisitIfExpression(const Node: IIfExpressionNode): IAstNode; override;
function VisitTernaryExpression(const Node: ITernaryExpressionNode): IAstNode; override;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): IAstNode; override;
@@ -136,8 +128,6 @@ type
function IAstVisitor.VisitConstant = DoVisitConstant;
function IAstVisitor.VisitIdentifier = DoVisitIdentifier;
function IAstVisitor.VisitKeyword = DoVisitKeyword;
function IAstVisitor.VisitBinaryExpression = DoVisitBinaryExpression;
function IAstVisitor.VisitUnaryExpression = DoVisitUnaryExpression;
function IAstVisitor.VisitIfExpression = DoVisitIfExpression;
function IAstVisitor.VisitTernaryExpression = DoVisitTernaryExpression;
function IAstVisitor.VisitLambdaExpression = DoVisitLambdaExpression;
@@ -163,8 +153,6 @@ type
function DoVisitConstant(const Node: IConstantNode): TDataValue;
function DoVisitIdentifier(const Node: IIdentifierNode): TDataValue;
function DoVisitKeyword(const Node: IKeywordNode): TDataValue;
function DoVisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue;
function DoVisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue;
function DoVisitIfExpression(const Node: IIfExpressionNode): TDataValue;
function DoVisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue;
function DoVisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue;
@@ -191,8 +179,6 @@ type
procedure VisitConstant(const Node: IConstantNode); virtual; abstract;
procedure VisitIdentifier(const Node: IIdentifierNode); virtual; abstract;
procedure VisitKeyword(const Node: IKeywordNode); virtual; abstract;
procedure VisitBinaryExpression(const Node: IBinaryExpressionNode); virtual; abstract;
procedure VisitUnaryExpression(const Node: IUnaryExpressionNode); virtual; abstract;
procedure VisitIfExpression(const Node: IIfExpressionNode); virtual; abstract;
procedure VisitTernaryExpression(const Node: ITernaryExpressionNode); virtual; abstract;
procedure VisitLambdaExpression(const Node: ILambdaExpressionNode); virtual; abstract;
@@ -244,16 +230,6 @@ begin
Result := TDataValue.FromGeneric<T>(VisitKeyword(Node));
end;
function TAstVisitor<T>.DoVisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue;
begin
Result := TDataValue.FromGeneric<T>(VisitBinaryExpression(Node));
end;
function TAstVisitor<T>.DoVisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue;
begin
Result := TDataValue.FromGeneric<T>(VisitUnaryExpression(Node));
end;
function TAstVisitor<T>.DoVisitIfExpression(const Node: IIfExpressionNode): TDataValue;
begin
Result := TDataValue.FromGeneric<T>(VisitIfExpression(Node));
@@ -466,33 +442,6 @@ begin
Result := Node; // Leaf node, immutable
end;
function TAstTransformer.VisitBinaryExpression(const Node: IBinaryExpressionNode): IAstNode;
var
newLeft, newRight: IAstNode;
begin
newLeft := Accept(Node.Left);
newRight := Accept(Node.Right);
if (newLeft = Node.Left) and (newRight = Node.Right) then
Result := Node
else
// Use TAst factory instead of concrete class constructor
Result := TAst.BinaryExpr(newLeft, Node.Operator, newRight, Node.StaticType);
end;
function TAstTransformer.VisitUnaryExpression(const Node: IUnaryExpressionNode): IAstNode;
var
newRight: IAstNode;
begin
newRight := Accept(Node.Right);
if newRight = Node.Right then
Result := Node
else
// Use TAst factory
Result := TAst.UnaryExpr(Node.Operator, newRight, Node.StaticType);
end;
function TAstTransformer.VisitIfExpression(const Node: IIfExpressionNode): IAstNode;
var
newCond, newThen, newElse: IAstNode;
@@ -785,16 +734,6 @@ begin
VisitKeyword(Node);
end;
function TAstVisitor.DoVisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue;
begin
VisitBinaryExpression(Node);
end;
function TAstVisitor.DoVisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue;
begin
VisitUnaryExpression(Node);
end;
function TAstVisitor.DoVisitIfExpression(const Node: IIfExpressionNode): TDataValue;
begin
VisitIfExpression(Node);
+17 -173
View File
@@ -26,7 +26,11 @@ type
class destructor Destroy;
public
class procedure RegisterLibrary(const AProc: TRegisterLibraryProc); static;
class function CreateScope(Parent: IExecutionScope; const Descriptor: IScopeDescriptor = nil): IExecutionScope; static;
class function CreateScope(
Parent: IExecutionScope;
const Descriptor: IScopeDescriptor = nil;
ARegisterLibraries: Boolean = False
): IExecutionScope; static;
// A No-Operation node, used as a placeholder/stub (e.g., for UI drop targets).
class function Nop(const AStaticType: IStaticType = nil): IAstNode; static;
@@ -41,17 +45,6 @@ type
const Address: TResolvedAddress;
const AStaticType: IStaticType = nil
): IIdentifierNode; overload; static;
class function BinaryExpr(
ALeft: IAstNode;
AOperator: TScalar.TBinaryOp;
ARight: IAstNode;
const AStaticType: IStaticType = nil
): IBinaryExpressionNode; static;
class function UnaryExpr(
const AOperator: TScalar.TUnaryOp;
const ARight: IAstNode;
const AStaticType: IStaticType = nil
): IUnaryExpressionNode; static;
class function IfExpr(
const ACondition: IAstNode;
const AThenBranch, AElseBranch: IAstNode;
@@ -156,8 +149,6 @@ type
function AsConstant: IConstantNode; virtual;
function AsIdentifier: IIdentifierNode; virtual;
function AsKeyword: IKeywordNode; virtual;
function AsBinaryExpression: IBinaryExpressionNode; virtual;
function AsUnaryExpression: IUnaryExpressionNode; virtual;
function AsIfExpression: IIfExpressionNode; virtual;
function AsTernaryExpression: ITernaryExpressionNode; virtual;
function AsLambdaExpression: ILambdaExpressionNode; virtual;
@@ -196,7 +187,7 @@ type
property StaticType: IStaticType read GetStaticType;
end;
TLambdaExpressionNode = class(TAstTypedNode, ILambdaExpressionNode)
TLambdaExpressionNode = class(TAstTypedNode, ILambdaExpressionNode, IFunctionDefinition)
private
FParameters: TArray<IIdentifierNode>;
FBody: IAstNode;
@@ -400,39 +391,6 @@ type
property Expressions: TArray<IAstNode> read FExpressions;
end;
TBinaryExpressionNode = class(TAstTypedNode, IBinaryExpressionNode)
private
FLeft: IAstNode;
FOperator: TScalar.TBinaryOp;
FRight: IAstNode;
function GetLeft: IAstNode;
function GetOperator: TScalar.TBinaryOp;
function GetRight: IAstNode;
function GetKind: TAstNodeKind; override;
public
constructor Create(const ALeft: IAstNode; AOperator: TScalar.TBinaryOp; const ARight: IAstNode; const AStaticType: IStaticType);
function Accept(const Visitor: IAstVisitor): TDataValue; override;
function AsBinaryExpression: IBinaryExpressionNode; override;
property Left: IAstNode read FLeft;
property Operator: TScalar.TBinaryOp read FOperator;
property Right: IAstNode read FRight;
end;
TUnaryExpressionNode = class(TAstTypedNode, IUnaryExpressionNode)
private
FOperator: TScalar.TUnaryOp;
FRight: IAstNode;
function GetOperator: TScalar.TUnaryOp;
function GetRight: IAstNode;
function GetKind: TAstNodeKind; override;
public
constructor Create(const AOperator: TScalar.TUnaryOp; const ARight: IAstNode; const AStaticType: IStaticType);
function Accept(const Visitor: IAstVisitor): TDataValue; override;
function AsUnaryExpression: IUnaryExpressionNode; override;
property Operator: TScalar.TUnaryOp read FOperator;
property Right: IAstNode read FRight;
end;
TIfExpressionNode = class(TAstTypedNode, IIfExpressionNode)
private
FCondition: IAstNode;
@@ -597,16 +555,23 @@ type
{ TAst }
class function TAst.CreateScope(Parent: IExecutionScope; const Descriptor: IScopeDescriptor): IExecutionScope;
class function TAst.CreateScope(
Parent: IExecutionScope;
const Descriptor: IScopeDescriptor = nil;
ARegisterLibraries: Boolean = False
): IExecutionScope;
begin
if Assigned(Descriptor) then
Result := Descriptor.CreateScope(Parent)
else
Result := TScope.CreateScope(Parent, nil, nil);
// Register libraries in the *new* scope
for var libProc in FLibraries do
libProc(Result);
// This should only be True when creating the *root* environment.
if ARegisterLibraries then
begin
for var libProc in FLibraries do
libProc(Result);
end;
end;
class function TAst.CreateSeries(const ADefinition: String; const AStaticType: IStaticType = nil): ICreateSeriesNode;
@@ -668,23 +633,6 @@ begin
Result := TAssignmentNode.Create(TAst.Identifier('Result'), AValue, TTypes.Unknown);
end;
class function TAst.BinaryExpr(
ALeft: IAstNode;
AOperator: TScalar.TBinaryOp;
ARight: IAstNode;
const AStaticType: IStaticType = nil
): IBinaryExpressionNode;
begin
Result :=
TBinaryExpressionNode.Create(
ALeft,
AOperator,
ARight,
if AStaticType <> nil then AStaticType
else TTypes.Unknown
);
end;
class function TAst.Block(const AExpressions: array of IAstNode; const AStaticType: IStaticType = nil): IBlockExpressionNode;
begin
Result :=
@@ -922,21 +870,6 @@ begin
);
end;
class function TAst.UnaryExpr(
const AOperator: TScalar.TUnaryOp;
const ARight: IAstNode;
const AStaticType: IStaticType = nil
): IUnaryExpressionNode;
begin
Result :=
TUnaryExpressionNode.Create(
AOperator,
ARight,
if AStaticType <> nil then AStaticType
else TTypes.Unknown
);
end;
class function TAst.Unquote(const AExpression: IAstNode): IUnquoteNode;
begin
Result := TUnquoteNode.Create(AExpression);
@@ -1004,11 +937,6 @@ begin
raise ETypeException.Create('Node is not an Assignment');
end;
function TAstNode.AsBinaryExpression: IBinaryExpressionNode;
begin
raise ETypeException.Create('Node is not a BinaryExpression');
end;
function TAstNode.AsBlockExpression: IBlockExpressionNode;
begin
raise ETypeException.Create('Node is not a BlockExpression');
@@ -1105,11 +1033,6 @@ begin
raise ETypeException.Create('Node has no type');
end;
function TAstNode.AsUnaryExpression: IUnaryExpressionNode;
begin
raise ETypeException.Create('Node is not an UnaryExpression');
end;
function TAstNode.AsUnquote: IUnquoteNode;
begin
raise ETypeException.Create('Node is not an Unquote');
@@ -1244,85 +1167,6 @@ begin
Result := akKeyword;
end;
{ TBinaryExpressionNode }
constructor TBinaryExpressionNode.Create(
const ALeft: IAstNode;
AOperator: TScalar.TBinaryOp;
const ARight: IAstNode;
const AStaticType: IStaticType
);
begin
inherited Create(AStaticType);
FLeft := ALeft;
FOperator := AOperator;
FRight := ARight;
end;
function TBinaryExpressionNode.Accept(const Visitor: IAstVisitor): TDataValue;
begin
Result := Visitor.VisitBinaryExpression(Self);
end;
function TBinaryExpressionNode.AsBinaryExpression: IBinaryExpressionNode;
begin
Result := Self;
end;
function TBinaryExpressionNode.GetLeft: IAstNode;
begin
Result := FLeft;
end;
function TBinaryExpressionNode.GetOperator: TScalar.TBinaryOp;
begin
Result := FOperator;
end;
function TBinaryExpressionNode.GetRight: IAstNode;
begin
Result := FRight;
end;
function TBinaryExpressionNode.GetKind: TAstNodeKind;
begin
Result := akBinaryExpression;
end;
{ TUnaryExpressionNode }
constructor TUnaryExpressionNode.Create(const AOperator: TScalar.TUnaryOp; const ARight: IAstNode; const AStaticType: IStaticType);
begin
inherited Create(AStaticType);
FOperator := AOperator;
FRight := ARight;
end;
function TUnaryExpressionNode.Accept(const Visitor: IAstVisitor): TDataValue;
begin
Result := Visitor.VisitUnaryExpression(Self);
end;
function TUnaryExpressionNode.AsUnaryExpression: IUnaryExpressionNode;
begin
Result := Self;
end;
function TUnaryExpressionNode.GetOperator: TScalar.TUnaryOp;
begin
Result := FOperator;
end;
function TUnaryExpressionNode.GetRight: IAstNode;
begin
Result := FRight;
end;
function TUnaryExpressionNode.GetKind: TAstNodeKind;
begin
Result := akUnaryExpression;
end;
{ TIfExpressionNode }
constructor TIfExpressionNode.Create(const ACondition, AThenBranch, AElseBranch: IAstNode; const AStaticType: IStaticType);