unit Myc.Ast.RTL; interface uses System.SysUtils, System.Generics.Collections, System.Generics.Defaults, System.Rtti, System.TypInfo, Myc.Data.Scalar, Myc.Data.Value, Myc.Ast, Myc.Ast.Scope, Myc.Ast.Nodes, Myc.Ast.Types; type //============================================================================================== // Internal Structures //============================================================================================== // Key used to identify specific overloads of a function based on argument types. TStaticSignatureKey = record public Name: string; ArgTypes: TArray; constructor Create(const AName: string; const AArgTypes: TArray); end; // Equality comparer for TStaticSignatureKey to be used in dictionaries. TStaticSignatureKeyComparer = class(TEqualityComparer) public function Equals(const Left, Right: TStaticSignatureKey): Boolean; override; function GetHashCode(const Value: TStaticSignatureKey): Integer; override; end; // Holds a reference to a specialized, type-safe native function wrapper. TSpecializedMethod = record public Target: TDataValue.TFunc; ReturnType: IStaticType; IsPure: Boolean; constructor Create(const ATarget: TDataValue.TFunc; const AReturnType: IStaticType; AIsPure: Boolean); end; // Cache for static specializations. TStaticBootstrapCache = TDictionary; // Metadata for a registered function, including dynamic fallback and signatures. TRtlFunctionInfo = class public DynamicWrapper: TDataValue.TFunc; Signatures: TList; Doc: string; constructor Create; destructor Destroy; override; end; TRtlFunctionMap = TDictionary; // Metadata for a registered constant. TRtlConstantInfo = record Name: string; Value: TDataValue; StaticType: IStaticType; Doc: string; constructor Create(const AName: string; const AValue: TDataValue; const AType: IStaticType; const ADoc: string); end; //============================================================================================== // RTL Registry //============================================================================================== // Central registry logic using RTTI to scan provider classes. TRtlRegistry = record private // Function pointer types for static wrappers type TNativeDataValueFunc = function(const Args: TArray): TDataValue; TNativeScalarFunc = function(Arg: TScalar): TScalar; TNativeFunc_O_O = function(A: Int64): Int64; TNativeFunc_F_F = function(A: Double): Double; TNativeFunc_F_O = function(A: Double): Int64; TNativeFunc_O_F = function(A: Int64): Double; TNativeFunc_V_F = function(): Double; 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; TNativeFunc_TT_T = function(const A: String; const B: String): String; private class var FStaticBootstrap: TStaticBootstrapCache; FStaticFuncMap: TRtlFunctionMap; FStaticConstList: TList; class constructor Create; class destructor Destroy; // Wrapper generators for specific function signatures 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_O_F(CodeAddress: Pointer): TDataValue.TFunc; static; class function CreateWrapper_V_F(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 CreateWrapper_TT_T(CodeAddress: Pointer): TDataValue.TFunc; static; // Helpers class function TValueToDataValue(const V: TValue): TDataValue; static; class function RttiTypeToStaticType(const AType: TRttiType): IStaticType; static; class function ParseStaticSuffix( const AMethodName: string; out AArgTypes: TArray; out AReturnType: IStaticType ): Boolean; static; class function CreateStaticWrapper( method: TRttiMethod; retType: IStaticType; argTypes: TArray; rttiParams: TArray ): TDataValue.TFunc; static; public // Scans a specific provider type for attributes and registers them internally. class procedure Scan; static; // Dumps all registered functions and constants into the execution scope. class procedure RegisterAll(const AScope: IExecutionScope); static; // API for the type checker to retrieve specialized methods. class function GetStaticSpecialization(const AName: string; const AArgTypes: TArray): TSpecializedMethod; static; class procedure RegisterStaticSpecialization( const AName: string; const AArgTypes: TArray; const AMethod: TSpecializedMethod ); static; end; // Main entry point for library registration. procedure RegisterRtlFunctions(const AScope: IExecutionScope); implementation uses System.Hash, System.StrUtils, Myc.Ast.Attributes, Myc.Ast.RTL.Core, Myc.Ast.RTL.Math, Myc.Ast.RTL.Series, Myc.Ast.RTL.DateTime; //================================================================================================== // Helper Structure Implementations //================================================================================================== constructor TStaticSignatureKey.Create(const AName: string; const AArgTypes: TArray); begin Name := AName; ArgTypes := AArgTypes; end; 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); for i := 0 to High(Left.ArgTypes) do if not Left.ArgTypes[i].IsEqual(Right.ArgTypes[i]) then exit(False); Result := True; end; function TStaticSignatureKeyComparer.GetHashCode(const Value: TStaticSignatureKey): Integer; var i, hash, ptrHash: Integer; begin hash := THashBobJenkins.GetHashValue(Value.Name); 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; constructor TRtlFunctionInfo.Create; begin inherited Create; Signatures := TList.Create; DynamicWrapper := nil; Doc := ''; end; destructor TRtlFunctionInfo.Destroy; begin Signatures.Free; inherited Destroy; end; constructor TRtlConstantInfo.Create(const AName: string; const AValue: TDataValue; const AType: IStaticType; const ADoc: string); begin Name := AName; Value := AValue; StaticType := AType; Doc := ADoc; end; constructor TSpecializedMethod.Create(const ATarget: TDataValue.TFunc; const AReturnType: IStaticType; AIsPure: Boolean); begin Target := ATarget; ReturnType := AReturnType; IsPure := AIsPure; end; //================================================================================================== // TRtlRegistry Implementation //================================================================================================== class constructor TRtlRegistry.Create; begin FStaticBootstrap := TStaticBootstrapCache.Create(TStaticSignatureKeyComparer.Create); FStaticFuncMap := TRtlFunctionMap.Create; FStaticConstList := TList.Create; end; class destructor TRtlRegistry.Destroy; var funcInfo: TRtlFunctionInfo; begin for funcInfo in FStaticFuncMap.Values do funcInfo.Free; FStaticFuncMap.Free; FStaticConstList.Free; FStaticBootstrap.Free; end; class procedure TRtlRegistry.Scan; var ctx: TRttiContext; typ: TRttiType; method: TRttiMethod; attribute: TCustomAttribute; exportAttr: TRtlExportAttribute; constAttr: TRtlConstAttribute; docString, rtlName: string; argTypes: TArray; retType: IStaticType; methodRecord: TSpecializedMethod; funcInfo: TRtlFunctionInfo; constInfo: TRtlConstantInfo; rttiParams: TArray; isDynamic: Boolean; i: Integer; begin ctx := TRttiContext.Create; try typ := ctx.GetType(TypeInfo(T)); if typ = nil then exit; for method in typ.GetMethods do begin if method.MethodKind <> mkClassFunction then continue; exportAttr := nil; constAttr := nil; docString := ''; // Extract attributes for attribute in method.GetAttributes do begin if attribute is TRtlExportAttribute then exportAttr := attribute as TRtlExportAttribute else if attribute is TRtlConstAttribute then constAttr := attribute as TRtlConstAttribute else if attribute is AstDocAttribute then docString := AstDocAttribute(attribute).Description; end; // --- CASE A: CONSTANT (via class function) --- if Assigned(constAttr) then begin var val: TValue := method.Invoke(nil, []); var dataVal: TDataValue := TValueToDataValue(val); var staticType: IStaticType := RttiTypeToStaticType(method.ReturnType); constInfo := TRtlConstantInfo.Create(constAttr.Name, dataVal, staticType, docString); FStaticConstList.Add(constInfo); continue; end; // --- CASE B: FUNCTION --- 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; if (funcInfo.Doc = '') and (docString <> '') then funcInfo.Doc := docString; rttiParams := method.GetParameters; isDynamic := (Length(rttiParams) = 1) and (method.ReturnType.Handle = TypeInfo(TDataValue)) and (rttiParams[0].ParamType.Handle = TypeInfo(TArray)); if isDynamic then begin // Dynamic wrapper (Interpreted mode) 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 begin Result := TNativeDataValueFunc(CodeAddress)(Args); end; end; funcInfo.DynamicWrapper := wrapperFactory(method.CodeAddress); end else begin // Static wrapper (Compiled mode / Fast path) if not ParseStaticSuffix(method.Name, argTypes, retType) then begin // Fallback to RTTI if name convention fails 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 methodRecord := TSpecializedMethod.Create(wrapper, retType, exportAttr.IsPure); RegisterStaticSpecialization(rtlName, argTypes, methodRecord); // Use static wrapper as fallback for interpreter if no dynamic wrapper exists if (not Assigned(funcInfo.DynamicWrapper)) and (Length(argTypes) = 1) and (argTypes[0].Kind = stUnknown) then funcInfo.DynamicWrapper := wrapper; end else raise ENotImplemented.CreateFmt('Wrapper for %s not implemented', [method.Name]); end; end; finally ctx.Free; end; end; class function TRtlRegistry.TValueToDataValue(const V: TValue): TDataValue; begin case V.Kind of tkInteger, tkInt64: Result := TScalar.FromInt64(V.AsInt64); tkFloat: Result := TScalar.FromDouble(V.AsType); tkChar, tkString, tkUString, tkWString: Result := V.AsString; tkEnumeration: if V.TypeInfo = TypeInfo(Boolean) then Result := TScalar.FromBoolean(V.AsBoolean) else Result := TScalar.FromInt64(V.AsOrdinal); else Result := TDataValue.Void; end; end; // --- Wrapper Implementations --- class function TRtlRegistry.CreateWrapper_O_O(CodeAddress: Pointer): TDataValue.TFunc; begin Result := function(const Args: TArray): TDataValue var A, 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 var A, 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 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_O_F(CodeAddress: Pointer): TDataValue.TFunc; begin Result := function(const Args: TArray): TDataValue var A: Int64; Res: Double; begin A := Args[0].AsScalar.Value.AsInt64; Res := TNativeFunc_O_F(CodeAddress)(A); Result := TDataValue(TScalar.FromDouble(Res)); end; end; class function TRtlRegistry.CreateWrapper_V_F(CodeAddress: Pointer): TDataValue.TFunc; begin Result := function(const Args: TArray): TDataValue var Res: Double; begin Res := TNativeFunc_V_F(CodeAddress)(); Result := TDataValue(TScalar.FromDouble(Res)); end; end; class function TRtlRegistry.CreateWrapper_OO_O(CodeAddress: Pointer): TDataValue.TFunc; begin Result := function(const Args: TArray): 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 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 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 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 var A: Int64; B, 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 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 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 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.CreateWrapper_TT_T(CodeAddress: Pointer): TDataValue.TFunc; begin Result := function(const Args: TArray): TDataValue var A, B: String; begin A := Args[0].AsText; B := Args[1].AsText; Result := TNativeFunc_TT_T(CodeAddress)(A, B); end; 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 Result := TTypes.Unknown; end; class function TRtlRegistry.ParseStaticSuffix( const AMethodName: string; out AArgTypes: TArray; out AReturnType: IStaticType ): Boolean; var parts: TArray; i: Integer; 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 if SameText(S, 'Boolean') then Result := TTypes.Boolean else if SameText(S, 'DateTime') then Result := TTypes.DateTime else Result := TTypes.Unknown; end; begin Result := False; AReturnType := TTypes.Unknown; AArgTypes := nil; parts := AMethodName.Split(['_']); // Format: Name_Arg1_Arg2_Return 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 AArgTypes[i - 1] := ParseType(parts[i]); if AArgTypes[i - 1].Kind = stUnknown then begin AArgTypes := nil; exit(False); end; end; Result := True; end; class function TRtlRegistry.CreateStaticWrapper( method: TRttiMethod; retType: IStaticType; argTypes: TArray; rttiParams: TArray ): TDataValue.TFunc; var ptr: Pointer; begin Result := nil; ptr := method.CodeAddress; case Length(argTypes) of 0: if retType.Kind = stFloat then Result := CreateWrapper_V_F(ptr); 1: 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 = stOrdinal) and (retType.Kind = stFloat) then Result := CreateWrapper_O_F(ptr) else if (argTypes[0].Kind = stUnknown) and (rttiParams[0].ParamType.Handle = TypeInfo(TScalar)) then begin var wrapperFactory := function(CodeAddress: Pointer): TDataValue.TFunc begin Result := function(const Args: TArray): TDataValue begin if (Length(Args) <> 1) or (Args[0].Kind <> vkScalar) then raise EArgumentException.Create('Invalid argument'); Result := TDataValue(TNativeScalarFunc(CodeAddress)(Args[0].AsScalar)); end; end; Result := wrapperFactory(ptr); end; 2: 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); 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); 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); 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); end else if (k1 = stKeyword) and (k2 = stKeyword) and (rk = stOrdinal) then Result := CreateWrapper_OO_O(ptr) else if (k1 = stText) and (k2 = stText) then Result := CreateWrapper_TT_T(ptr); end; end; end; class function TRtlRegistry.GetStaticSpecialization(const AName: string; const AArgTypes: TArray): 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; const AMethod: TSpecializedMethod ); var key: TStaticSignatureKey; begin key := TStaticSignatureKey.Create(AName, AArgTypes); FStaticBootstrap.AddOrSetValue(key, AMethod); end; class procedure TRtlRegistry.RegisterAll(const AScope: IExecutionScope); var rtlName: string; funcInfo: TRtlFunctionInfo; constInfo: TRtlConstantInfo; staticType: IStaticType; pair: TPair; 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; AScope.Define(rtlName, funcInfo.DynamicWrapper, staticType, funcInfo.Doc); end; for constInfo in FStaticConstList do AScope.Define(constInfo.Name, constInfo.Value, constInfo.StaticType, constInfo.Doc); end; procedure RegisterRtlFunctions(const AScope: IExecutionScope); begin TRtlRegistry.RegisterAll(AScope); end; initialization TRtlRegistry.Scan; TRtlRegistry.Scan; TRtlRegistry.Scan; TRtlRegistry.Scan; TAst.RegisterLibrary(RegisterRtlFunctions); end.