Michael Schimmel
525 lines
19 KiB
ObjectPascal
525 lines
19 KiB
ObjectPascal
unit Myc.Ast.RTL.TypeRegistry;
|
|
|
|
interface
|
|
|
|
uses
|
|
System.SysUtils,
|
|
System.Classes,
|
|
System.Rtti,
|
|
System.TypInfo,
|
|
System.Generics.Collections,
|
|
Myc.Data.Value,
|
|
Myc.Data.Scalar,
|
|
Myc.Data.Keyword,
|
|
Myc.Ast.Types,
|
|
Myc.Ast.Scope,
|
|
Myc.Ast.RTL;
|
|
|
|
type
|
|
EInteropException = class(Exception);
|
|
ERecursionException = class(EInteropException);
|
|
|
|
// Factory delegate for Interfaces
|
|
TInterfaceFactoryDelegate<T: IInterface> = reference to function(const Args: TArray<TDataValue>): T;
|
|
|
|
// Central registry mapping Delphi Interfaces to AST static types and handling
|
|
// runtime wrapping (Shadow Records).
|
|
TRtlTypeRegistry = class
|
|
private
|
|
class var
|
|
FCtx: TRttiContext;
|
|
FKnownTypes: TDictionary<PTypeInfo, IStaticType>;
|
|
FAnalysisStack: TList<PTypeInfo>;
|
|
|
|
// --- 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;
|
|
|
|
// --- Marshalling ---
|
|
class function ToTValue(const AData: TDataValue; ATargetType: TRttiType): TValue; static;
|
|
class function FromTValue(const AValue: TValue): TDataValue; static;
|
|
|
|
// --- Wrapping ---
|
|
class function WrapInstance(const Instance: IInterface; TypeInfo: PTypeInfo): TDataValue; static;
|
|
|
|
public
|
|
class constructor Create;
|
|
class destructor Destroy;
|
|
|
|
// --- Registration ---
|
|
// Registers a Delphi Interface type. Raises ERecursionException on cycles.
|
|
class procedure RegisterType<T: IInterface>; overload;
|
|
class procedure RegisterType(Info: PTypeInfo); overload;
|
|
|
|
// --- Factories ---
|
|
// Registers a factory function. T must be registered via RegisterType<T> first.
|
|
class procedure RegisterFactory<T: IInterface>(
|
|
const Scope: IExecutionScope;
|
|
const FactoryName: string;
|
|
const FactoryArgs: TArray<IStaticType>;
|
|
const FactoryDelegate: TInterfaceFactoryDelegate<T>
|
|
);
|
|
|
|
// --- Resolution ---
|
|
class function GetStaticType(Info: PTypeInfo): IStaticType;
|
|
class function ResolveType(RType: TRttiType): IStaticType;
|
|
|
|
class property Context: TRttiContext read FCtx;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
Myc.Ast.Evaluator,
|
|
Myc.Ast.RTL.Core;
|
|
|
|
{ TRtlTypeRegistry }
|
|
|
|
class constructor TRtlTypeRegistry.Create;
|
|
begin
|
|
FCtx := TRttiContext.Create;
|
|
FKnownTypes := TDictionary<PTypeInfo, IStaticType>.Create;
|
|
FAnalysisStack := TList<PTypeInfo>.Create;
|
|
end;
|
|
|
|
class destructor TRtlTypeRegistry.Destroy;
|
|
begin
|
|
FAnalysisStack.Free;
|
|
FKnownTypes.Free;
|
|
FCtx.Free;
|
|
end;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// Type Analysis
|
|
// -----------------------------------------------------------------------------
|
|
|
|
class procedure TRtlTypeRegistry.EnterAnalysis(Info: PTypeInfo);
|
|
begin
|
|
if FAnalysisStack.Contains(Info) then
|
|
raise ERecursionException.CreateFmt('Recursive type definition detected for "%s".', [string(Info.Name)]);
|
|
FAnalysisStack.Add(Info);
|
|
end;
|
|
|
|
class procedure TRtlTypeRegistry.ExitAnalysis(Info: PTypeInfo);
|
|
begin
|
|
FAnalysisStack.Remove(Info);
|
|
end;
|
|
|
|
class procedure TRtlTypeRegistry.RegisterType<T>;
|
|
begin
|
|
RegisterType(TypeInfo(T));
|
|
end;
|
|
|
|
class procedure TRtlTypeRegistry.RegisterType(Info: PTypeInfo);
|
|
begin
|
|
TMonitor.Enter(FKnownTypes);
|
|
try
|
|
if FKnownTypes.ContainsKey(Info) then
|
|
exit;
|
|
|
|
EnterAnalysis(Info);
|
|
try
|
|
var staticType := AnalyzeType(Info);
|
|
FKnownTypes.Add(Info, staticType);
|
|
finally
|
|
ExitAnalysis(Info);
|
|
end;
|
|
finally
|
|
TMonitor.Exit(FKnownTypes);
|
|
end;
|
|
end;
|
|
|
|
class function TRtlTypeRegistry.GetStaticType(Info: PTypeInfo): IStaticType;
|
|
begin
|
|
if not FKnownTypes.TryGetValue(Info, Result) then
|
|
Result := TTypes.Unknown;
|
|
end;
|
|
|
|
class function TRtlTypeRegistry.ResolveType(RType: TRttiType): IStaticType;
|
|
begin
|
|
if not Assigned(RType) then
|
|
exit(TTypes.Void);
|
|
|
|
if FKnownTypes.TryGetValue(RType.Handle, Result) then
|
|
exit;
|
|
|
|
if FAnalysisStack.Contains(RType.Handle) then
|
|
raise ERecursionException.CreateFmt('Recursive type reference detected during resolution of "%s".', [RType.Name]);
|
|
|
|
case RType.TypeKind of
|
|
tkInteger, tkInt64: Result := TTypes.Ordinal;
|
|
tkFloat: Result := TTypes.Float;
|
|
tkString, tkUString, tkWString, tkLString, tkChar, tkWChar: Result := TTypes.Text;
|
|
tkEnumeration:
|
|
if RType.Handle = TypeInfo(Boolean) then
|
|
Result := TTypes.Boolean
|
|
else
|
|
Result := TTypes.Ordinal;
|
|
tkInterface: raise EInteropException.CreateFmt('Interface "%s" is not registered. Call RegisterType first.', [RType.Name]);
|
|
else
|
|
Result := TTypes.Unknown;
|
|
end;
|
|
end;
|
|
|
|
class function TRtlTypeRegistry.AnalyzeType(ATypeInfo: PTypeInfo): IStaticType;
|
|
var
|
|
rType: TRttiType;
|
|
begin
|
|
rType := FCtx.GetType(ATypeInfo);
|
|
case rType.TypeKind of
|
|
// 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>;
|
|
props: TArray<TRttiProperty>;
|
|
fields: TList<TPair<IKeyword, IStaticType>>;
|
|
|
|
function MakeSig(Method: TRttiMethod): IStaticType;
|
|
var
|
|
ps: TArray<TRttiParameter>;
|
|
pTypes: TArray<IStaticType>;
|
|
returnType: IStaticType;
|
|
k: Integer;
|
|
begin
|
|
ps := Method.GetParameters;
|
|
SetLength(pTypes, Length(ps));
|
|
for k := 0 to High(ps) do
|
|
pTypes[k] := ResolveType(ps[k].ParamType);
|
|
|
|
if Assigned(Method.ReturnType) then
|
|
returnType := ResolveType(Method.ReturnType)
|
|
else
|
|
returnType := TTypes.Void;
|
|
|
|
Result := TTypes.CreateMethod(pTypes, returnType);
|
|
end;
|
|
|
|
begin
|
|
fields := TList<TPair<IKeyword, IStaticType>>.Create;
|
|
try
|
|
methods := RType.GetMethods;
|
|
for var m in methods do
|
|
begin
|
|
// Only map standard procedures/functions
|
|
if m.MethodKind in [mkProcedure, mkFunction] then
|
|
fields.Add(TPair<IKeyword, IStaticType>.Create(TKeywordRegistry.Intern(m.Name), MakeSig(m)));
|
|
end;
|
|
|
|
props := RType.GetProperties;
|
|
for var p in props do
|
|
begin
|
|
if p.IsReadable then
|
|
begin
|
|
var propType := ResolveType(p.PropertyType);
|
|
var getterSig := TTypes.CreateMethod([], propType);
|
|
fields.Add(TPair<IKeyword, IStaticType>.Create(TKeywordRegistry.Intern(p.Name), getterSig));
|
|
end;
|
|
end;
|
|
|
|
var def := TGenericRecordRegistry.Intern(fields.ToArray);
|
|
Result := TTypes.CreateGenericRecord(def);
|
|
finally
|
|
fields.Free;
|
|
end;
|
|
end;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// Marshalling
|
|
// -----------------------------------------------------------------------------
|
|
|
|
class function TRtlTypeRegistry.ToTValue(const AData: TDataValue; ATargetType: TRttiType): TValue;
|
|
begin
|
|
case AData.Kind of
|
|
vkScalar:
|
|
begin
|
|
var sc := AData.AsScalar;
|
|
case sc.Kind of
|
|
TScalar.TKind.Ordinal:
|
|
begin
|
|
if ATargetType.Handle = TypeInfo(Integer) then
|
|
Result := TValue.From<Integer>(Integer(sc.Value.AsInt64))
|
|
else if ATargetType.Handle = TypeInfo(Byte) then
|
|
Result := TValue.From<Byte>(Byte(sc.Value.AsInt64))
|
|
else if ATargetType.Handle = TypeInfo(Word) then
|
|
Result := TValue.From<Word>(Word(sc.Value.AsInt64))
|
|
else
|
|
Result := TValue.From<Int64>(sc.Value.AsInt64);
|
|
end;
|
|
TScalar.TKind.Float, TScalar.TKind.DateTime: Result := TValue.From<Double>(sc.Value.AsDouble);
|
|
TScalar.TKind.Boolean: Result := TValue.From<Boolean>(sc.Value.AsInt64 <> 0);
|
|
TScalar.TKind.Keyword:
|
|
if ATargetType.TypeKind in [tkString, tkUString, tkWString, tkLString] then
|
|
Result := TValue.From<String>(TKeywordRegistry.GetName(sc.Value.AsInt64))
|
|
else
|
|
Result := TValue.From<Int64>(sc.Value.AsInt64);
|
|
end;
|
|
end;
|
|
|
|
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;
|
|
end;
|
|
|
|
class function TRtlTypeRegistry.FromTValue(const AValue: TValue): TDataValue;
|
|
begin
|
|
if AValue.IsEmpty then
|
|
exit(TDataValue.Void);
|
|
|
|
case AValue.Kind of
|
|
tkInteger, tkInt64: Result := TScalar.FromInt64(AValue.AsInt64);
|
|
tkFloat: Result := TScalar.FromDouble(AValue.AsExtended);
|
|
tkString, tkUString, tkWString, tkLString: Result := AValue.AsString;
|
|
tkEnumeration:
|
|
if AValue.TypeInfo = TypeInfo(Boolean) then
|
|
Result := TScalar.FromBoolean(AValue.AsBoolean)
|
|
else
|
|
Result := TScalar.FromInt64(AValue.AsOrdinal);
|
|
|
|
// 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;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// Runtime Wrapping (Shadow Record Creation)
|
|
// -----------------------------------------------------------------------------
|
|
|
|
class function TRtlTypeRegistry.WrapInstance(const Instance: IInterface; TypeInfo: PTypeInfo): TDataValue;
|
|
var
|
|
rType: TRttiType;
|
|
rIntf: TRttiInterfaceType;
|
|
recFields: TDictionary<IKeyword, TDataValue>;
|
|
begin
|
|
if Instance = nil then
|
|
exit(TDataValue.Void);
|
|
|
|
rType := FCtx.GetType(TypeInfo);
|
|
if not (rType is TRttiInterfaceType) then
|
|
exit(TDataValue.Void);
|
|
|
|
rIntf := rType as TRttiInterfaceType;
|
|
recFields := TDictionary<IKeyword, TDataValue>.Create;
|
|
try
|
|
// Wrap Methods
|
|
for var m in rIntf.GetMethods do
|
|
begin
|
|
if (m.MethodKind in [mkProcedure, mkFunction]) then
|
|
begin
|
|
var key := TKeywordRegistry.Intern(m.Name);
|
|
|
|
if recFields.ContainsKey(key) then
|
|
raise EInteropException.Create('Overloading not supported');
|
|
|
|
var methodFactory :=
|
|
function(const Instance: IInterface; Meth: TRttiMethod): TDataValue.TFunc
|
|
begin
|
|
var inst := TValue.From(Instance);
|
|
var params := Meth.GetParameters;
|
|
Result :=
|
|
function(const Args: TArray<TDataValue>): TDataValue
|
|
var
|
|
rttiArgs: TArray<TValue>;
|
|
res: TValue;
|
|
i: Integer;
|
|
begin
|
|
if Length(Args) <> Length(params) then
|
|
raise Exception.CreateFmt('Method %s expects %d args', [m.Name, Length(params)]);
|
|
|
|
SetLength(rttiArgs, Length(params));
|
|
for i := 0 to High(params) do
|
|
rttiArgs[i] := ToTValue(Args[i], params[i].ParamType);
|
|
|
|
res := Meth.Invoke(inst, rttiArgs);
|
|
|
|
Result := FromTValue(res);
|
|
end;
|
|
end;
|
|
|
|
recFields.Add(key, methodFactory(Instance, m));
|
|
end;
|
|
end;
|
|
|
|
Result := TDataValue.FromGenericRecord(TKeywordMapping<TDataValue>.Create(recFields.ToArray));
|
|
finally
|
|
recFields.Free;
|
|
end;
|
|
end;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// Factories
|
|
// -----------------------------------------------------------------------------
|
|
|
|
class procedure TRtlTypeRegistry.RegisterFactory<T>(
|
|
const Scope: IExecutionScope;
|
|
const FactoryName: string;
|
|
const FactoryArgs: TArray<IStaticType>;
|
|
const FactoryDelegate: TInterfaceFactoryDelegate<T>
|
|
);
|
|
var
|
|
staticType: IStaticType;
|
|
ti: PTypeInfo;
|
|
begin
|
|
ti := TypeInfo(T);
|
|
staticType := GetStaticType(ti);
|
|
if staticType.Kind = stUnknown then
|
|
raise EInteropException.CreateFmt('Interface "%s" must be registered via RegisterType<T> first.', [string(ti.Name)]);
|
|
|
|
var factoryWrapper: TDataValue.TFunc :=
|
|
function(const Args: TArray<TDataValue>): TDataValue
|
|
var
|
|
instance: T;
|
|
begin
|
|
instance := FactoryDelegate(Args);
|
|
// Result wrapping will handle reference counting via closures
|
|
Result := WrapInstance(instance, ti);
|
|
end;
|
|
|
|
var factorySig := TTypes.CreateMethod(FactoryArgs, staticType);
|
|
Scope.Define(FactoryName, TDataValue(factoryWrapper), factorySig);
|
|
end;
|
|
|
|
end.
|