diff --git a/ASTPlayground/Script.txt b/ASTPlayground/Script.txt index 09e0d2d..c255c9a 100644 --- a/ASTPlayground/Script.txt +++ b/ASTPlayground/Script.txt @@ -1,73 +1,103 @@ (do - ;; --------------------------------------------------------- - ;; 1. Hilfsfunktion: Berechnet den WMA für einen gegebenen - ;; Zeitpunkt auf einer Series. - ;; --------------------------------------------------------- - (def calc-wma - (fn [s len] - (do - (def cnt (count s)) - ;; Wenn nicht genug Daten da sind, gib 0 oder den letzten Wert zurück - (if (< cnt len) - 0.0 - (do - ;; Summe der Gewichte: n * (n + 1) / 2 - (def weight-sum (/ (* len (+ len 1)) 2)) - - ;; Rekursive Berechnung der gewichteten Summe - ;; Wir iterieren von 0 bis len-1 rückwärts - (def w-total - ((fn [i acc] - (if (>= i len) - acc - (do - ;; Gewicht: (len - i) -> Höchstes Gewicht für aktuelles Element - (def w (- len i)) - ;; Wert holen: (get s (count - 1 - i)) - (def val (get s (- (- cnt 1) i))) - ;; Tail-Recursion - (recur (+ i 1) (+ acc (* w val))) - ))) - 0 0.0)) ;; Start bei i=0, acc=0.0 - - ;; Ergebnis: Gewichtete Summe / Summe der Gewichte - (/ w-total weight-sum) - ))))) + ;; =========================================================================== + ;; 1. DEFINITIONEN (Wie zuvor besprochen) + ;; =========================================================================== - ;; --------------------------------------------------------- - ;; 2. Die HMA Factory - ;; --------------------------------------------------------- + ;; --- WMA Factory (O(1)) --- + (def create-wma + (fn [len] + (do + (def prev-w-sum 0.0) + (def prev-s-sum 0.0) + (def weight-div (/ (* len (+ len 1)) 2)) + + (fn [src] + (do + (def cnt (count src)) + (if (< cnt (+ len 1)) + 0.0 + (do + (def val-new (get src 0)) + (def val-out (get src len)) + (def w-sum (+ prev-w-sum (- (* len val-new) prev-s-sum))) + (def s-sum (+ (- prev-s-sum val-out) val-new)) + (assign prev-w-sum w-sum) + (assign prev-s-sum s-sum) + (/ w-sum weight-div) + )) + )) + ))) + + ;; --- HMA Factory --- (def create-hma (fn [len] (do - ;; Konstanten vorberechnen (def half-len (round (/ len 2))) (def sqrt-len (round (sqrt len))) + (def wma-half (create-wma half-len)) + (def wma-full (create-wma len)) + (def wma-smooth (create-wma sqrt-len)) + (def diff-series (new-series [[:val :Float]])) - ;; !!! WICHTIG !!! - ;; HMA benötigt eine Glättung der Differenz. - ;; Da 'calc-wma' eine Series als Input erwartet, müssen wir - ;; die Zwischenwerte (diff) in einer eigenen Series speichern. - ;; Diese Series wird in der Closure "gefangen" (captured). - (def diff-series (new-series :Float)) - - ;; Die eigentliche Funktion, die zurückgegeben wird - (fn [source-series] + (fn [src] (do - ;; Schritt 1: WMA(n/2) * 2 - (def wma-half (calc-wma source-series half-len)) - - ;; Schritt 2: WMA(n) - (def wma-full (calc-wma source-series len)) - - ;; Schritt 3: Differenz berechnen - (def diff (- (* 2 wma-half) wma-full)) - - ;; Schritt 4: Differenz in die interne Series schieben - (add-item diff-series diff) - - ;; Schritt 5: WMA(sqrt(n)) auf der Differenz-Series berechnen - (calc-wma diff-series sqrt-len) + (def v1 (wma-half src)) + (def v2 (wma-full src)) + (def diff (- (* 2 v1) v2)) + (add-item diff-series {:val diff}) + (wma-smooth (get diff-series :val)) )) ))) + + ;; --- Repeat Macro --- + (defmacro repeat [n body] + `((fn [cnt] + (if (> cnt 0) + (do + ~body + (recur (- cnt 1))))) + ~n)) + + ;; =========================================================================== + ;; 2. SIMULATION & TEST + ;; =========================================================================== + + ;; Konfiguration + (def hma-length 14) + (def simulation-steps 50) + + ;; Initialisierung der Komponenten + (def hma-calc (create-hma hma-length)) ; Die HMA-Closure + (def prices (new-series [[:close :Float]])) ; Die Preis-Series + (def current-price 100.0) ; Startpreis + + ;; Header Ausgabe (falls print verfügbar ist) + (print "Step | Price | HMA(14)") + (print "-----|----------|----------") + + ;; Simulations-Schleife + (repeat simulation-steps + (do + ;; 1. Preis simulieren (Random Walk) + ;; (random) gibt 0.0 bis 1.0 zurück. + ;; (- (random) 0.5) erzeugt eine Änderung zwischen -0.5 und +0.5 + (assign current-price (+ current-price (- (random) 0.5))) + + ;; 2. Preis zur Series hinzufügen + (add-item prices {:close current-price}) + + ;; 3. HMA berechnen + (def hma-val 0.0) + + ;; 3. HMA berechnen + (def price-series (get prices :close)) + (assign hma-val (hma-calc price-series)) + + ;; 4. Ausgabe + ;; Wir geben nur Werte aus, wenn der HMA "eingeschwungen" ist (Wert > 0) + (if (> hma-val 0.0) + (print (count prices) " |" current-price " | " hma-val) + (print (count prices) " |" current-price " | (warming up...)")) + ) + ) ) \ No newline at end of file diff --git a/Src/AST/Myc.Ast.Compiler.TypeChecker.pas b/Src/AST/Myc.Ast.Compiler.TypeChecker.pas index ddda86c..a1e7cf8 100644 --- a/Src/AST/Myc.Ast.Compiler.TypeChecker.pas +++ b/Src/AST/Myc.Ast.Compiler.TypeChecker.pas @@ -897,43 +897,56 @@ begin // Case 2: Record Series, e.g. (new-series [[:Price :Float] [:Vol :Ordinal]]) tuple := defNode.AsTuple; elements := tuple.Elements; - SetLength(fields, Length(elements)); - for i := 0 to High(elements) do + if Length(elements) > 0 then begin - if elements[i].Kind <> akTuple then + // check format first + var failed := false; + for i := 0 to High(elements) do begin - if Assigned(FLog) then - FLog.AddError('Record definition elements must be vectors [Key Type]', elements[i]); - continue; + if elements[i].Kind <> akTuple then + begin + failed := true; + if Assigned(FLog) then + FLog.AddError('Record definition elements must be vectors [Key Type]', elements[i]); + break; + end; + + fieldTuple := elements[i].AsTuple; + if Length(fieldTuple.Elements) <> 2 then + begin + failed := true; + if Assigned(FLog) then + FLog.AddError('Record definition entry must have exactly 2 elements [Key Type]', fieldTuple); + break; + end; + + if (fieldTuple.Elements[0].Kind <> akKeyword) or (fieldTuple.Elements[1].Kind <> akKeyword) then + begin + failed := true; + if Assigned(FLog) then + FLog.AddError('Record definition keys and types must be keywords', fieldTuple); + break; + end; end; - fieldTuple := elements[i].AsTuple; - if Length(fieldTuple.Elements) <> 2 then + if not failed then begin - if Assigned(FLog) then - FLog.AddError('Record definition entry must have exactly 2 elements [Key Type]', fieldTuple); - continue; + SetLength(fields, Length(elements)); + + for i := 0 to High(elements) do + begin + fieldTuple := elements[i].AsTuple; + keyNode := fieldTuple.Elements[0].AsKeyword; + typeNode := fieldTuple.Elements[1].AsKeyword; + + elemKind := TScalar.StringToKind(typeNode.Value.Name); + fields[i] := TPair.Create(keyNode.Value, elemKind); + end; + + recDef := TKeywordMappingRegistry.Intern(fields); + resType := TTypes.CreateRecordSeries(recDef); end; - - if (fieldTuple.Elements[0].Kind <> akKeyword) or (fieldTuple.Elements[1].Kind <> akKeyword) then - begin - if Assigned(FLog) then - FLog.AddError('Record definition keys and types must be keywords', fieldTuple); - continue; - end; - - keyNode := fieldTuple.Elements[0].AsKeyword; - typeNode := fieldTuple.Elements[1].AsKeyword; - - elemKind := TScalar.StringToKind(typeNode.Value.Name); - fields[i] := TPair.Create(keyNode.Value, elemKind); - end; - - if Length(fields) > 0 then - begin - recDef := TKeywordMappingRegistry.Intern(fields); - resType := TTypes.CreateRecordSeries(recDef); end; end else diff --git a/Src/AST/Myc.Ast.Evaluator.pas b/Src/AST/Myc.Ast.Evaluator.pas index 9b8eab2..758dae7 100644 --- a/Src/AST/Myc.Ast.Evaluator.pas +++ b/Src/AST/Myc.Ast.Evaluator.pas @@ -347,31 +347,51 @@ end; function TEvaluatorVisitor.VisitIndexer(const N: IIndexerNode): TDataValue; var - base, idx: TDataValue; + base: TDataValue; begin base := Visit(N.Base); if base.IsVoid then exit(TDataValue.Void); - idx := Visit(N.Index); case base.Kind of vkSeries: begin + var idx := Visit(N.Index); var i: Integer := idx.AsScalar.Value.AsInt64; + var series := base.AsSeries; + if (i < 0) or (i >= series.Count) then + raise EEvaluatorException.CreateFmt('Series index %d out of bounds (series contains %d items).', [i, series.Count]); Result := base.AsSeries[i]; end; vkRecordSeries: begin - var i: Integer := idx.AsScalar.Value.AsInt64; var rs := base.AsRecordSeries; - var vals: TArray; - SetLength(vals, rs.Def.Count); - for var k := 0 to rs.Def.Count - 1 do - vals[k] := rs.Fields[rs.Def.Keywords[k]].Items[i].Value; - Result := TScalarRecord.Create(rs.Def, vals); + + if N.Index.Kind = akKeyword then + begin + Result := rs.Fields[TKeywordRegistry.GetKeyword(Visit(N.Index).AsScalar.Value.AsInt64)]; + end + else + begin + var idx := Visit(N.Index); + var i: Integer := idx.AsScalar.Value.AsInt64; + var vals: TArray; + SetLength(vals, rs.Def.Count); + for var k := 0 to rs.Def.Count - 1 do + begin + var series := rs.Fields[rs.Def.Keywords[k]]; + if (i < 0) or (i >= series.Count) then + raise EEvaluatorException.CreateFmt( + 'Record index %d out of bounds (series <%s> contains %d items).', + [i, rs.Keywords[k].Name, series.Count]); + vals[k] := series[i].Value; + end; + Result := TScalarRecord.Create(rs.Def, vals); + end; end; vkTuple: begin + var idx := Visit(N.Index); var i: Integer := idx.AsScalar.Value.AsInt64; var tpl := base.AsTuple; if (i < 0) or (i >= tpl.Count) then @@ -491,7 +511,38 @@ begin var lb: Int64 := -1; if Assigned(N.Lookback) then lb := Visit(N.Lookback).AsScalar.Value.AsInt64; - FScope[N.Series.Address].AsRecordSeries.Add(Visit(N.Value).AsScalarRecord, lb); + + var series := FScope[N.Series.Address]; + + case series.Kind of + vkSeries: raise EEvaluatorException.Create(N.Series.Name + ' is read-only. Use a record series instead.'); + vkRecordSeries: + begin + var rec := Visit(N.Value); + case rec.Kind of + vkScalarRecord: series.AsRecordSeries.Add(rec.AsScalarRecord, lb); + vkRecord: + begin + // Type inference didn't manage to infer static record type. + var r := rec.AsRecord; + var vals: TArray; + SetLength(vals, r.Count); + for var i := 0 to r.Count - 1 do + begin + if r[i].Kind <> vkScalar then + raise EEvaluatorException.Create('Scalar record expected.'); + vals[i] := r[i].AsScalar.Value; + end; + series.AsRecordSeries.Add(vals); + end + else + raise EEvaluatorException.Create('Adding ' + rec.Kind.ToString + ' to record series not allowed.'); + end; + end + else + raise EEvaluatorException.Create('Record series expected.'); + end; + Result := TDataValue.Void; end; diff --git a/Src/AST/Myc.Ast.RTL.Core.pas b/Src/AST/Myc.Ast.RTL.Core.pas index 7934fef..48cb7be 100644 --- a/Src/AST/Myc.Ast.RTL.Core.pas +++ b/Src/AST/Myc.Ast.RTL.Core.pas @@ -19,6 +19,16 @@ type { Contains the native implementations for the Myc standard library. } TRtlFunctions = record public + // --- Constants --- + + // Konstanten werden als statische Funktionen ohne Parameter implementiert. + // Das TRtlConst-Attribut sorgt dafür, dass der Rückgabewert beim Start + // evaluiert und in den Scope eingetragen wird. + + [TRtlConst('NaN')] + [AstDoc('Not a Number (IEEE 754).')] + class function Const_NaN: Double; static; + // --- Arithmetic --- [TRtlExport('+', Pure)] @@ -163,6 +173,12 @@ type [AstSignature('(number, number) -> number')] class function Pow(const Args: TArray): TDataValue; static; + [TRtlExport('random', Impure)] + [AstDoc('Returns a random number. No args: [0..1). Arg N: Integer [0..N).')] + [AstSignature('() -> float')] + [AstSignature('(number) -> number')] + class function Random(const Args: TArray): TDataValue; static; + // --- DateTime --- [TRtlExport('now', Impure)] @@ -350,10 +366,22 @@ type class function Pow_Ordinal_Float_Float(A: Int64; B: Double): Double; static; [TRtlExport('pow', Pure)] class function Pow_Float_Ordinal_Float(A: Double; B: Int64): Double; static; + + [TRtlExport('random', Impure)] + class function Random_Void_Float: Double; static; + [TRtlExport('random', Impure)] + class function Random_Ordinal_Ordinal(Limit: Int64): Int64; static; end; implementation +{ TRtlFunctions - Constants } + +class function TRtlFunctions.Const_NaN: Double; +begin + Result := System.Math.NaN; +end; + { TRtlFunctions - Operator Implementations } class function TRtlFunctions.Add(const Args: TArray): TDataValue; @@ -576,6 +604,16 @@ begin Result := TScalar.FromDouble(System.Math.Power(baseVal, expVal)); end; +class function TRtlFunctions.Random(const Args: TArray): TDataValue; +begin + if Length(Args) = 0 then + Result := TScalar.FromDouble(System.Random) + else if (Length(Args) = 1) and (Args[0].AsScalar.Kind = TScalar.TKind.Ordinal) then + Result := TScalar.FromInt64(System.Random(Integer(Args[0].AsScalar.Value.AsInt64))) + else + raise EArgumentException.Create('Random expects 0 arguments or 1 integer argument.'); +end; + // --- Date Constructors --- class function TRtlFunctions.Now(const Args: TArray): TDataValue; @@ -1094,4 +1132,14 @@ begin Result := System.Math.Power(A, B); end; +class function TRtlFunctions.Random_Void_Float: Double; +begin + Result := System.Random; +end; + +class function TRtlFunctions.Random_Ordinal_Ordinal(Limit: Int64): Int64; +begin + Result := System.Random(Limit); +end; + end. diff --git a/Src/AST/Myc.Ast.RTL.pas b/Src/AST/Myc.Ast.RTL.pas index 62dd9fe..ba9ba65 100644 --- a/Src/AST/Myc.Ast.RTL.pas +++ b/Src/AST/Myc.Ast.RTL.pas @@ -10,6 +10,7 @@ uses System.Generics.Collections, System.Generics.Defaults, System.Rtti, + System.TypInfo, Myc.Data.Scalar, Myc.Data.Value, Myc.Ast, @@ -29,6 +30,14 @@ type constructor Create(const AName: string; APurity: TPurity); overload; end; + // Defines a constant export (via class function). + // The registry will INVOKE this function at startup and register the RESULT as a value. + TRtlConstAttribute = class(TCustomAttribute) + public + Name: string; + constructor Create(const AName: string); + end; + // Defines the key for the static bootstrap cache. type TStaticSignatureKey = record @@ -67,6 +76,15 @@ type TRtlFunctionMap = TDictionary; + // Container for constant metadata + 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; + //-------------------------------------------------------------------------------------------------- //== Library Registration (RTTI-based) //-------------------------------------------------------------------------------------------------- @@ -79,6 +97,7 @@ type 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; @@ -95,6 +114,9 @@ type FStaticBootstrap: TStaticBootstrapCache; class var FStaticFuncMap: TRtlFunctionMap; + class var + FStaticConstList: TList; + class constructor Create; class destructor Destroy; @@ -103,6 +125,7 @@ type 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; @@ -115,6 +138,8 @@ type // --- RTTI Helpers --- class function RttiTypeToStaticType(const AType: TRttiType): IStaticType; static; + class function TValueToDataValue(const V: TValue): TDataValue; static; + class function ParseStaticSuffix( const AMethodName: string; out AArgTypes: TArray; @@ -145,7 +170,6 @@ procedure RegisterRtlFunctions(const AScope: IExecutionScope); implementation uses - System.TypInfo, System.Hash, System.StrUtils, Myc.Ast.Attributes, @@ -173,6 +197,14 @@ begin Self.IsPure := APurity = Pure; end; +{ TRtlConstAttribute } + +constructor TRtlConstAttribute.Create(const AName: string); +begin + inherited Create; + Name := AName; +end; + { TStaticSignatureKey } constructor TStaticSignatureKey.Create(const AName: string; const AArgTypes: TArray); @@ -241,6 +273,16 @@ begin inherited Destroy; end; +{ TRtlConstantInfo } + +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; + { TSpecializedMethod } constructor TSpecializedMethod.Create(const ATarget: TDataValue.TFunc; const AReturnType: IStaticType; AIsPure: Boolean); @@ -252,6 +294,22 @@ end; { TRtlRegistry } +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; + class constructor TRtlRegistry.Create; var ctx: TRttiContext; @@ -259,11 +317,13 @@ var method: TRttiMethod; attribute: TCustomAttribute; exportAttr: TRtlExportAttribute; + constAttr: TRtlConstAttribute; rtlName: string; argTypes: TArray; retType: IStaticType; methodRecord: TSpecializedMethod; funcInfo: TRtlFunctionInfo; + constInfo: TRtlConstantInfo; rttiParams: TArray; isDynamic: Boolean; i: Integer; @@ -272,28 +332,49 @@ begin // 1. Create global caches FStaticBootstrap := TStaticBootstrapCache.Create(TStaticSignatureKeyComparer.Create); FStaticFuncMap := TRtlFunctionMap.Create; + FStaticConstList := TList.Create; // 2. Perform RTTI Scan ctx := TRttiContext.Create; try rtlType := ctx.GetType(TypeInfo(TRtlFunctions)); + // --- SCAN METHODS --- + // Includes Class Functions used as Constants! for method in rtlType.GetMethods do begin if method.MethodKind <> mkClassFunction then continue; exportAttr := nil; + constAttr := nil; docString := ''; 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 + // Since this is a static method (class function), we can invoke it with nil instance + // to get the value immediately. + 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; // Done with this method + end; + + // --- CASE B: FUNCTION --- if not Assigned(exportAttr) then continue; @@ -377,6 +458,7 @@ begin funcInfo.Free; FStaticFuncMap.Free; + FStaticConstList.Free; FStaticBootstrap.Free; end; @@ -484,9 +566,11 @@ class procedure TRtlRegistry.RegisterAll(const AScope: IExecutionScope); var rtlName: string; funcInfo: TRtlFunctionInfo; + constInfo: TRtlConstantInfo; staticType: IStaticType; pair: TPair; begin + // Register Functions for pair in FStaticFuncMap do begin rtlName := pair.Key; @@ -502,6 +586,12 @@ begin // Pass documentation to scope definition AScope.Define(rtlName, wrapper, staticType, funcInfo.Doc); end; + + // Register Constants + for constInfo in FStaticConstList do + begin + AScope.Define(constInfo.Name, constInfo.Value, constInfo.StaticType, constInfo.Doc); + end; end; // --- Wrapper Generation --- @@ -562,6 +652,18 @@ begin 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 := @@ -710,84 +812,91 @@ 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 = 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 + case Length(argTypes) of + 0: 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 - 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); + if retType.Kind = stFloat then + Result := CreateWrapper_V_F(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 + 1: 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 + 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 + // This is the wrapper for: class function(Arg: TScalar): TScalar; + var wrapperFactory := + function(CodeAddress: Pointer): TDataValue.TFunc + begin + Result := + function(const Args: TArray): 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: 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 - else if (k1 = stText) and (k2 = stText) then - begin - Result := CreateWrapper_TT_T(ptr); // e.g. String concat - end - end + 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 + else if (k1 = stText) and (k2 = stText) then + begin + Result := CreateWrapper_TT_T(ptr); // e.g. String concat + end; + end; else - Assert(false, 'fgdfdf'); + Assert(false, 'Wrapper not implemented'); + end; end; procedure RegisterRtlFunctions(const AScope: IExecutionScope); diff --git a/Src/AST/Myc.Fmx.AstEditor.Handlers.Control.pas b/Src/AST/Myc.Fmx.AstEditor.Handlers.Control.pas index dd94877..b9c4c4b 100644 --- a/Src/AST/Myc.Fmx.AstEditor.Handlers.Control.pas +++ b/Src/AST/Myc.Fmx.AstEditor.Handlers.Control.pas @@ -16,8 +16,10 @@ type TBlockExpressionNodeHandler = class(TBaseNodeHandler) private - FExpressionsNode: TAstViewNode; + FExpressions: TList; public + constructor Create(const ANode: IBlockExpressionNode); + destructor Destroy; override; procedure BuildUI(OwnerNode: TAstViewNode); override; function ReconstructAst(OwnerNode: TAstViewNode): IAstNode; override; end; @@ -109,6 +111,18 @@ type implementation +constructor TBlockExpressionNodeHandler.Create(const ANode: IBlockExpressionNode); +begin + inherited Create(ANode); + FExpressions := TList.Create(); +end; + +destructor TBlockExpressionNodeHandler.Destroy; +begin + FExpressions.Free; + inherited Destroy; +end; + { TBlockExpressionNodeHandler } procedure TBlockExpressionNodeHandler.BuildUI(OwnerNode: TAstViewNode); @@ -125,13 +139,39 @@ begin titleLabel := OwnerNode.AddLabel(OwnerNode, 'do'); titleLabel.FontSettings.Font.Style := [TFontStyle.fsBold]; - FExpressionsNode := visu.CallAccept(FNode.Expressions); - FExpressionsNode.Frameless := True; + // OwnerNode.Frameless := True; + // visu := OwnerNode.Visualizer.Clone(OwnerNode, OwnerNode.Visualizer.ExprDepth); + + var elements := FNode.AsBlockExpression.Expressions.Elements; + + for var i := 0 to High(elements) do + begin + // Standard spacing between elements + if i > 0 then + OwnerNode.AddLabel(OwnerNode, ' '); + + var childView := visu.CallAccept(elements[i]); + FExpressions.Add(childView); + end; + + // if Length(elements) = 0 then + // begin + // OwnerNode.AddLabel(OwnerNode, ' '); // spacer + // end; end; function TBlockExpressionNodeHandler.ReconstructAst(OwnerNode: TAstViewNode): IAstNode; +var + newElements: TArray; + i: Integer; begin - Result := TAst.Block(FNode.Identity, FExpressionsNode.CreateAst.AsTuple, FNode.StaticType); + SetLength(newElements, FExpressions.Count); + for i := 0 to FExpressions.Count - 1 do + newElements[i] := FExpressions[i].CreateAst; + + var tpl := TAst.Tuple(FNode.Expressions.Identity, newElements, FNode.Expressions.StaticType); + + Result := TAst.Block(FNode.Identity, tpl, FNode.StaticType); end; { TIfExpressionNodeHandler } diff --git a/Src/Data/Myc.Data.Keyword.pas b/Src/Data/Myc.Data.Keyword.pas index fc58069..5d726a9 100644 --- a/Src/Data/Myc.Data.Keyword.pas +++ b/Src/Data/Myc.Data.Keyword.pas @@ -45,6 +45,8 @@ type class function Intern(const AName: string): IKeyword; static; // Gets the name for a given keyword index. class function GetName(AIdx: Integer): string; static; + // Gets the keyword for a given keyword index. + class function GetKeyword(AIdx: Integer): IKeyword; static; end; // Defines a mapping from Keywords to a generic value T @@ -144,6 +146,11 @@ begin FReverseMap.Free; end; +class function TKeywordRegistry.GetKeyword(AIdx: Integer): IKeyword; +begin + Result := FReverseMap[AIdx]; +end; + class function TKeywordRegistry.Intern(const AName: string): IKeyword; var idx: Integer; diff --git a/Src/Data/Myc.Data.Value.pas b/Src/Data/Myc.Data.Value.pas index 03d67fc..68e445e 100644 --- a/Src/Data/Myc.Data.Value.pas +++ b/Src/Data/Myc.Data.Value.pas @@ -333,7 +333,12 @@ end; function TDataValue.AsScalarRecord: IKeywordMapping; begin if (FKind <> vkScalarRecord) then - raise EInvalidCast.Create('Cannot read value as Record.'); + begin + if (FKind = vkRecord) then + raise EInvalidCast.Create('Scalar record expected.') + else + raise EInvalidCast.Create('Cannot read value as Record.'); + end; Result := IKeywordMapping(FInterface); end;