From 624af31243c444bb70fc611ed0829ab08c450e4f Mon Sep 17 00:00:00 2001 From: Michael Schimmel Date: Wed, 24 Sep 2025 10:03:10 +0200 Subject: [PATCH] Added user library --- ASTPlayground/MainForm.fmx | 16 + ASTPlayground/MainForm.pas | 369 +++++++++++++----- ASTPlayground/Myc.Fmx.AstEditor.Workspace.pas | 1 + ASTPlayground/UserLib.json | 85 ++++ IntfExtract/FullApiToClipboard.bat | 1 + Src/AST/Myc.Ast.Binding.pas | 43 +- Src/AST/Myc.Ast.Dumper.pas | 19 +- Src/AST/Myc.Ast.Evaluator.pas | 26 +- Src/AST/Myc.Ast.JSON.pas | 143 +++---- Src/AST/Myc.Ast.Nodes.pas | 32 -- Src/AST/Myc.Ast.RTL.pas | 1 + Src/AST/Myc.Ast.Scope.pas | 109 +++++- Src/AST/Myc.Ast.Visitor.pas | 40 +- Src/AST/Myc.Ast.pas | 5 +- 14 files changed, 585 insertions(+), 305 deletions(-) create mode 100644 ASTPlayground/UserLib.json create mode 100644 IntfExtract/FullApiToClipboard.bat diff --git a/ASTPlayground/MainForm.fmx b/ASTPlayground/MainForm.fmx index c1affd9..86ea512 100644 --- a/ASTPlayground/MainForm.fmx +++ b/ASTPlayground/MainForm.fmx @@ -186,6 +186,22 @@ object Form1: TForm1 TextSettings.Trimming = None OnClick = TailCallButtenClick end + object SaveUserLibButton: TButton + Position.X = 24.000000000000000000 + Position.Y = 680.000000000000000000 + TabOrder = 24 + Text = 'Save Lib' + TextSettings.Trimming = None + OnClick = SaveUserLibButtonClick + end + object LoadUserLibButton: TButton + Position.X = 24.000000000000000000 + Position.Y = 710.000000000000000000 + TabOrder = 25 + Text = 'LoadLib' + TextSettings.Trimming = None + OnClick = LoadUserLibButtonClick + end end object Panel2: TPanel Align = Client diff --git a/ASTPlayground/MainForm.pas b/ASTPlayground/MainForm.pas index af1fe16..1a6a38a 100644 --- a/ASTPlayground/MainForm.pas +++ b/ASTPlayground/MainForm.pas @@ -11,6 +11,7 @@ uses System.Variants, System.Generics.Collections, System.Math, + System.JSON, FMX.Types, FMX.Controls, FMX.Forms, @@ -24,6 +25,7 @@ uses Myc.Data.Scalar, Myc.Data.Value, Myc.Ast.Nodes, + Myc.Ast.Scope, Myc.Ast, Myc.Ast.Evaluator, Myc.Ast.Dumper, @@ -36,7 +38,8 @@ uses Myc.Ast.Debugger, Myc.Fmx.AstEditor, Myc.Fmx.AstEditor.Node, - Myc.Fmx.AstEditor.Workspace; + Myc.Fmx.AstEditor.Workspace, + FMX.DialogService; // Added for platform-independent dialogs type // A test record @@ -77,6 +80,8 @@ type Splitter1: TSplitter; Splitter2: TSplitter; ScriptMemo: TMemo; + LoadUserLibButton: TButton; + SaveUserLibButton: TButton; procedure InnerLambdaButtonClick(Sender: TObject); procedure ClearButtonClick(Sender: TObject); procedure FormCreate(Sender: TObject); @@ -98,6 +103,8 @@ type procedure ScriptMemoChange(Sender: TObject); procedure TailCallButtenClick(Sender: TObject); procedure ToJSONButtonClick(Sender: TObject); + procedure SaveUserLibButtonClick(Sender: TObject); + procedure LoadUserLibButtonClick(Sender: TObject); private FCurrAst: IAstNode; FCurrDesc: IScopeDescriptor; @@ -116,6 +123,9 @@ type { Public declarations } end; +const + UserLibName = 'T:\Myc\ASTPlayground\UserLib.json'; + var Form1: TForm1; @@ -124,7 +134,8 @@ implementation uses Myc.Data.Scalar.JSON, System.Diagnostics, // For TStopwatch - Myc.Ast.Json; // For TAstJson serialization + Myc.Ast.Json, // For TAstJson serialization + System.IOUtils; // For TFile {$R *.fmx} @@ -187,6 +198,14 @@ begin FGScope := TAst.CreateScope(nil); RegisterNativeFunctions(FGScope); + + ScriptMemo.Lines.Text := + ''' + (do + (def my-add (fn [a b] (+ a b))) + (def my-square (fn [x] (* x x))) + ) + '''; end; function TForm1.ExecuteAst(const ANode: IAstNode; const AParentScope: IExecutionScope): TDataValue; @@ -271,10 +290,10 @@ begin ) ); - binder := TAstBinder.Create(FGScope); + binder := TAstBinder.Create(Scope); boundSmaAst := binder.Execute(smaAst, smaDescriptor); - smaScope := smaDescriptor.CreateScope(FGScope); + smaScope := smaDescriptor.CreateScope(Scope); smaVisitor := CreateEvaluator(smaScope); Scope.Define('CreateSMA', smaVisitor.Execute(boundSmaAst)); @@ -284,6 +303,257 @@ begin ClearButtonClick(Self); end; +procedure TForm1.LoadUserLibButtonClick(Sender: TObject); +var + jsonString: string; + jsonObj: TJSONObject; + pair: TJSONPair; + funcAst: IAstNode; + funcValue: TDataValue; + converter: IJsonAstConverter; +begin + // Load definitions from JSON and populate the global scope. + if not TFile.Exists(UserLibName) then + begin + Memo1.Lines.Add(Format('Library file "%s" not found.', [UserLibName])); + exit; + end; + + try + converter := TJsonAstConverter.Create; + jsonString := TFile.ReadAllText(UserLibName); + jsonObj := TJSONObject.ParseJSONValue(jsonString) as TJSONObject; + if not Assigned(jsonObj) then + raise Exception.Create('Invalid JSON format for library file.'); + + try + Memo1.Lines.Add(Format('--- Loading User Library from %s ---', [ExtractFileName(UserLibName)])); + var scopeDescr := FGScope.CreateDescriptor; + for pair in jsonObj do + begin + if not (pair.JsonValue is TJSONObject) then + continue; + + funcAst := converter.Deserialize(pair.JsonValue as TJSONObject); + // Execute the lambda to get a callable function value + var adr := scopeDescr.FindSymbol(pair.JsonString.Value); + if adr.Kind = akUnresolved then + begin + funcValue := ExecuteAst(funcAst, FGScope); + FGScope.Define(pair.JsonString.Value, funcValue); + Memo1.Lines.Add(Format('Defined function "%s"', [pair.JsonString.Value])); + end + else + Memo1.Lines.Add(Format('Function "%s" already defined', [pair.JsonString.Value])); + end; + finally + jsonObj.Free; + end; + except + on E: Exception do + Memo1.Lines.Add('Error loading library: ' + E.Message); + end; +end; + +procedure TForm1.SaveUserLibButtonClick(Sender: TObject); +var + rootNode: IAstNode; + definitions: TDictionary; + jsonLib: TJSONObject; + converter: IJsonAstConverter; + jsonString: string; + updatedCount: Integer; + addedList: TList; +begin + // Extract definitions from the current script and merge them into the JSON library. + try + rootNode := TAstScript.Parse(ScriptMemo.Lines.Text); + if not Assigned(rootNode) then + raise Exception.Create('Script is empty or invalid.'); + + definitions := TDictionary.Create; + try + // Check if the root is a block and extract top-level definitions + if rootNode is TBlockExpressionNode then + begin + for var expr in (rootNode as TBlockExpressionNode).Expressions do + begin + if expr is TVariableDeclarationNode then + begin + var decl := expr as TVariableDeclarationNode; + definitions.Add(decl.Identifier.Name, decl.Initializer); + end; + end; + end + else if rootNode is TVariableDeclarationNode then // Handle single definition + begin + var decl := rootNode as TVariableDeclarationNode; + definitions.Add(decl.Identifier.Name, decl.Initializer); + end; + + if definitions.Count = 0 then + begin + Memo1.Lines.Add('No top-level "(def ...)" definitions found in the script to save.'); + exit; + end; + + // Load existing library file or create a new JSON object if it doesn't exist + jsonLib := nil; + if TFile.Exists(UserLibName) then + begin + jsonString := TFile.ReadAllText(UserLibName); + if not jsonString.IsEmpty then + jsonLib := TJSONObject.ParseJSONValue(jsonString) as TJSONObject; + end; + + if not Assigned(jsonLib) then + jsonLib := TJSONObject.Create; + + addedList := TList.Create; + try + // Serialize and merge the definitions from the script into the JSON object + converter := TJsonAstConverter.Create; + updatedCount := 0; + + for var pair in definitions do + begin + // Track if we are adding or updating a function + if jsonLib.Values[pair.Key] <> nil then + begin + Inc(updatedCount); + jsonLib.RemovePair(pair.Key); + end + else + addedList.Add(pair.Key); + + jsonLib.AddPair(pair.Key, converter.Serialize(pair.Value)); + end; + + TFile.WriteAllText(UserLibName, jsonLib.Format(4)); + + // Provide more detailed feedback to the user + Memo1.Lines.Add(Format('--- Library "%s" updated ---', [ExtractFileName(UserLibName)])); + if updatedCount > 0 then + Memo1.Lines.Add(Format('%d existing definitions updated.', [updatedCount])); + if addedList.Count > 0 then + begin + Memo1.Lines.Add(Format('%d new definitions added:', [addedList.Count])); + for var n in addedList do + Memo1.Lines.Add(n); + end; + + finally + jsonLib.Free; + addedList.Free; + end; + finally + definitions.Free; + end; + except + on E: Exception do + Memo1.Lines.Add('Error saving library: ' + E.Message); + end; +end; + +procedure TForm1.FromJSONButtonClick(Sender: TObject); +var + jsonString: string; + jsonObj: TJSONObject; + converter: IJsonAstConverter; +begin + Memo1.Lines.BeginUpdate; + try + jsonString := Memo1.Lines.Text; + Memo1.Lines.Clear; + + if jsonString.IsEmpty then + begin + Memo1.Lines.Add('Memo is empty. Please paste an AST JSON string.'); + exit; + end; + + try + converter := TJsonAstConverter.Create; + jsonObj := TJSONObject.ParseJSONValue(jsonString) as TJSONObject; + if not Assigned(jsonObj) then + raise EJSONParseException.Create('Invalid JSON format.'); + + try + var binder := TAstBinder.Create(FGScope); + var unboundAst := converter.Deserialize(jsonObj); + FCurrAst := binder.Execute(unboundAst, FCurrDesc); + Memo1.Lines.Add('AST deserialized successfully from JSON.'); + Memo1.Lines.Add('You can now visualize it (Middle Mouse Click) or pretty-print it.'); + finally + jsonObj.Free; + end; + except + on E: Exception do + begin + FCurrAst := nil; + FCurrDesc := nil; + Memo1.Lines.Add('Error deserializing AST from JSON:'); + Memo1.Lines.Add(E.Message); + Memo1.Lines.Add('--- Original JSON ---'); + Memo1.Lines.Text := Memo1.Lines.Text + sLineBreak + jsonString; + end; + end; + finally + Memo1.Lines.EndUpdate; + end; + UpdateScript; +end; + +procedure TForm1.ToJSONButtonClick(Sender: TObject); +var + jsonObj: TJSONObject; + converter: IJsonAstConverter; +begin + Memo1.Lines.Clear; + + if not Assigned(FCurrAst) then + begin + Memo1.Lines.Add('No AST available to serialize. Please generate one first.'); + exit; + end; + + try + converter := TJsonAstConverter.Create; + jsonObj := converter.Serialize(FCurrAst); + try + Memo1.Lines.Text := jsonObj.Format(4); + finally + jsonObj.Free; + end; + except + on E: Exception do + begin + Memo1.Lines.Add('Error serializing AST to JSON:'); + Memo1.Lines.Add(E.Message); + end; + end; +end; + +procedure TForm1.DumpButtonClick(Sender: TObject); +var + binder: IAstBinder; + boundNode: IAstNode; +begin + Memo1.Lines.Clear; + Memo1.Lines.Add('--- AST Dump ---'); + + if not Assigned(FCurrAst) then + begin + Memo1.Lines.Add('No AST has been generated yet. Click a test button first.'); + exit; + end; + + // Re-bind the current AST against the global scope to ensure up-to-date binding info for the dump. + binder := TAstBinder.Create(FGScope); + boundNode := binder.Execute(FCurrAst, FCurrDesc); + TAstDumper.Dump(boundNode, Memo1.Lines); +end; + procedure TForm1.FibonacciButtonClick(Sender: TObject); var root, fibAst, boundFibAst: IAstNode; @@ -632,16 +902,16 @@ begin boundCallAst := binder.Execute(callAst, callDescriptor); // 4. Get the address of 'current_series' from the new descriptor. - var depth, index: Integer; - if not callDescriptor.FindSymbol('current_series', depth, index) then + seriesAddress := callDescriptor.FindSymbol('current_series'); + if seriesAddress.Kind = akUnresolved then raise Exception.Create('Could not resolve current_series address.'); - seriesAddress := TResolvedAddress.Create(akLocalOrParent, depth, index); // 5. Create the final scope and visitor for the simulation loop. var loopScope := callDescriptor.CreateScope(scope); var visitor := CreateEvaluator(loopScope); // 6. Simulation Loop + Memo1.Lines.Clear; Memo1.Lines.Add('Starting simulation...'); Application.ProcessMessages; @@ -798,24 +1068,6 @@ begin UpdateScript; end; -procedure TForm1.DumpButtonClick(Sender: TObject); -var - binder: IAstBinder; - boundNode: IAstNode; -begin - Memo1.Lines.Clear; - Memo1.Lines.Add('--- AST Dump ---'); - - if not Assigned(FCurrAst) then - begin - Memo1.Lines.Add('No AST has been generated yet. Click a test button first.'); - exit; - end; - - boundNode := binder.Execute(FCurrAst, FCurrDesc); - TAstDumper.Dump(boundNode, Memo1.Lines); -end; - procedure TForm1.ExternalFuncButtonClick(Sender: TObject); var scope: IExecutionScope; @@ -898,43 +1150,6 @@ begin UpdateScript; end; -procedure TForm1.FromJSONButtonClick(Sender: TObject); -var - jsonString: string; -begin - Memo1.Lines.BeginUpdate; - try - jsonString := Memo1.Lines.Text; - Memo1.Lines.Clear; - - if jsonString.IsEmpty then - begin - Memo1.Lines.Add('Memo is empty. Please paste an AST JSON string.'); - exit; - end; - - try - var binder := TAstBinder.Create(FGScope); - FCurrAst := binder.Execute(TAstJson.Deserialize(jsonString), FCurrDesc); - Memo1.Lines.Add('AST deserialized successfully from JSON.'); - Memo1.Lines.Add('You can now visualize it (Middle Mouse Click) or pretty-print it.'); - except - on E: Exception do - begin - FCurrAst := nil; - FCurrDesc := nil; - Memo1.Lines.Add('Error deserializing AST from JSON:'); - Memo1.Lines.Add(E.Message); - Memo1.Lines.Add('--- Original JSON ---'); - Memo1.Lines.Text := Memo1.Lines.Text + sLineBreak + jsonString; - end; - end; - finally - Memo1.Lines.EndUpdate; - end; - UpdateScript; -end; - procedure TForm1.PrintScript(const Node: IAstNode); begin try @@ -960,9 +1175,11 @@ begin Memo1.Lines.Clear; try - var binder := TAstBinder.Create(FGScope); - FCurrAst := binder.Execute(TAstScript.Parse(ScriptMemo.Lines.Text), FCurrDesc); + // Execute the entire script block when it changes + var result := ExecuteAst(TAstScript.Parse(ScriptMemo.Lines.Text), FGScope); + Memo1.Lines.Add(Format('Script executed. Final result: %s', [result.ToString])); + // After execution, the FCurrAst is set by ExecuteAst, so we can visualize it FWorkspace.DeleteChildren; ShowVizualization(14, 14); except @@ -971,30 +1188,6 @@ begin end; end; -procedure TForm1.ToJSONButtonClick(Sender: TObject); -var - jsonString: string; -begin - Memo1.Lines.Clear; - - if not Assigned(FCurrAst) then - begin - Memo1.Lines.Add('No AST available to serialize. Please generate one first.'); - exit; - end; - - try - jsonString := TAstJson.Serialize(FCurrAst); - Memo1.Lines.Text := jsonString; - except - on E: Exception do - begin - Memo1.Lines.Add('Error serializing AST to JSON:'); - Memo1.Lines.Add(E.Message); - end; - end; -end; - procedure TForm1.UpdateScript; begin PrintScript(FCurrAst); diff --git a/ASTPlayground/Myc.Fmx.AstEditor.Workspace.pas b/ASTPlayground/Myc.Fmx.AstEditor.Workspace.pas index 1253e37..401290d 100644 --- a/ASTPlayground/Myc.Fmx.AstEditor.Workspace.pas +++ b/ASTPlayground/Myc.Fmx.AstEditor.Workspace.pas @@ -15,6 +15,7 @@ uses FMX.Objects, Myc.Ast, Myc.Ast.Nodes, + Myc.Ast.Scope, Myc.Ast.Binding; type diff --git a/ASTPlayground/UserLib.json b/ASTPlayground/UserLib.json new file mode 100644 index 0000000..17812f9 --- /dev/null +++ b/ASTPlayground/UserLib.json @@ -0,0 +1,85 @@ +{ + "my-add": { + "NodeType": "LambdaExpr", + "Parameters": [ + { + "NodeType": "Identifier", + "Name": "a" + }, + { + "NodeType": "Identifier", + "Name": "b" + } + ], + "Body": { + "NodeType": "BinaryExpr", + "Operator": "+", + "Left": { + "NodeType": "Identifier", + "Name": "a" + }, + "Right": { + "NodeType": "Identifier", + "Name": "b" + } + } + }, + "my-square": { + "NodeType": "LambdaExpr", + "Parameters": [ + { + "NodeType": "Identifier", + "Name": "x" + } + ], + "Body": { + "NodeType": "BinaryExpr", + "Operator": "*", + "Left": { + "NodeType": "Identifier", + "Name": "x" + }, + "Right": { + "NodeType": "Identifier", + "Name": "x" + } + } + }, + "my-3": { + "NodeType": "LambdaExpr", + "Parameters": [ + { + "NodeType": "Identifier", + "Name": "a" + }, + { + "NodeType": "Identifier", + "Name": "b" + }, + { + "NodeType": "Identifier", + "Name": "c" + } + ], + "Body": { + "NodeType": "BinaryExpr", + "Operator": "+", + "Left": { + "NodeType": "BinaryExpr", + "Operator": "+", + "Left": { + "NodeType": "Identifier", + "Name": "a" + }, + "Right": { + "NodeType": "Identifier", + "Name": "b" + } + }, + "Right": { + "NodeType": "Identifier", + "Name": "c" + } + } + } +} \ No newline at end of file diff --git a/IntfExtract/FullApiToClipboard.bat b/IntfExtract/FullApiToClipboard.bat new file mode 100644 index 0000000..bd7ec4d --- /dev/null +++ b/IntfExtract/FullApiToClipboard.bat @@ -0,0 +1 @@ +T:\Myc\IntfExtract\Win64\Debug\ExtractPascalInterfaces.exe -c -dirs T:\Myc\dirs.txt -fc T:\Myc\Src\Ast\Myc.Ast.*.pas \ No newline at end of file diff --git a/Src/AST/Myc.Ast.Binding.pas b/Src/AST/Myc.Ast.Binding.pas index cef04b4..25effd6 100644 --- a/Src/AST/Myc.Ast.Binding.pas +++ b/Src/AST/Myc.Ast.Binding.pas @@ -51,8 +51,6 @@ type function Execute(const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode; - class function CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor; static; - // The binder overrides specific transform methods to enrich the AST. function TransformIdentifier(const Node: IIdentifierNode): IIdentifierNode; override; function TransformVariableDeclaration(const Node: IVariableDeclarationNode): IVariableDeclarationNode; override; @@ -186,22 +184,10 @@ begin inherited Destroy; end; -class function TAstBinder.CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor; -begin - if Scope is TExecutionScope then - begin - var res := TScopeDescriptor.Create(CreateDescriptor(Scope.Parent)); - res.PopulateFromScope(Scope as TExecutionScope); - Result := res; - end - else - Result := TScopeDescriptor.Create(nil); -end; - constructor TAstBinder.Create(const AInitialScope: IExecutionScope); begin inherited Create; - FCurrentDescriptor := CreateDescriptor(AInitialScope); + FCurrentDescriptor := AInitialScope.CreateDescriptor; FUpvalueStack := TObjectStack.Create(True); FNestedLambdaCount := 0; FIsTailStack := TStack.Create; @@ -230,7 +216,7 @@ end; procedure TAstBinder.EnterScope; begin - FCurrentDescriptor := TScopeDescriptor.Create(FCurrentDescriptor); + FCurrentDescriptor := TScope.CreateDescriptor(FCurrentDescriptor); end; function TAstBinder.Execute(const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode; @@ -270,30 +256,29 @@ end; function TAstBinder.TransformIdentifier(const Node: IIdentifierNode): IIdentifierNode; var - depth, idx: Integer; + adr: TResolvedAddress; begin - if FCurrentDescriptor.FindSymbol(Node.Name, depth, idx) then + adr := FCurrentDescriptor.FindSymbol(Node.Name); + if adr.Kind = akLocalOrParent then begin - if (depth > 0) and (FUpvalueStack.Count > 0) then + if (adr.ScopeDepth > 0) and (FUpvalueStack.Count > 0) then begin var upvalue := FUpvalueStack.Peek; - dec(depth); - var originalAddress := TResolvedAddress.Create(akLocalOrParent, depth, idx); + + // up to outer scope + dec(adr.ScopeDepth); var upvalueIndex: Integer; - if not upvalue.Map.TryGetValue(originalAddress, upvalueIndex) then + if not upvalue.Map.TryGetValue(adr, upvalueIndex) then begin upvalueIndex := upvalue.Map.Count; - upvalue.Map.Add(originalAddress, upvalueIndex); + upvalue.Map.Add(adr, upvalueIndex); end; - var address := TResolvedAddress.Create(akUpvalue, 0, upvalueIndex); - Result := TBoundIdentifierNode.Create(Node, address); + + Result := TBoundIdentifierNode.Create(Node, TResolvedAddress.Create(akUpvalue, 0, upvalueIndex)); end else - begin - var address := TResolvedAddress.Create(akLocalOrParent, depth, idx); - Result := TBoundIdentifierNode.Create(Node, address); - end + Result := TBoundIdentifierNode.Create(Node, adr); end else raise Exception.CreateFmt('Undefined identifier: "%s"', [Node.Name]); diff --git a/Src/AST/Myc.Ast.Dumper.pas b/Src/AST/Myc.Ast.Dumper.pas index 5a4057b..db3e5a4 100644 --- a/Src/AST/Myc.Ast.Dumper.pas +++ b/Src/AST/Myc.Ast.Dumper.pas @@ -27,16 +27,8 @@ type procedure Log(const Text: string); overload; procedure LogFmt(const Fmt: string; const Args: array of const); overload; function FormatAddress(const Addr: TResolvedAddress): string; - public - // Creates a new instance of the AST dumper. - constructor Create(const AOutput: TStrings); - // Traverses the given root node and writes the structural information into the output. - class procedure Dump(const RootNode: IAstNode; const Output: TStrings); - - procedure Execute(const RootNode: IAstNode); - - // IAstVisitor implementation + protected function VisitConstant(const Node: IConstantNode): TDataValue; override; function VisitIdentifier(const Node: IIdentifierNode): TDataValue; override; function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; override; @@ -54,6 +46,15 @@ type function VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; override; function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; override; function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; override; + + public + // Creates a new instance of the AST dumper. + constructor Create(const AOutput: TStrings); + + // Traverses the given root node and writes the structural information into the output. + class procedure Dump(const RootNode: IAstNode; const Output: TStrings); + + procedure Execute(const RootNode: IAstNode); end; implementation diff --git a/Src/AST/Myc.Ast.Evaluator.pas b/Src/AST/Myc.Ast.Evaluator.pas index 79bb562..e84a023 100644 --- a/Src/AST/Myc.Ast.Evaluator.pas +++ b/Src/AST/Myc.Ast.Evaluator.pas @@ -28,18 +28,6 @@ type procedure HandleTCO(var ResultValue: TDataValue); protected - function IsTruthy(const AValue: TDataValue): Boolean; inline; - - // Returns a closure that can create the correct type of visitor for a lambda's body. - function CreateVisitorFactory: TVisitorFactory; virtual; - - property Scope: IExecutionScope read FScope; - public - constructor Create(const AScope: IExecutionScope); - - // Executes an AST with proper TCO handling. This is the main entry point. - function Execute(const RootNode: IAstNode): TDataValue; - function VisitConstant(const Node: IConstantNode): TDataValue; override; function VisitIdentifier(const Node: IIdentifierNode): TDataValue; override; function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; override; @@ -57,6 +45,18 @@ type function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; override; function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; override; function VisitRecurNode(const Node: IRecurNode): TDataValue; override; + + function IsTruthy(const AValue: TDataValue): Boolean; inline; + + // Returns a closure that can create the correct type of visitor for a lambda's body. + function CreateVisitorFactory: TVisitorFactory; virtual; + + property Scope: IExecutionScope read FScope; + public + constructor Create(const AScope: IExecutionScope); + + // Executes an AST with proper TCO handling. This is the main entry point. + function Execute(const RootNode: IAstNode): TDataValue; end; // Registers native Delphi functions into a scope. @@ -207,7 +207,7 @@ begin if (Length(ArgValues) <> Length(params)) then raise EArgumentException.CreateFmt('Argument count mismatch: expected %d, got %d', [Length(params), Length(ArgValues)]); - lambdaScope := TExecutionScope.Create(closureScope, scopeDescriptor, capturedCells); + lambdaScope := TScope.CreateScope(closureScope, scopeDescriptor, capturedCells); adr.Kind := akLocalOrParent; adr.ScopeDepth := 0; diff --git a/Src/AST/Myc.Ast.JSON.pas b/Src/AST/Myc.Ast.JSON.pas index ec22b52..0f96b9b 100644 --- a/Src/AST/Myc.Ast.JSON.pas +++ b/Src/AST/Myc.Ast.JSON.pas @@ -4,29 +4,23 @@ interface uses System.SysUtils, + System.Generics.Collections, + System.JSON, + Myc.Data.Scalar, + Myc.Data.Value, + Myc.Ast, + Myc.Ast.Visitor, Myc.Ast.Nodes; type - // TAstJson provides static methods for serializing and deserializing an AST to/from JSON. - TAstJson = record - public - class function Serialize(const ANode: IAstNode): string; static; - class function Deserialize(const AJson: string): IAstNode; static; + IJsonAstConverter = interface + function Serialize(const RootNode: IAstNode): TJSONObject; + function Deserialize(const AJson: TJSONObject): IAstNode; end; -implementation - -uses - System.JSON, - System.Generics.Collections, - Myc.Ast, - Myc.Data.Scalar, - Myc.Data.Value; - -type // TJsonAstConverter implements the visitor pattern for serialization // and uses factory functions for deserialization. - TJsonAstConverter = class(TInterfacedObject, IAstVisitor) + TJsonAstConverter = class(TAstVisitor, IJsonAstConverter) private FJsonObjectStack: TStack; procedure DataValueToJson(const AValue: TDataValue; const AParent: TJSONObject; const AName: string); @@ -52,31 +46,33 @@ type function JsonToSeriesLengthNode(const AObj: TJSONObject): ISeriesLengthNode; protected // IAstVisitor implementation for serialization - function VisitConstant(const Node: IConstantNode): TDataValue; - function VisitIdentifier(const Node: IIdentifierNode): TDataValue; - function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; - function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; - function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; - function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; - function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; - function VisitFunctionCall(const Node: IFunctionCallNode): TDataValue; - function VisitRecurNode(const Node: IRecurNode): TDataValue; - function VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; - function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TDataValue; - function VisitAssignment(const Node: IAssignmentNode): TDataValue; - function VisitIndexer(const Node: IIndexerNode): TDataValue; - function VisitMemberAccess(const Node: IMemberAccessNode): TDataValue; - function VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; - function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; - function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; + function VisitConstant(const Node: IConstantNode): TDataValue; override; + function VisitIdentifier(const Node: IIdentifierNode): TDataValue; override; + function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; override; + function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; override; + function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; override; + function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; override; + function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; override; + function VisitFunctionCall(const Node: IFunctionCallNode): TDataValue; override; + function VisitRecurNode(const Node: IRecurNode): TDataValue; override; + function VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; override; + function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TDataValue; override; + function VisitAssignment(const Node: IAssignmentNode): TDataValue; override; + function VisitIndexer(const Node: IIndexerNode): TDataValue; override; + function VisitMemberAccess(const Node: IMemberAccessNode): TDataValue; override; + function VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; override; + function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; override; + function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; override; + + function Serialize(const RootNode: IAstNode): TJSONObject; + function Deserialize(const AJson: TJSONObject): IAstNode; public constructor Create; destructor Destroy; override; - function Execute(const RootNode: IAstNode): TDataValue; - function Serialize(const ANode: IAstNode): string; - function Deserialize(const AJson: string): IAstNode; end; +implementation + { TJsonAstConverter } constructor TJsonAstConverter.Create; @@ -91,48 +87,9 @@ begin inherited; end; -function TJsonAstConverter.Serialize(const ANode: IAstNode): string; -var - rootObj: TJSONObject; +function TJsonAstConverter.Deserialize(const AJson: TJSONObject): IAstNode; begin - if not Assigned(ANode) then - exit(''); - - FJsonObjectStack.Clear; - ANode.Accept(Self); - - if FJsonObjectStack.Count <> 1 then - raise EInvalidOpException.Create('JSON serialization stack is corrupt.'); - - rootObj := FJsonObjectStack.Pop; - try - Result := rootObj.Format(4); - finally - rootObj.Free; - end; -end; - -function TJsonAstConverter.Deserialize(const AJson: string): IAstNode; -var - jsonValue: TJSONValue; -begin - if AJson.IsEmpty then - exit(nil); - - jsonValue := TJSONObject.ParseJSONValue(AJson); - if jsonValue = nil then - raise EJSONParseException.Create('Invalid JSON format.'); - - try - Result := JsonToNode(jsonValue); - finally - jsonValue.Free; - end; -end; - -function TJsonAstConverter.Execute(const RootNode: IAstNode): TDataValue; -begin - Result := RootNode.Accept(Self); + Result := JsonToNode(AJson); end; { TJsonAstConverter - IAstVisitor for Serialization } @@ -782,30 +739,18 @@ begin raise ENotSupportedException.CreateFmt('Unsupported NodeType "%s" for JSON deserialization.', [nodeType]); end; -{ TAstJson } - -class function TAstJson.Deserialize(const AJson: string): IAstNode; -var - converter: TJsonAstConverter; +function TJsonAstConverter.Serialize(const RootNode: IAstNode): TJSONObject; begin - converter := TJsonAstConverter.Create; - try - Result := converter.Deserialize(AJson); - finally - converter.Free; - end; -end; + FJsonObjectStack.Clear; + if not Assigned(RootNode) then + exit(nil); -class function TAstJson.Serialize(const ANode: IAstNode): string; -var - converter: TJsonAstConverter; -begin - converter := TJsonAstConverter.Create; - try - Result := converter.Serialize(ANode); - finally - converter.Free; - end; + RootNode.Accept(Self); + + if FJsonObjectStack.Count <> 1 then + raise EInvalidOpException.Create('JSON serialization stack is corrupt.'); + + Result := FJsonObjectStack.Pop; end; end. diff --git a/Src/AST/Myc.Ast.Nodes.pas b/Src/AST/Myc.Ast.Nodes.pas index bb39b75..ac14a84 100644 --- a/Src/AST/Myc.Ast.Nodes.pas +++ b/Src/AST/Myc.Ast.Nodes.pas @@ -29,8 +29,6 @@ type IAddSeriesItemNode = interface; ISeriesLengthNode = interface; IRecurNode = interface; - IExecutionScope = interface; - IScopeDescriptor = interface; // --- Concrete Type Definitions --- @@ -55,36 +53,6 @@ type property Value: TDataValue read GetValue write SetValue; end; - IExecutionScope = interface - {$region 'private'} - function GetParent: IExecutionScope; - function GetValues(const Address: TResolvedAddress): TDataValue; - procedure SetValues(const Address: TResolvedAddress; const Value: TDataValue); - {$endregion} - - procedure Define(const Name: string; const Value: TDataValue); - function Dump: string; - procedure Clear; - function Capture(const Address: TResolvedAddress): IValueCell; - - property Values[const Address: TResolvedAddress]: TDataValue read GetValues write SetValues; default; - property Parent: IExecutionScope read GetParent; - end; - - IScopeDescriptor = interface - {$region 'private'} - function GetParent: IScopeDescriptor; - function GetSlotCount: Integer; - function GetSymbols: TDictionary; - {$endregion} - function CreateScope(const AParent: IExecutionScope): IExecutionScope; - function Define(const Name: string): Integer; - function FindSymbol(const Name: string; out Depth, Index: Integer): Boolean; - property Parent: IScopeDescriptor read GetParent; - property SlotCount: Integer read GetSlotCount; - property Symbols: TDictionary read GetSymbols; - end; - IAstVisitor = interface function VisitConstant(const Node: IConstantNode): TDataValue; function VisitIdentifier(const Node: IIdentifierNode): TDataValue; diff --git a/Src/AST/Myc.Ast.RTL.pas b/Src/AST/Myc.Ast.RTL.pas index a8c2300..67e4309 100644 --- a/Src/AST/Myc.Ast.RTL.pas +++ b/Src/AST/Myc.Ast.RTL.pas @@ -26,6 +26,7 @@ implementation uses System.Rtti, System.TypInfo, + Myc.Ast.Scope, Myc.Ast.RTL.Core; //-------------------------------------------------------------------------------------------------- diff --git a/Src/AST/Myc.Ast.Scope.pas b/Src/AST/Myc.Ast.Scope.pas index 9cd2e86..ea6d2d2 100644 --- a/Src/AST/Myc.Ast.Scope.pas +++ b/Src/AST/Myc.Ast.Scope.pas @@ -9,6 +9,58 @@ uses Myc.Data.Value, Myc.Ast.Nodes; +type + IExecutionScope = interface; + IScopeDescriptor = interface; + + IExecutionScope = interface + {$region 'private'} + function GetParent: IExecutionScope; + function GetValues(const Address: TResolvedAddress): TDataValue; + procedure SetValues(const Address: TResolvedAddress; const Value: TDataValue); + {$endregion} + + procedure Define(const Name: string; const Value: TDataValue); + function Dump: string; + procedure Clear; + function Capture(const Address: TResolvedAddress): IValueCell; + + function CreateDescriptor: IScopeDescriptor; + + property Values[const Address: TResolvedAddress]: TDataValue read GetValues write SetValues; default; + property Parent: IExecutionScope read GetParent; + end; + + // Describes the layout of a scope: variable names and their slot indices. + // This is generated by the binder and used to create TExecutionScope instances at runtime. + IScopeDescriptor = interface + {$region 'private'} + function GetParent: IScopeDescriptor; + function GetSlotCount: Integer; + function GetSymbols: TDictionary; + {$endregion} + function CreateScope(const AParent: IExecutionScope): IExecutionScope; + function Define(const Name: string): Integer; + function FindSymbol(const Name: string): TResolvedAddress; + property Parent: IScopeDescriptor read GetParent; + property SlotCount: Integer read GetSlotCount; + property Symbols: TDictionary read GetSymbols; + end; + + TScope = record + class function CreateScope( + const Parent: IExecutionScope; + const Descriptor: IScopeDescriptor; + const CapturedUpvalues: TArray + ): IExecutionScope; static; + class function CreateDescriptor(const Parent: IScopeDescriptor): IScopeDescriptor; static; + end; + +implementation + +uses + System.Generics.Defaults; + type TExecutionScope = class(TInterfacedObject, IExecutionScope) type @@ -54,14 +106,13 @@ type function Dump: string; procedure Define(const Name: string; const Value: TDataValue); function Capture(const Address: TResolvedAddress): IValueCell; + function CreateDescriptor: IScopeDescriptor; property Names: TDictionary read FNames; property NameStrings: TList read FNameStrings; property NameToIndex: TDictionary read GetNameToIndex; property Parent: IExecutionScope read FParent; end; - // Describes the layout of a scope: variable names and their slot indices. - // This is generated by the binder and used to create TExecutionScope instances at runtime. TScopeDescriptor = class(TInterfacedObject, IScopeDescriptor) private FParent: IScopeDescriptor; @@ -72,18 +123,14 @@ type public constructor Create(const AParent: IScopeDescriptor); destructor Destroy; override; + class function CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor; static; function Define(const Name: string): Integer; - function FindSymbol(const Name: string; out Depth, Index: Integer): Boolean; + function FindSymbol(const Name: string): TResolvedAddress; function CreateScope(const Parent: IExecutionScope): IExecutionScope; procedure PopulateFromScope(Scope: TExecutionScope); property Symbols: TDictionary read FSymbols; end; -implementation - -uses - System.Generics.Defaults; - { TValueCell } constructor TExecutionScope.TValueCell.Create(const AValue: TDataValue); @@ -185,6 +232,11 @@ begin end; end; +function TExecutionScope.CreateDescriptor: IScopeDescriptor; +begin + Result := TScopeDescriptor.CreateDescriptor(Self); +end; + procedure TExecutionScope.Define(const Name: string; const Value: TDataValue); var id: Integer; @@ -373,6 +425,18 @@ begin inherited; end; +class function TScopeDescriptor.CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor; +begin + if Scope is TExecutionScope then + begin + var res := TScopeDescriptor.Create(CreateDescriptor(Scope.Parent)); + res.PopulateFromScope(Scope as TExecutionScope); + Result := res; + end + else + Result := TScopeDescriptor.Create(nil); +end; + function TScopeDescriptor.CreateScope(const Parent: IExecutionScope): IExecutionScope; begin // Creates a runtime scope instance based on this descriptor's layout. @@ -385,20 +449,23 @@ begin FSymbols.Add(Name, Result); end; -function TScopeDescriptor.FindSymbol(const Name: string; out Depth, Index: Integer): Boolean; +function TScopeDescriptor.FindSymbol(const Name: string): TResolvedAddress; var currentDescriptor: TScopeDescriptor; begin - Depth := 0; + Result.Kind := akUnresolved; + Result.ScopeDepth := 0; currentDescriptor := Self; while currentDescriptor <> nil do begin - if currentDescriptor.FSymbols.TryGetValue(Name, Index) then - exit(True); - inc(Depth); + if currentDescriptor.FSymbols.TryGetValue(Name, Result.SlotIndex) then + begin + Result.Kind := akLocalOrParent; + exit; + end; + inc(Result.ScopeDepth); currentDescriptor := currentDescriptor.FParent as TScopeDescriptor; end; - Result := False; end; function TScopeDescriptor.GetParent: IScopeDescriptor; @@ -428,4 +495,18 @@ begin end; end; +class function TScope.CreateDescriptor(const Parent: IScopeDescriptor): IScopeDescriptor; +begin + Result := TScopeDescriptor.Create(Parent); +end; + +class function TScope.CreateScope( + const Parent: IExecutionScope; + const Descriptor: IScopeDescriptor; + const CapturedUpvalues: TArray +): IExecutionScope; +begin + Result := TExecutionScope.Create(Parent, Descriptor, CapturedUpvalues); +end; + end. diff --git a/Src/AST/Myc.Ast.Visitor.pas b/Src/AST/Myc.Ast.Visitor.pas index df10414..a8bf43d 100644 --- a/Src/AST/Myc.Ast.Visitor.pas +++ b/Src/AST/Myc.Ast.Visitor.pas @@ -12,7 +12,7 @@ uses type // A fully abstract base class for any visitor of the AST. TAstVisitor = class abstract(TInterfacedObject, IAstVisitor) - public + protected function VisitConstant(const Node: IConstantNode): TDataValue; virtual; abstract; function VisitIdentifier(const Node: IIdentifierNode): TDataValue; virtual; abstract; function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; virtual; abstract; @@ -45,6 +45,25 @@ type FDone: Boolean; protected + // Final Visit methods - these should not be overridden. They call the virtual Transform methods. + function VisitConstant(const Node: IConstantNode): TDataValue; override; final; + function VisitIdentifier(const Node: IIdentifierNode): TDataValue; override; final; + function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; override; final; + function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; override; final; + function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; override; final; + function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; override; final; + function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; override; final; + function VisitFunctionCall(const Node: IFunctionCallNode): TDataValue; override; final; + function VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; override; final; + function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TDataValue; override; final; + function VisitAssignment(const Node: IAssignmentNode): TDataValue; override; final; + function VisitIndexer(const Node: IIndexerNode): TDataValue; override; final; + function VisitMemberAccess(const Node: IMemberAccessNode): TDataValue; override; final; + function VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; override; final; + function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; override; final; + function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; override; final; + function VisitRecurNode(const Node: IRecurNode): TDataValue; override; final; + // Dispatch methods for each node type. Derived classes override these to change the transformation. function TransformConstant(const Node: IConstantNode): IConstantNode; virtual; function TransformIdentifier(const Node: IIdentifierNode): IIdentifierNode; virtual; @@ -73,25 +92,6 @@ type public // This is the main entry point for the transformer, returning a transformed node. function Execute(const RootNode: IAstNode): IAstNode; - - // Final Visit methods - these should not be overridden. They call the virtual Transform methods. - function VisitConstant(const Node: IConstantNode): TDataValue; override; final; - function VisitIdentifier(const Node: IIdentifierNode): TDataValue; override; final; - function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; override; final; - function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; override; final; - function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; override; final; - function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; override; final; - function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; override; final; - function VisitFunctionCall(const Node: IFunctionCallNode): TDataValue; override; final; - function VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; override; final; - function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TDataValue; override; final; - function VisitAssignment(const Node: IAssignmentNode): TDataValue; override; final; - function VisitIndexer(const Node: IIndexerNode): TDataValue; override; final; - function VisitMemberAccess(const Node: IMemberAccessNode): TDataValue; override; final; - function VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; override; final; - function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; override; final; - function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; override; final; - function VisitRecurNode(const Node: IRecurNode): TDataValue; override; final; end; // TAstTraverser simply inherits the identity-transform (cloning) behavior from TAstTransformer. diff --git a/Src/AST/Myc.Ast.pas b/Src/AST/Myc.Ast.pas index 38dc0e5..9b04b43 100644 --- a/Src/AST/Myc.Ast.pas +++ b/Src/AST/Myc.Ast.pas @@ -171,6 +171,7 @@ type constructor Create(const AExpressions: array of IAstNode); destructor Destroy; override; function Accept(const Visitor: IAstVisitor): TDataValue; override; + property Expressions: TList read FExpressions; end; TVariableDeclarationNode = class(TAstNode, IVariableDeclarationNode) @@ -182,6 +183,8 @@ type public constructor Create(const AIdentifier: IIdentifierNode; AInitializer: IAstNode); function Accept(const Visitor: IAstVisitor): TDataValue; override; + property Identifier: IIdentifierNode read FIdentifier; + property Initializer: IAstNode read FInitializer; end; TAssignmentNode = class(TAstNode, IAssignmentNode) @@ -731,7 +734,7 @@ class function TAst.CreateScope(Parent: IExecutionScope; const Descriptor: IScop var proc: TRegisterLibraryProc; begin - Result := TExecutionScope.Create(Parent, Descriptor, nil); + Result := TScope.CreateScope(Parent, Descriptor, nil); if Parent = nil then begin