Brummel/MycLib
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases Wiki Activity

Refactoring streams and fixin various bugs

Browse Source
This commit is contained in:
Michael Schimmel
2026-01-13 16:23:33 +01:00
parent 717a648ad4
commit 1429278765
8 changed files with 481 additions and 178 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ASTPlayground/Script.txt
+91 -61
View File
@@ -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...)"))
)
)
)
Src/AST/Myc.Ast.Compiler.TypeChecker.pas
+43 -30
View File
@@ -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<IKeyword, TScalar.TKind>.Create(keyNode.Value, elemKind);
end;
recDef := TKeywordMappingRegistry<TScalar.TKind>.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<IKeyword, TScalar.TKind>.Create(keyNode.Value, elemKind);
end;
if Length(fields) > 0 then
begin
recDef := TKeywordMappingRegistry<TScalar.TKind>.Intern(fields);
resType := TTypes.CreateRecordSeries(recDef);
end;
end
else
Src/AST/Myc.Ast.Evaluator.pas
+60 -9
View File
@@ -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<TScalar.TValue>;
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<TScalar.TValue>;
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<TScalar.TValue>;
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;
Src/AST/Myc.Ast.RTL.Core.pas
+48
View File
@@ -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>): 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>): 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>): TDataValue;
@@ -576,6 +604,16 @@ begin
Result := TScalar.FromDouble(System.Math.Power(baseVal, expVal));
end;
class function TRtlFunctions.Random(const Args: TArray<TDataValue>): 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>): 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.
Src/AST/Myc.Ast.RTL.pas
+182 -73
View File
@@ -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<string, TRtlFunctionInfo>;
// 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<TRtlConstantInfo>;
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<IStaticType>;
@@ -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<IStaticType>);
@@ -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<Double>);
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<IStaticType>;
retType: IStaticType;
methodRecord: TSpecializedMethod;
funcInfo: TRtlFunctionInfo;
constInfo: TRtlConstantInfo;
rttiParams: TArray<TRttiParameter>;
isDynamic: Boolean;
i: Integer;
@@ -272,28 +332,49 @@ begin
// 1. Create global caches
FStaticBootstrap := TStaticBootstrapCache.Create(TStaticSignatureKeyComparer.Create);
FStaticFuncMap := TRtlFunctionMap.Create;
FStaticConstList := TList<TRtlConstantInfo>.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<string, TRtlFunctionInfo>;
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>): 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>): 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>): 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);
Src/AST/Myc.Fmx.AstEditor.Handlers.Control.pas
+44 -4
View File
@@ -16,8 +16,10 @@ type
TBlockExpressionNodeHandler = class(TBaseNodeHandler<IBlockExpressionNode>)
private
FExpressionsNode: TAstViewNode;
FExpressions: TList<TAstViewNode>;
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<TAstViewNode>.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<IAstNode>;
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 }
Src/Data/Myc.Data.Keyword.pas
+7
View File
@@ -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;
Src/Data/Myc.Data.Value.pas
+6 -1
View File
@@ -333,7 +333,12 @@ end;
function TDataValue.AsScalarRecord: IKeywordMapping<TScalar>;
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<TScalar>(FInterface);
end;