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

Added user library

Browse Source
This commit is contained in:
Michael Schimmel
2025-09-24 10:03:10 +02:00
parent 5a1919ec07
commit 624af31243
14 changed files with 585 additions and 305 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ASTPlayground/MainForm.fmx
+16
View File
@@ -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
ASTPlayground/MainForm.pas
+281 -88
View File
@@ -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<string, IAstNode>;
jsonLib: TJSONObject;
converter: IJsonAstConverter;
jsonString: string;
updatedCount: Integer;
addedList: TList<String>;
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<string, IAstNode>.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<String>.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);
ASTPlayground/Myc.Fmx.AstEditor.Workspace.pas
+1
View File
@@ -15,6 +15,7 @@ uses
FMX.Objects,
Myc.Ast,
Myc.Ast.Nodes,
Myc.Ast.Scope,
Myc.Ast.Binding;
type
ASTPlayground/UserLib.json
+85
View File
@@ -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"
}
}
}
}
IntfExtract/FullApiToClipboard.bat
+1
View File
@@ -0,0 +1 @@
T:\Myc\IntfExtract\Win64\Debug\ExtractPascalInterfaces.exe -c -dirs T:\Myc\dirs.txt -fc T:\Myc\Src\Ast\Myc.Ast.*.pas
Src/AST/Myc.Ast.Binding.pas
+14 -29
View File
@@ -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<TUpvalueMapping>.Create(True);
FNestedLambdaCount := 0;
FIsTailStack := TStack<Boolean>.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]);
Src/AST/Myc.Ast.Dumper.pas
+10 -9
View File
@@ -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
Src/AST/Myc.Ast.Evaluator.pas
+13 -13
View File
@@ -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;
Src/AST/Myc.Ast.JSON.pas
+44 -99
View File
@@ -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<TJSONObject>;
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.
Src/AST/Myc.Ast.Nodes.pas
-32
View File
@@ -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<string, Integer>;
{$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<string, Integer> read GetSymbols;
end;
IAstVisitor = interface
function VisitConstant(const Node: IConstantNode): TDataValue;
function VisitIdentifier(const Node: IIdentifierNode): TDataValue;
Src/AST/Myc.Ast.RTL.pas
+1
View File
@@ -26,6 +26,7 @@ implementation
uses
System.Rtti,
System.TypInfo,
Myc.Ast.Scope,
Myc.Ast.RTL.Core;
//--------------------------------------------------------------------------------------------------
Src/AST/Myc.Ast.Scope.pas
+95 -14
View File
@@ -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<string, Integer>;
{$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<string, Integer> read GetSymbols;
end;
TScope = record
class function CreateScope(
const Parent: IExecutionScope;
const Descriptor: IScopeDescriptor;
const CapturedUpvalues: TArray<IValueCell>
): 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<string, Integer> read FNames;
property NameStrings: TList<string> read FNameStrings;
property NameToIndex: TDictionary<Integer, Integer> 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<string, Integer> 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<IValueCell>
): IExecutionScope;
begin
Result := TExecutionScope.Create(Parent, Descriptor, CapturedUpvalues);
end;
end.
Src/AST/Myc.Ast.Visitor.pas
+20 -20
View File
@@ -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.
Src/AST/Myc.Ast.pas
+4 -1
View File
@@ -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<IAstNode> 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