Brummel/MycLib
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases Wiki Activity

Anonymous recursions

Browse Source
This commit is contained in:
Michael Schimmel
2025-09-19 23:53:48 +02:00
parent 28558614f0
commit e03155179a
7 changed files with 126 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ASTPlayground/ASTPlayground.dpr
+2 -1
View File
@@ -19,7 +19,8 @@ uses
Myc.Ast.Binding in '..\Src\AST\Myc.Ast.Binding.pas',
Myc.Ast.RTL in '..\Src\AST\Myc.Ast.RTL.pas',
Myc.Ast.Dumper in '..\Src\AST\Myc.Ast.Dumper.pas',
Myc.Ast.RTL.Core in '..\Src\AST\Myc.Ast.RTL.Core.pas';
Myc.Ast.RTL.Core in '..\Src\AST\Myc.Ast.RTL.Core.pas',
Myc.Utils in '..\Src\Myc.Utils.pas';
{$R *.res}
ASTPlayground/ASTPlayground.dproj
+1
View File
@@ -151,6 +151,7 @@
<DCCReference Include="..\Src\AST\Myc.Ast.RTL.pas"/>
<DCCReference Include="..\Src\AST\Myc.Ast.Dumper.pas"/>
<DCCReference Include="..\Src\AST\Myc.Ast.RTL.Core.pas"/>
<DCCReference Include="..\Src\Myc.Utils.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
ASTPlayground/MainForm.pas
+42 -14
View File
@@ -31,6 +31,9 @@ uses
Myc.Ast.Evaluator,
Myc.Ast.Printer,
Myc.Ast.Dumper,
Myc.Data.Decimal,
Myc.Ast.Binding,
Myc.Ast.RTL,
FMX.Layouts,
FMX.Objects,
Myc.Ast.Debugger;
@@ -110,8 +113,6 @@ implementation
uses
Myc.Data.Scalar.JSON,
Myc.Data.Decimal,
Myc.Ast.Binding,
System.Diagnostics, // For TStopwatch
Myc.Ast.Json; // For TAstJson serialization
@@ -184,9 +185,6 @@ begin
resultValue := ExecuteAst(mainBlock, FGScope);
//TODO Dieses Assert löst aus:
// "The final result should be 15, but is 10 (T:\Myc\ASTPlayground\MainForm.pas, line 186)"
Assert(TScalar.FromInteger(15) = resultValue.AsScalar, 'The final result should be 15, but is ' + resultValue.AsScalar.ToString);
end;
@@ -282,14 +280,14 @@ var
result: TDataValue;
sw: TStopwatch;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Recursive fib with AST---');
sw := TStopwatch.StartNew;
root :=
// Create a setup script to define a memoize-compatible 'fib' function globally.
var fibAst :=
TAst.Block(
[
TAst.VarDecl(
// 1. var fib; (Declare the name so it can be captured by the lambda. Initializer is nil)
TAst.VarDecl(TAst.Identifier('fib')),
// 2. var fib_impl = lambda(n) { ... fib(n-1) + fib(n-2) ... };
TAst.Assign(
TAst.Identifier('fib'),
TAst.LambdaExpr(
[TAst.Identifier('n')],
@@ -297,6 +295,7 @@ begin
TAst.BinaryExpr(TAst.Identifier('n'), boLess, TAst.Constant(TScalar.FromInt64(2))),
TAst.Identifier('n'),
TAst.BinaryExpr(
// Recursive calls now use the re-bindable name 'fib' instead of 'Self'
TAst.FunctionCall(
TAst.Identifier('Self'),
[TAst.BinaryExpr(TAst.Identifier('n'), boSubtract, TAst.Constant(TScalar.FromInt64(1)))]
@@ -309,14 +308,43 @@ begin
)
)
)
),
)
]
);
var fibScope := TAstBinder.Bind(fibAst, FGScope).CreateScope(FGScope);
var visitor := CreateVisitor(fibScope);
Result := visitor.Execute(fibAst);
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Recursive fib with AST---');
sw := TStopwatch.StartNew;
root := TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(TScalar.FromInt64(30))]);
FLastAst := root;
// Execute with fibScope as parent. The helper function handles debug/prod switching.
result := ExecuteAst(root, fibScope);
sw.Stop;
Memo1.Lines.Add(Format('Result: fib(30) %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
Memo1.Lines.Add('');
Memo1.Lines.Add('--- Memoized recursive fib with AST (using global fib)---');
sw := TStopwatch.StartNew;
root :=
TAst.Block(
[
// Create a memoized version by calling the RTL function on the global 'fib'
TAst.Assign(TAst.Identifier('fib'), TAst.FunctionCall(TAst.Identifier('Memoize'), [TAst.Identifier('fib')])),
// Call the memoized function
TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(TScalar.FromInt64(30))])
]
);
FLastAst := root;
// Execute with FGScope as parent. The helper function handles debug/prod switching.
result := ExecuteAst(root, FGScope);
result := ExecuteAst(root, fibScope);
sw.Stop;
Memo1.Lines.Add(Format('Result: fib(30) %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
Src/AST/Myc.Ast.RTL.Core.pas
+4 -2
View File
@@ -3,6 +3,7 @@ unit Myc.Ast.RTL.Core;
interface
uses
Myc.Utils,
Myc.Data.Scalar,
Myc.Data.Value,
Myc.Ast.RTL;
@@ -122,7 +123,6 @@ end;
class function TRtlFunctions.Memoize(const Args: TArray<TDataValue>): TDataValue;
var
funcToMemoize: TDataValue.TFunc;
cache: TDictionary<Int64, TDataValue>;
memoizedFunc: TDataValue.TFunc;
begin
if Length(Args) <> 1 then
@@ -130,8 +130,8 @@ begin
if Args[0].Kind <> vkMethod then
raise EArgumentException.Create('The argument to Memoize must be a function.');
var cCache: TManaged<TDictionary<Int64, TDataValue>> := TDictionary<Int64, TDataValue>.Create;
funcToMemoize := Args[0].AsMethod();
cache := TDictionary<Int64, TDataValue>.Create;
memoizedFunc :=
function(const AArgs: TArray<TDataValue>): TDataValue
@@ -151,6 +151,8 @@ begin
else
key := argScalar.Value.AsInt64;
var cache: TDictionary<Int64, TDataValue> := cCache;
if cache.TryGetValue(key, Result) then
exit;
Src/AST/Myc.Ast.RTL.pas
+29 -29
View File
@@ -54,34 +54,10 @@ type
const AArgs: TArray<TDataValue>;
out AArg: TScalar
): Boolean; static; inline;
class function CreateScalarWrapper(AFuncName: string; AFuncPtr: Pointer): TDataValue.TFunc; static;
public
class procedure RegisterAll(const AScope: IExecutionScope); static;
end;
// This is the "Wrapper Generator" for the (TScalar):TScalar signature.
// It creates a high-performance anonymous method that uses a direct function pointer.
class function TRtlRegistry.CreateScalarWrapper(AFuncName: string; AFuncPtr: Pointer): TDataValue.TFunc;
var
// Statically typed pointer to the native function.
nativeFunc: TNativeScalarFunc;
begin
nativeFunc := AFuncPtr;
// This is the generated wrapper that will be registered with the interpreter.
Result :=
function(const Args: TArray<TDataValue>): TDataValue
var
argScalar: TScalar;
begin
// 1. Optimized argument validation and unpacking.
GetSingleNumericArg(AFuncName, Args, argScalar);
// 2. Direct, statically typed call via pointer.
Result := TDataValue(nativeFunc(argScalar));
end;
end;
{ TRtlRegistry }
class function TRtlRegistry.GetSingleNumericArg(const AName: string; const AArgs: TArray<TDataValue>; out AArg: TScalar): Boolean;
@@ -123,6 +99,9 @@ begin
if not (attribute is TRtlFunctionAttribute) then
continue;
if method.MethodKind <> mkClassFunction then
continue;
rtlAttribute := attribute as TRtlFunctionAttribute;
wrapper := nil;
@@ -134,7 +113,21 @@ begin
if param.ParamType.Handle = TypeInfo(TScalar) then
begin
// Signature matches: class function(Arg: TScalar): TScalar;
wrapper := CreateScalarWrapper(rtlAttribute.Name, method.CodeAddress);
// 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;
wrapper := wrapperFactory(rtlAttribute.Name, method.CodeAddress);
end;
end
else if (Length(method.GetParameters) = 1) and (method.ReturnType.Handle = TypeInfo(TDataValue)) then
@@ -143,13 +136,20 @@ begin
if (pfConst in param.Flags) and (param.ParamType.Handle = TypeInfo(TArray<TDataValue>)) then
begin
// Signature matches: class function(const Args: TArray<TDataValue>): TDataValue;
// For these, we can just cast the pointer directly. No wrapper needed.
wrapper :=
// 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(method.CodeAddress)(Args);
Result := TNativeDataValueFunc1(CodeAddress)(Args);
end;
end;
// Create the wrapper
wrapper := wrapperFactory(method.CodeAddress);
end;
end;
if Assigned(wrapper) then
@@ -158,7 +158,7 @@ begin
break; // Found our attribute, proceed to next method
end
else
raise ENotImplemented.Create('Native method wrapper not implemented');
raise ENotImplemented.CreateFmt('Native method wrapper for %s() not implemented', [method.Name]);
end;
end;
finally
Src/AST/Myc.Ast.pas
+2 -2
View File
@@ -37,7 +37,7 @@ type
class function LambdaExpr(const AParameters: TArray<IIdentifierNode>; const ABody: IAstNode): ILambdaExpressionNode; static;
class function FunctionCall(const ACallee: IAstNode; const AArguments: TArray<IAstNode>): IFunctionCallNode; static;
class function Block(const AExpressions: array of IAstNode): IBlockExpressionNode; static;
class function VarDecl(const AIdentifier: IIdentifierNode; AInitializer: IAstNode): IVariableDeclarationNode; static;
class function VarDecl(const AIdentifier: IIdentifierNode; AInitializer: IAstNode = nil): IVariableDeclarationNode; static;
class function Assign(const AIdentifier: IIdentifierNode; const AValue: IAstNode): IAssignmentNode; static;
class function AssignResult(const AValue: IAstNode): IAssignmentNode; static; deprecated;
class function Indexer(const ABase: IAstNode; const AIndex: IAstNode): IIndexerNode; static;
@@ -780,7 +780,7 @@ begin
Result := TUnaryExpressionNode.Create(AOperator, ARight);
end;
class function TAst.VarDecl(const AIdentifier: IIdentifierNode; AInitializer: IAstNode): IVariableDeclarationNode;
class function TAst.VarDecl(const AIdentifier: IIdentifierNode; AInitializer: IAstNode = nil): IVariableDeclarationNode;
begin
Result := TVariableDeclarationNode.Create(AIdentifier, AInitializer);
end;
Src/Myc.Utils.pas
+45
View File
@@ -0,0 +1,45 @@
unit Myc.Utils;
interface
type
TManaged<T: class> = record
private
type
TObj = class(TInterfacedObject)
FValue: T;
constructor Create(AValue: T);
destructor Destroy; override;
end;
var
FIntf: IInterface;
public
class operator Implicit(A: T): TManaged<T>; overload;
class operator Implicit(const Upvalue: TManaged<T>): T; overload;
end;
implementation
constructor TManaged<T>.TObj.Create(AValue: T);
begin
inherited Create;
FValue := AValue;
end;
destructor TManaged<T>.TObj.Destroy;
begin
FValue.Free;
inherited;
end;
class operator TManaged<T>.Implicit(A: T): TManaged<T>;
begin
Result.FIntf := TObj.Create(A);
end;
class operator TManaged<T>.Implicit(const Upvalue: TManaged<T>): T;
begin
Result := (Upvalue.FIntf as TObj).FValue;
end;
end.