Michael Schimmel
739 lines
24 KiB
ObjectPascal
739 lines
24 KiB
ObjectPascal
unit Myc.Ast.RTL;
|
|
|
|
interface
|
|
|
|
// This unit is intended to be included in a 'uses' clause.
|
|
// It self-registers its functions via its initialization section.
|
|
|
|
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.Types;
|
|
|
|
type
|
|
// Defines the export parameters for a native RTL function.
|
|
TRtlExportAttribute = class(TCustomAttribute)
|
|
public
|
|
Name: 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;
|
|
IsPure: Boolean; // (* ADDED *)
|
|
constructor Create(const ATarget: TDataValue.TFunc; const AReturnType: IStaticType; AIsPure: Boolean);
|
|
end;
|
|
|
|
// The cache holding TDataValue.TFunc wrappers for static native functions.
|
|
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);
|
|
|
|
implementation
|
|
|
|
uses
|
|
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 TRtlExportAttribute.Create(const AName: string);
|
|
begin
|
|
inherited Create;
|
|
Self.Name := AName;
|
|
Self.IsPure := False; // Default to impure (safe)
|
|
end;
|
|
|
|
constructor TRtlExportAttribute.Create(const AName: string; AIsPure: Boolean);
|
|
begin
|
|
inherited Create;
|
|
Self.Name := AName;
|
|
Self.IsPure := AIsPure;
|
|
end;
|
|
|
|
{ TStaticSignatureKey }
|
|
|
|
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;
|
|
|
|
Result := True;
|
|
end;
|
|
|
|
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;
|
|
|
|
{ TSpecializedMethod }
|
|
|
|
constructor TSpecializedMethod.Create(const ATarget: TDataValue.TFunc; const AReturnType: IStaticType; AIsPure: Boolean);
|
|
begin
|
|
Target := ATarget;
|
|
ReturnType := AReturnType;
|
|
IsPure := AIsPure;
|
|
end;
|
|
|
|
{ TRtlRegistry }
|
|
|
|
class constructor TRtlRegistry.Create;
|
|
var
|
|
ctx: TRttiContext;
|
|
rtlType: TRttiType;
|
|
method: TRttiMethod;
|
|
attribute: TCustomAttribute;
|
|
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
|
|
ctx := TRttiContext.Create;
|
|
try
|
|
rtlType := ctx.GetType(TypeInfo(TRtlFunctions));
|
|
|
|
for method in rtlType.GetMethods do
|
|
begin
|
|
if method.MethodKind <> mkClassFunction then
|
|
continue;
|
|
|
|
exportAttr := nil;
|
|
for attribute in method.GetAttributes do
|
|
begin
|
|
if attribute is TRtlExportAttribute then
|
|
begin
|
|
exportAttr := attribute as TRtlExportAttribute;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
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) 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;
|
|
funcInfo.DynamicWrapper := wrapperFactory(method.CodeAddress);
|
|
end
|
|
else
|
|
begin
|
|
// This is a STATIC SPECIALIZATION
|
|
if not ParseStaticSuffix(method.Name, argTypes, retType) then
|
|
begin
|
|
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
|
|
// (* UPDATED: Capture IsPure from attribute *)
|
|
methodRecord := TSpecializedMethod.Create(wrapper, retType, exportAttr.IsPure);
|
|
RegisterStaticSpecialization(rtlName, argTypes, methodRecord);
|
|
end
|
|
else
|
|
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);
|
|
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;
|
|
|
|
initialization
|
|
// Register this library's functions with the central AST factory.
|
|
TAst.RegisterLibrary(RegisterRtlFunctions);
|
|
|
|
end.
|