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

RTL custom interface types as records, added callbacks (marshalled using virtual interfaces)

Browse Source
This commit is contained in:
Michael Schimmel
2025-12-12 02:28:25 +01:00
parent 8c60949ec9
commit e84ecfa2d2
8 changed files with 192 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ASTPlayground/ASTPlayground.delphilsp.json
+1 -1
View File
File diff suppressed because one or more lines are too long
ASTPlayground/ASTPlayground.dpr
+2 -1
View File
@@ -37,7 +37,8 @@ uses
Myc.Fmx.AstEditor.Handlers.Primitives in '..\Src\AST\Myc.Fmx.AstEditor.Handlers.Primitives.pas',
Myc.Fmx.AstEditor.Handlers.Control in '..\Src\AST\Myc.Fmx.AstEditor.Handlers.Control.pas',
Myc.Fmx.AstEditor.Handlers.Data in '..\Src\AST\Myc.Fmx.AstEditor.Handlers.Data.pas',
Myc.Ast.RTL.TypeRegistry in '..\Src\AST\Myc.Ast.RTL.TypeRegistry.pas';
Myc.Ast.RTL.TypeRegistry in '..\Src\AST\Myc.Ast.RTL.TypeRegistry.pas',
Myc.Trade.Broker in '..\Src\Myc.Trade.Broker.pas';
{$R *.res}
ASTPlayground/ASTPlayground.dproj
+1
View File
@@ -168,6 +168,7 @@
<DCCReference Include="..\Src\AST\Myc.Fmx.AstEditor.Handlers.Control.pas"/>
<DCCReference Include="..\Src\AST\Myc.Fmx.AstEditor.Handlers.Data.pas"/>
<DCCReference Include="..\Src\AST\Myc.Ast.RTL.TypeRegistry.pas"/>
<DCCReference Include="..\Src\Myc.Trade.Broker.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
ASTPlayground/MainForm.fmx
+6 -6
View File
@@ -246,14 +246,14 @@ object Form1: TForm1
DataDetectorTypes = []
Lines.Strings = (
'(do'
' (defmacro test [body] `(fn [] ~body ))'
' (defmacro test2 [body] `(fn [] ~body ))'
' (test2 "hi")'
' ;; Broker mit 10.000 Startkapital erstellen'
' (def broker (create-broker 10000.0))'
' '
' (def debug-mode :true)'
' ;; Aktien kaufen: 10 St'#252'ck von "AAPL" zu 150.0'
' ((.Buy broker) "AAPL" 10 150.0)'
' ((.Buy broker) "MSFT" 5 50.0)'
' '
' (stopwatch '
' (if debug-mode (print "Debug an")))'
' ((.ListPositions broker) (fn [t] (print t)))'
')')
StyledSettings = [Size, Style, FontColor]
TextSettings.Font.Family = 'Consolas'
ASTPlayground/MainForm.pas
+18 -9
View File
@@ -114,6 +114,7 @@ type
procedure RTLListViewChange(Sender: TObject);
private
FCurrUnboundAst: IAstNode;
FCurrCompiled: ILambdaExpressionNode;
FCurrExec: TCompiledFunction;
FEnvironment: TAstEnvironment;
FAstEditor: TAstEditor; // Die Komponente (Facade)
@@ -141,6 +142,7 @@ implementation
uses
Myc.Data.Scalar.JSON,
Myc.Trade.Broker,
System.Diagnostics, // For TStopwatch
System.TimeSpan,
Myc.Ast.Json, // For TAstJson serialization
@@ -306,7 +308,8 @@ begin
try
// Use Compile directly. Errors will be raised as ECompilationFailed.
// We catch them to print to log, but allow flow to continue so UI can be updated.
FCurrExec := FEnvironment.Compile(ANode);
FCurrCompiled := FEnvironment.Compile(ANode);
FCurrExec := FEnvironment.Link(FCurrCompiled);
if Assigned(FCurrExec.Func) then
begin
@@ -599,7 +602,8 @@ begin
Memo1.Lines.Add('--- Naive recursive fib with AST---');
var fibExec := TestEnv.Compile(TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(25)])).Func;
FCurrCompiled := TestEnv.Compile(TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(25)]));
var fibExec := TestEnv.Link(FCurrCompiled).Func;
sw := TStopwatch.StartNew;
result := fibExec([]);
@@ -614,7 +618,7 @@ begin
memoizeTest.Define('fib', TAstScript.Parse('(Memoize fib)'));
var memoizeExec := memoizeTest.Compile(TAstScript.Parse('(fib 25)')).Func;
var memoizeExec := memoizeTest.Link(memoizeTest.Compile(TAstScript.Parse('(fib 25)'))).Func;
sw := TStopwatch.StartNew;
result := memoizeExec([]);
@@ -757,7 +761,8 @@ begin
FCurrUnboundAst := converter.Deserialize(jsonObj);
// Run the full pipeline via environment
FCurrExec := FEnvironment.Compile(FCurrUnboundAst);
FCurrCompiled := FEnvironment.Compile(FCurrUnboundAst);
FCurrExec := FEnvironment.Link(FCurrCompiled);
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.');
@@ -822,7 +827,7 @@ begin
var seriesAddress := env.RootScope.Define('current_series', TDataValue.Void);
var callExec := env.Compile(TAst.FunctionCall(TAst.Identifier('maCrossStrategy'), [TAst.Identifier('current_series')])).Func;
var callExec := env.Link(env.Compile(TAst.FunctionCall(TAst.Identifier('maCrossStrategy'), [TAst.Identifier('current_series')]))).Func;
// Simulation Loop
Memo1.Lines.Clear;
@@ -1169,7 +1174,8 @@ end;
procedure TForm1.Test1ButtonClick(Sender: TObject);
begin
FCurrUnboundAst := TAstScript.Parse('(do (print txt))');
var fn := FEnvironment.Compile(FCurrUnboundAst, [TAst.Identifier('txt')]).Func;
FCurrCompiled := FEnvironment.Compile(FCurrUnboundAst, [TAst.Identifier('txt')]);
var fn := FEnvironment.Link(FCurrCompiled).Func;
fn(['Hello World']);
FEnvironment.RootScope.Define('fn', fn);
UpdateScript;
@@ -1247,14 +1253,17 @@ begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- AST Dump ---');
if FCurrUnboundAst = nil then
if FCurrCompiled = nil then
begin
Memo1.Lines.Add('No AST available.');
Memo1.Lines.Add('No compiled AST available.');
exit;
end;
// Dump the raw unbound AST first
TAstDumper.Dump(FCurrUnboundAst, Memo1.Lines);
TAstDumper.Dump(FCurrCompiled, Memo1.Lines);
end;
initialization
TAst.RegisterLibrary(RegisterBroker);
end.
Src/AST/Myc.Ast.Environment.pas
+17 -16
View File
@@ -54,8 +54,8 @@ type
const Node: IFunctionDefinition;
const ArgTypes: TArray<IStaticType> = [];
const Log: ICompilerLog = nil
): TCompiledFunction;
function Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog): TCompiledFunction;
): ILambdaExpressionNode;
function Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog = nil): TCompiledFunction;
function CreateEnvironment: IEnvironment;
@@ -93,9 +93,9 @@ type
const Node: IAstNode;
const Params: TArray<IIdentifierNode> = [];
const ArgTypes: TArray<IStaticType> = []
): TCompiledFunction; overload;
function Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType> = []): TCompiledFunction; overload;
function Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog): TCompiledFunction;
): ILambdaExpressionNode; overload;
function Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType> = []): ILambdaExpressionNode; overload;
function Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog = nil): TCompiledFunction;
function Run(const ANode: IAstNode; const Params: TArray<IIdentifierNode> = []; const Args: TArray<TDataValue> = []): TDataValue;
@@ -193,8 +193,8 @@ type
const Node: IFunctionDefinition;
const ArgTypes: TArray<IStaticType>;
const Log: ICompilerLog = nil
): TCompiledFunction;
function Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog): TCompiledFunction;
): ILambdaExpressionNode;
function Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog = nil): TCompiledFunction;
end;
{ TAstEnvironment }
@@ -235,12 +235,12 @@ function TAstEnvironment.Compile(
const Node: IAstNode;
const Params: TArray<IIdentifierNode> = [];
const ArgTypes: TArray<IStaticType> = []
): TCompiledFunction;
): ILambdaExpressionNode;
begin
Result := FEnvironment.Compile(TAst.LambdaExpr(Params, Node), ArgTypes);
end;
function TAstEnvironment.Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType> = []): TCompiledFunction;
function TAstEnvironment.Compile(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType> = []): ILambdaExpressionNode;
begin
Result := FEnvironment.Compile(Node, ArgTypes);
end;
@@ -263,7 +263,8 @@ end;
procedure TAstEnvironment.Define(const Name: String; const AScript: IAstNode);
begin
var compiled := Compile(AScript);
RootScope.Define(Name, compiled.Func([]), compiled.StaticType);
var linked := Link(compiled);
RootScope.Define(Name, linked.Func([]), compiled.StaticType);
end;
function TAstEnvironment.ExpandMacros(const Node: IAstNode): IAstNode;
@@ -281,7 +282,7 @@ begin
Result := FEnvironment.GetMacroRegistry;
end;
function TAstEnvironment.Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog): TCompiledFunction;
function TAstEnvironment.Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog = nil): TCompiledFunction;
begin
Result := FEnvironment.Link(Node, Log);
end;
@@ -292,7 +293,7 @@ function TAstEnvironment.Run(
const Args: TArray<TDataValue> = []
): TDataValue;
begin
Result := Compile(ANode, Params).Func(Args);
Result := Link(Compile(ANode, Params)).Func(Args);
end;
function TAstEnvironment.Specialize(const Node: IAstNode): IAstNode;
@@ -404,7 +405,7 @@ function TEnvironment.Compile(
const Node: IFunctionDefinition;
const ArgTypes: TArray<IStaticType>;
const Log: ICompilerLog = nil
): TCompiledFunction;
): ILambdaExpressionNode;
var
layout: IScopeLayout;
lg: ICompilerLog;
@@ -428,10 +429,10 @@ begin
var specialized := Specialize(typedNode);
Result := Link(specialized.AsLambdaExpression, lg);
Result := specialized.AsLambdaExpression;
end;
function TEnvironment.Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog): TCompiledFunction;
function TEnvironment.Link(const Node: ILambdaExpressionNode; const Log: ICompilerLog = nil): TCompiledFunction;
var
descriptor: IScopeDescriptor;
funcType: IStaticType;
@@ -516,7 +517,7 @@ begin
FFunctionRegistry,
function(const Node: IFunctionDefinition; const ArgTypes: TArray<IStaticType>): TCompiledFunction
begin
Result := Compile(Node, ArgTypes);
Result := Link(Compile(Node, ArgTypes));
end
);
end;
Src/AST/Myc.Ast.RTL.TypeRegistry.pas
+137 -3
View File
@@ -33,6 +33,7 @@ type
// --- Analysis ---
class function AnalyzeType(ATypeInfo: PTypeInfo): IStaticType; static;
class function GenerateMethodType(RType: TRttiMethodType): IStaticType; static;
class function GenerateInterfaceDefinition(RType: TRttiInterfaceType): IStaticType; static;
class procedure EnterAnalysis(Info: PTypeInfo); static;
class procedure ExitAnalysis(Info: PTypeInfo); static;
@@ -72,6 +73,7 @@ type
implementation
uses
Myc.Ast.Evaluator,
Myc.Ast.RTL.Core;
{ TRtlTypeRegistry }
@@ -168,12 +170,71 @@ var
begin
rType := FCtx.GetType(ATypeInfo);
case rType.TypeKind of
tkInterface: Result := GenerateInterfaceDefinition(rType as TRttiInterfaceType);
// Check for Anonymous Method (treated as Interface in Delphi but should be stMethod in AST)
tkInterface:
begin
var rIntf := rType as TRttiInterfaceType;
// If the Interface has an "Invoke" method and is marked as reference-to (or is generic TFunc/TProc),
// map it directly to stMethod.
// Note: RTTI for "IsReferenceTo" is not always directly available,
// but we can check if there is exactly one method named "Invoke".
var method := rIntf.GetMethod('Invoke');
if Assigned(method) and (Length(rIntf.GetMethods) = 1) then
begin
// It is functionally a Delegate -> Map to stMethod
var params := method.GetParameters;
var pTypes: TArray<IStaticType>;
SetLength(pTypes, Length(params));
for var i := 0 to High(params) do
pTypes[i] := ResolveType(params[i].ParamType);
var retType: IStaticType;
if Assigned(method.ReturnType) then
retType := ResolveType(method.ReturnType)
else
retType := TTypes.Void;
Result := TTypes.CreateMethod(pTypes, retType);
end
else
begin
// Classic Interface -> Map to Generic Record
Result := GenerateInterfaceDefinition(rIntf);
end;
end;
// NEW: Support for classic method pointers (of object)
tkMethod: Result := GenerateMethodType(rType as TRttiMethodType);
else
Result := ResolveType(rType);
end;
end;
class function TRtlTypeRegistry.GenerateMethodType(RType: TRttiMethodType): IStaticType;
var
params: TArray<TRttiParameter>;
pTypes: TArray<IStaticType>;
retType: IStaticType;
i: Integer;
begin
params := RType.GetParameters;
SetLength(pTypes, Length(params));
for i := 0 to High(params) do
begin
pTypes[i] := ResolveType(params[i].ParamType);
end;
if Assigned(RType.ReturnType) then
retType := ResolveType(RType.ReturnType)
else
retType := TTypes.Void;
Result := TTypes.CreateMethod(pTypes, retType);
end;
class function TRtlTypeRegistry.GenerateInterfaceDefinition(RType: TRttiInterfaceType): IStaticType;
var
methods: TArray<TRttiMethod>;
@@ -260,8 +321,80 @@ begin
Result := TValue.From<Int64>(sc.Value.AsInt64);
end;
end;
vkText: Result := TValue.From<string>(AData.AsText);
vkVoid: Result := TValue.Empty;
vkText:
begin
Result := TValue.From<string>(AData.AsText);
end;
vkMethod:
begin
// We can only map script methods to Interfaces (Anonymous Methods are Interfaces).
if ATargetType.TypeKind <> tkInterface then
raise EInteropException.CreateFmt(
'Cannot marshal script method to non-interface type "%s". Target must be an interface or anonymous method.',
[ATargetType.Name]);
// Cast to Interface Type
var rIntf := ATargetType as TRttiInterfaceType;
var scriptFunc := AData.AsMethod;
// Create a proxy
var vIntf :=
TVirtualInterface.Create(
rIntf.Handle,
procedure(Method: TRttiMethod; const Args: TArray<TValue>; out Result: TValue)
var
scriptArgs: TArray<TDataValue>;
scriptResult: TDataValue;
i: Integer;
begin
// Args[0] is always the Instance (Self) for Interfaces, skip it.
SetLength(scriptArgs, Length(Args) - 1);
for i := 0 to High(scriptArgs) do
begin
scriptArgs[i] := FromTValue(Args[i + 1]);
end;
try
scriptResult := scriptFunc(scriptArgs);
// The caller comes from the Delphi world. We must ensure the TCO stack is flushed before returning.
TEvaluatorVisitor.HandleTCO(scriptResult);
except
on E: Exception do
raise EInteropException
.CreateFmt('Error executing script callback for "%s.%s": %s', [rIntf.Name, Method.Name, E.Message]);
end;
if Assigned(Method.ReturnType) then
begin
Result := ToTValue(scriptResult, Method.ReturnType);
end;
end
);
// Extract the Interface
var intfRef: IInterface;
if vIntf.QueryInterface(rIntf.GUID, intfRef) = S_OK then
begin
// Instead of using TValue.From(intfRef) (which creates a TValue of type IInterface),
// we force the TValue to the exact target type (e.g. TStringProc).
// PassArg requires exact type matching for Interfaces/Anonymous Methods.
TValue.Make(@intfRef, ATargetType.Handle, Result);
end
else
raise EInteropException.CreateFmt('Failed to create virtual interface for "%s".', [rIntf.Name]);
end;
vkVoid:
begin
if ATargetType.TypeKind = tkInterface then
raise EInteropException.Create(
'Cannot pass Void to Interface parameter (did you mean nil? or is your lambda returning void?)');
Result := TValue.Empty;
end
else
raise EInteropException.CreateFmt('Marshalling for DataKind %s not implemented.', [TRttiEnumerationType.GetName(AData.Kind)]);
end;
@@ -285,6 +418,7 @@ begin
// Recursively wrap returned interfaces
tkInterface: Result := WrapInstance(AValue.AsInterface, AValue.TypeInfo);
else
raise EInteropException.CreateFmt('FromTValue: Unsupported Kind %s', [TRttiEnumerationType.GetName(AValue.Kind)]);
Result := TDataValue.Void;
end;
end;
Src/AST/Myc.Ast.RTL.pas
+8 -6
View File
@@ -107,12 +107,6 @@ type
class function CreateWrapper_FO_F(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_FO_O(CodeAddress: Pointer): TDataValue.TFunc; static;
class function CreateWrapper_TT_T(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;
@@ -124,6 +118,14 @@ type
public
class procedure RegisterAll(const AScope: IExecutionScope); static;
class function CreateStaticWrapper(
method: TRttiMethod;
retType: IStaticType;
argTypes: TArray<IStaticType>;
rttiParams: TArray<TRttiParameter>
): TDataValue.TFunc; static;
// Public accessor for the TStaticSpecializer
class function GetStaticSpecialization(const AName: string; const AArgTypes: TArray<IStaticType>): TSpecializedMethod; static;
class procedure RegisterStaticSpecialization(