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
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(