Closure upvalues

This commit is contained in:
Michael Schimmel
2025-09-04 23:59:33 +02:00
parent 4a8075fecf
commit aa3c218f44
5 changed files with 351 additions and 56 deletions
+3 -3
View File
@@ -164,12 +164,12 @@ begin
TAst.Identifier('n'), TAst.Identifier('n'),
TAst.BinaryExpr( TAst.BinaryExpr(
TAst.FunctionCall( TAst.FunctionCall(
TAst.Identifier('fib'), TAst.Identifier('Self'),
[TAst.BinaryExpr(TAst.Identifier('n'), boSubtract, TAst.Constant(TScalar.FromInt64(1)))] [TAst.BinaryExpr(TAst.Identifier('n'), boSubtract, TAst.Constant(TScalar.FromInt64(1)))]
), ),
boAdd, boAdd,
TAst.FunctionCall( TAst.FunctionCall(
TAst.Identifier('fib'), TAst.Identifier('Self'),
[TAst.BinaryExpr(TAst.Identifier('n'), boSubtract, TAst.Constant(TScalar.FromInt64(2)))] [TAst.BinaryExpr(TAst.Identifier('n'), boSubtract, TAst.Constant(TScalar.FromInt64(2)))]
) )
) )
@@ -230,7 +230,7 @@ begin
TAst.Identifier('n'), TAst.Identifier('n'),
boMultiply, boMultiply,
TAst.FunctionCall( TAst.FunctionCall(
TAst.Identifier('factorial'), TAst.Identifier('Self'),
[TAst.BinaryExpr(TAst.Identifier('n'), boSubtract, TAst.Constant(TScalar.FromInt64(1)))] [TAst.BinaryExpr(TAst.Identifier('n'), boSubtract, TAst.Constant(TScalar.FromInt64(1)))]
) )
) )
+51 -7
View File
@@ -88,19 +88,25 @@ type
// The signature for a native Delphi function callable from the script. // The signature for a native Delphi function callable from the script.
TNativeFunction = function(const Args: TArray<TAstValue>): TAstValue; TNativeFunction = function(const Args: TArray<TAstValue>): TAstValue;
// Concrete implementation of the TAstValue.IClosure interface for script-defined functions.
TClosureValue = class(TInterfacedObject, TAstValue.IClosure) TClosureValue = class(TInterfacedObject, TAstValue.IClosure)
private private
FBody: IExpressionNode; FBody: IExpressionNode;
FClosureScope: IExecutionScope; FClosureScope: IExecutionScope;
FLambdaNode: ILambdaExpressionNode; FLambdaNode: ILambdaExpressionNode;
FUpvalues: TArray<IValueCell>;
function GetBody: IExpressionNode; function GetBody: IExpressionNode;
function GetParameters: TArray<IIdentifierNode>; function GetParameters: TArray<IIdentifierNode>;
function GetClosureScope: IExecutionScope; function GetClosureScope: IExecutionScope;
function GetUpvalues: TArray<IValueCell>;
public public
constructor Create(const ALambdaNode: ILambdaExpressionNode; const AClosureScope: IExecutionScope); constructor Create(
const ALambdaNode: ILambdaExpressionNode;
const AClosureScope: IExecutionScope;
const AUpvalues: TArray<IValueCell>
);
property ClosureScope: IExecutionScope read GetClosureScope; property ClosureScope: IExecutionScope read GetClosureScope;
property LambdaNode: ILambdaExpressionNode read FLambdaNode; property LambdaNode: ILambdaExpressionNode read FLambdaNode;
property Upvalues: TArray<IValueCell> read FUpvalues;
end; end;
// Concrete implementation of TAstValue.IClosure for native Delphi functions. // Concrete implementation of TAstValue.IClosure for native Delphi functions.
@@ -110,6 +116,7 @@ type
function GetBody: IExpressionNode; function GetBody: IExpressionNode;
function GetParameters: TArray<IIdentifierNode>; function GetParameters: TArray<IIdentifierNode>;
function GetClosureScope: IExecutionScope; function GetClosureScope: IExecutionScope;
function GetUpvalues: TArray<IValueCell>;
public public
constructor Create(const AMethod: TNativeFunction); constructor Create(const AMethod: TNativeFunction);
property Method: TNativeFunction read FMethod; property Method: TNativeFunction read FMethod;
@@ -205,12 +212,17 @@ end;
{ TClosureValue } { TClosureValue }
constructor TClosureValue.Create(const ALambdaNode: ILambdaExpressionNode; const AClosureScope: IExecutionScope); constructor TClosureValue.Create(
const ALambdaNode: ILambdaExpressionNode;
const AClosureScope: IExecutionScope;
const AUpvalues: TArray<IValueCell>
);
begin begin
inherited Create; inherited Create;
FLambdaNode := ALambdaNode; FLambdaNode := ALambdaNode;
FBody := ALambdaNode.Body; FBody := ALambdaNode.Body;
FClosureScope := AClosureScope; FClosureScope := AClosureScope;
FUpvalues := AUpvalues; // Store the captured cells
end; end;
function TClosureValue.GetBody: IExpressionNode; function TClosureValue.GetBody: IExpressionNode;
@@ -228,6 +240,11 @@ begin
Result := FLambdaNode.Parameters; Result := FLambdaNode.Parameters;
end; end;
function TClosureValue.GetUpvalues: TArray<IValueCell>;
begin
Result := FUpvalues;
end;
{ TNativeClosure } { TNativeClosure }
constructor TNativeClosure.Create(const AMethod: TNativeFunction); constructor TNativeClosure.Create(const AMethod: TNativeFunction);
@@ -251,6 +268,10 @@ begin
Result := nil; Result := nil;
end; end;
function TNativeClosure.GetUpvalues: TArray<IValueCell>;
begin
end;
{ TEvaluatorVisitor } { TEvaluatorVisitor }
constructor TEvaluatorVisitor.Create(const AScope: IExecutionScope); constructor TEvaluatorVisitor.Create(const AScope: IExecutionScope);
@@ -475,8 +496,27 @@ begin
end; end;
function TEvaluatorVisitor.VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue; function TEvaluatorVisitor.VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue;
var
capturedCells: TArray<IValueCell>;
i: Integer;
sourceAddr: TResolvedAddress;
sourceAddresses: TArray<TResolvedAddress>;
begin begin
Result := TAstValue.FromClosure(TClosureValue.Create(Node, FScope)); // The binder has identified the upvalues. Capture the cells from the current scope
// using the original source addresses provided by the binder.
sourceAddresses := Node.UpvalueSourceAddresses;
SetLength(capturedCells, Length(sourceAddresses));
for i := 0 to High(sourceAddresses) do
begin
sourceAddr := sourceAddresses[i];
// The binder gives the depth relative to the lambda's
// inner scope. The evaluator is in the outer scope, so we adjust the
// depth by -1 to find the cell in the current context.
dec(sourceAddr.ScopeDepth);
capturedCells[i] := FScope.GetCell(sourceAddr);
end;
Result := TAstValue.FromClosure(TClosureValue.Create(Node, FScope, capturedCells));
end; end;
function TEvaluatorVisitor.VisitFunctionCall(const Node: IFunctionCallNode): TAstValue; function TEvaluatorVisitor.VisitFunctionCall(const Node: IFunctionCallNode): TAstValue;
@@ -510,17 +550,21 @@ begin
if not Assigned(descriptor) then if not Assigned(descriptor) then
raise EParserError.Create('Lambda has no scope descriptor. Did the binder run?'); raise EParserError.Create('Lambda has no scope descriptor. Did the binder run?');
var callScope := descriptor.CreateScope(closure.ClosureScope); // Create the execution scope for the call, providing the captured upvalues.
var callScope := TExecutionScope.Create(closure.ClosureScope, descriptor, (closure as TClosureValue).Upvalues) as IExecutionScope;
var adr: TResolvedAddress; var adr: TResolvedAddress;
adr.Kind := akLocalOrParent;
adr.ScopeDepth := 0; adr.ScopeDepth := 0;
// Slot 0 is 'Self'.
adr.SlotIndex := 0; adr.SlotIndex := 0;
callScope[adr] := calleeValue; callScope.Values[adr] := calleeValue;
for i := 0 to Node.Arguments.Count - 1 do for i := 0 to Node.Arguments.Count - 1 do
begin begin
adr.SlotIndex := closure.Parameters[i].Address.SlotIndex; adr.SlotIndex := closure.Parameters[i].Address.SlotIndex;
callScope[adr] := Node.Arguments[i].Accept(Self); callScope.Values[adr] := Node.Arguments[i].Accept(Self);
end; end;
Result := closure.Body.Accept(CreateVisitorForScope(callScope)); Result := closure.Body.Accept(CreateVisitorForScope(callScope));
+23
View File
@@ -46,6 +46,7 @@ type
ISeriesLengthNode = interface; ISeriesLengthNode = interface;
IExecutionScope = interface; IExecutionScope = interface;
IScopeDescriptor = interface; IScopeDescriptor = interface;
IValueCell = interface;
// --- Concrete Type Definitions --- // --- Concrete Type Definitions ---
@@ -56,10 +57,12 @@ type
function GetBody: IExpressionNode; function GetBody: IExpressionNode;
function GetClosureScope: IExecutionScope; function GetClosureScope: IExecutionScope;
function GetParameters: TArray<IIdentifierNode>; function GetParameters: TArray<IIdentifierNode>;
function GetUpvalues: TArray<IValueCell>;
{$endregion} {$endregion}
property Body: IExpressionNode read GetBody; property Body: IExpressionNode read GetBody;
property ClosureScope: IExecutionScope read GetClosureScope; property ClosureScope: IExecutionScope read GetClosureScope;
property Parameters: TArray<IIdentifierNode> read GetParameters; property Parameters: TArray<IIdentifierNode> read GetParameters;
property Upvalues: TArray<IValueCell> read GetUpvalues;
end; end;
TVal<T> = class(TInterfacedObject) TVal<T> = class(TInterfacedObject)
@@ -96,7 +99,21 @@ type
property Kind: TAstValueKind read GetKind; property Kind: TAstValueKind read GetKind;
end; end;
// A managed, reference-counted cell that holds a TAstValue,
// allowing it to be shared by reference between scopes (for closures).
IValueCell = interface
{$region 'private'}
function GetValue: TAstValue;
procedure SetValue(const AValue: TAstValue);
{$endregion}
property Value: TAstValue read GetValue write SetValue;
end;
// Defines how an identifier's address was resolved.
TAddressKind = (akUnresolved, akLocalOrParent, akUpvalue);
TResolvedAddress = record TResolvedAddress = record
Kind: TAddressKind;
ScopeDepth: Integer; ScopeDepth: Integer;
SlotIndex: Integer; SlotIndex: Integer;
end; end;
@@ -106,12 +123,14 @@ type
function GetParent: IExecutionScope; function GetParent: IExecutionScope;
function GetValues(const Address: TResolvedAddress): TAstValue; function GetValues(const Address: TResolvedAddress): TAstValue;
procedure SetValues(const Address: TResolvedAddress; const Value: TAstValue); procedure SetValues(const Address: TResolvedAddress; const Value: TAstValue);
function GetCell(const Address: TResolvedAddress): IValueCell;
{$endregion} {$endregion}
procedure Define(const Name: string; const Value: TAstValue); procedure Define(const Name: string; const Value: TAstValue);
function Dump: string; function Dump: string;
procedure Clear; procedure Clear;
property Cell[const Address: TResolvedAddress]: IValueCell read GetCell;
property Values[const Address: TResolvedAddress]: TAstValue read GetValues write SetValues; default; property Values[const Address: TResolvedAddress]: TAstValue read GetValues write SetValues; default;
property Parent: IExecutionScope read GetParent; property Parent: IExecutionScope read GetParent;
@@ -222,10 +241,14 @@ type
function GetParameters: TArray<IIdentifierNode>; function GetParameters: TArray<IIdentifierNode>;
function GetBody: IExpressionNode; function GetBody: IExpressionNode;
function GetScopeDescriptor: IScopeDescriptor; function GetScopeDescriptor: IScopeDescriptor;
function GetUpvalues: TArray<IIdentifierNode>;
function GetUpvalueSourceAddresses: TArray<TResolvedAddress>;
{$endregion} {$endregion}
property Parameters: TArray<IIdentifierNode> read GetParameters; property Parameters: TArray<IIdentifierNode> read GetParameters;
property Body: IExpressionNode read GetBody; property Body: IExpressionNode read GetBody;
property ScopeDescriptor: IScopeDescriptor read GetScopeDescriptor; property ScopeDescriptor: IScopeDescriptor read GetScopeDescriptor;
property Upvalues: TArray<IIdentifierNode> read GetUpvalues;
property UpvalueSourceAddresses: TArray<TResolvedAddress> read GetUpvalueSourceAddresses;
end; end;
IFunctionCallNode = interface(IExpressionNode) IFunctionCallNode = interface(IExpressionNode)
+124 -27
View File
@@ -12,21 +12,28 @@ type
TExecutionScope = class(TInterfacedObject, IExecutionScope) TExecutionScope = class(TInterfacedObject, IExecutionScope)
private private
FParent: IExecutionScope; FParent: IExecutionScope;
FValues: TArray<TAstValue>; FValues: TArray<IValueCell>;
// Stores references to the value cells captured by a closure.
FCapturedUpvalues: TArray<IValueCell>;
FNameToIndex: TDictionary<string, Integer>; FNameToIndex: TDictionary<string, Integer>;
procedure DumpScope(const ABuilder: TStringBuilder; AIndent: Integer); procedure DumpScope(const ABuilder: TStringBuilder; AIndent: Integer);
function GetValues(const Address: TResolvedAddress): TAstValue; function GetValues(const Address: TResolvedAddress): TAstValue;
procedure SetValues(const Address: TResolvedAddress; const Value: TAstValue); procedure SetValues(const Address: TResolvedAddress; const Value: TAstValue);
function GetParent: IExecutionScope; function GetParent: IExecutionScope;
function GetCell(const Address: TResolvedAddress): IValueCell;
public public
constructor Create(AParent: IExecutionScope = nil; const ADescriptor: IScopeDescriptor = nil); constructor Create(
AParent: IExecutionScope = nil;
const ADescriptor: IScopeDescriptor = nil;
const ACapturedUpvalues: TArray<IValueCell> = nil
);
destructor Destroy; override; destructor Destroy; override;
procedure Clear; procedure Clear;
function Dump: string; function Dump: string;
procedure Define(const Name: string; const Value: TAstValue); procedure Define(const Name: string; const Value: TAstValue);
property NameToIndex: TDictionary<string, Integer> read FNameToIndex; property NameToIndex: TDictionary<string, Integer> read FNameToIndex;
property Parent: IExecutionScope read FParent; property Parent: IExecutionScope read FParent;
property Values: TArray<TAstValue> read FValues; property Values: TArray<IValueCell> read FValues;
end; end;
implementation implementation
@@ -34,19 +41,54 @@ implementation
uses uses
System.Generics.Defaults; System.Generics.Defaults;
type
TValueCell = class(TInterfacedObject, IValueCell)
private
FValue: TAstValue;
function GetValue: TAstValue;
procedure SetValue(const AValue: TAstValue);
end;
{ TValueCell }
function TValueCell.GetValue: TAstValue;
begin
Result := FValue;
end;
procedure TValueCell.SetValue(const AValue: TAstValue);
begin
FValue := AValue;
end;
{ TExecutionScope } { TExecutionScope }
constructor TExecutionScope.Create(AParent: IExecutionScope = nil; const ADescriptor: IScopeDescriptor = nil); { TExecutionScope }
constructor TExecutionScope.Create(
AParent: IExecutionScope;
const ADescriptor: IScopeDescriptor;
const ACapturedUpvalues: TArray<IValueCell>
);
var
slotCount: Integer;
i: Integer;
begin begin
inherited Create; inherited Create;
FParent := AParent; FParent := AParent;
FValues := []; FValues := [];
FNameToIndex := TDictionary<string, Integer>.Create; FNameToIndex := TDictionary<string, Integer>.Create;
FCapturedUpvalues := ACapturedUpvalues; // Store upvalues
if ADescriptor <> nil then if ADescriptor <> nil then
begin begin
for var item in ADescriptor.Symbols do for var item in ADescriptor.Symbols do
FNameToIndex.AddOrSetValue(item.Key, item.Value); FNameToIndex.AddOrSetValue(item.Key, item.Value);
SetLength(FValues, ADescriptor.SlotCount);
slotCount := ADescriptor.SlotCount;
SetLength(FValues, slotCount);
for i := 0 to slotCount - 1 do
FValues[i] := TValueCell.Create as IValueCell;
end; end;
end; end;
@@ -56,6 +98,26 @@ begin
inherited Destroy; inherited Destroy;
end; end;
function TExecutionScope.GetCell(const Address: TResolvedAddress): IValueCell;
var
targetScope: TExecutionScope;
i: Integer;
begin
// Cells can only be retrieved from local/parent scopes.
if Address.Kind <> akLocalOrParent then
raise EInvalidOpException.Create('Cannot get a cell for a non-local address.');
targetScope := Self;
for i := 1 to Address.ScopeDepth do
begin
targetScope := targetScope.Parent as TExecutionScope;
Assert(Assigned(targetScope), 'Invalid scope depth during cell retrieval.');
end;
Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(targetScope.FValues)), 'Invalid scope index during cell retrieval.');
Result := targetScope.FValues[Address.SlotIndex];
end;
function TExecutionScope.GetParent: IExecutionScope; function TExecutionScope.GetParent: IExecutionScope;
begin begin
Result := FParent; Result := FParent;
@@ -76,7 +138,8 @@ begin
index := Length(FValues); index := Length(FValues);
SetLength(FValues, index + 1); SetLength(FValues, index + 1);
FValues[index] := Value; FValues[index] := TValueCell.Create as IValueCell;
FValues[index].Value := Value;
FNameToIndex.Add(Name, index); FNameToIndex.Add(Name, index);
end; end;
@@ -97,7 +160,8 @@ begin
); );
for pair in sortedPairs do for pair in sortedPairs do
ABuilder.AppendLine(indentStr + Format(' [%d] %s: %s', [pair.Value, pair.Key, FValues[pair.Value].ToString])); // Access the value inside the cell for printing.
ABuilder.AppendLine(indentStr + Format(' [%d] %s: %s', [pair.Value, pair.Key, FValues[pair.Value].Value.ToString]));
end end
else else
begin begin
@@ -130,16 +194,33 @@ var
targetScope: TExecutionScope; targetScope: TExecutionScope;
i: Integer; i: Integer;
begin begin
targetScope := Self; case Address.Kind of
akUpvalue:
for i := 0 to Address.ScopeDepth - 1 do begin
begin Assert(Assigned(FCapturedUpvalues), 'Attempt to access an upvalue in a scope with no closure context.');
targetScope := targetScope.Parent as TExecutionScope; Assert(
Assert(Assigned(targetScope), 'Invalid scope depth during value retrieval.'); (Address.SlotIndex >= 0) and (Address.SlotIndex < Length(FCapturedUpvalues)),
'Invalid upvalue index during value retrieval.'
);
Result := FCapturedUpvalues[Address.SlotIndex].Value;
end;
akLocalOrParent:
begin
targetScope := Self;
for i := 1 to Address.ScopeDepth do
begin
targetScope := targetScope.Parent as TExecutionScope;
Assert(Assigned(targetScope), 'Invalid scope depth during value retrieval.');
end;
Assert(
(Address.SlotIndex >= 0) and (Address.SlotIndex < Length(targetScope.Values)),
'Invalid scope index during value retrieval.'
);
Result := targetScope.Values[Address.SlotIndex].Value;
end;
else
raise EInvalidOpException.Create('Cannot get value for an unresolved address.');
end; end;
Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(targetScope.Values)), 'Invalid scope index during value retrieval.');
Result := targetScope.Values[Address.SlotIndex];
end; end;
procedure TExecutionScope.SetValues(const Address: TResolvedAddress; const Value: TAstValue); procedure TExecutionScope.SetValues(const Address: TResolvedAddress; const Value: TAstValue);
@@ -147,18 +228,34 @@ var
targetScope: IExecutionScope; targetScope: IExecutionScope;
i: Integer; i: Integer;
begin begin
targetScope := Self; case Address.Kind of
for i := 1 to Address.ScopeDepth do akUpvalue:
begin begin
if Assigned(targetScope) then Assert(Assigned(FCapturedUpvalues), 'Attempt to access an upvalue in a scope with no closure context.');
targetScope := targetScope.Parent Assert(
else (Address.SlotIndex >= 0) and (Address.SlotIndex < Length(FCapturedUpvalues)),
raise EInvalidOpException.Create('Invalid scope depth during assignment.'); 'Invalid upvalue index during value assignment.'
end; );
FCapturedUpvalues[Address.SlotIndex].Value := Value;
end;
akLocalOrParent:
begin
targetScope := Self;
for i := 0 to Address.ScopeDepth - 1 do
begin
if Assigned(targetScope) then
targetScope := targetScope.Parent
else
raise EInvalidOpException.Create('Invalid scope depth during assignment.');
end;
if Address.SlotIndex >= Length((targetScope as TExecutionScope).FValues) then if Address.SlotIndex >= Length((targetScope as TExecutionScope).Values) then
raise EInvalidOpException.Create('Invalid scope index during assignment.'); raise EInvalidOpException.Create('Invalid scope index during assignment.');
(targetScope as TExecutionScope).FValues[Address.SlotIndex] := Value; (targetScope as TExecutionScope).Values[Address.SlotIndex].Value := Value;
end;
else
raise EInvalidOpException.Create('Cannot set value for an unresolved address.');
end;
end; end;
end. end.
+150 -19
View File
@@ -6,6 +6,7 @@ uses
System.Classes, System.Classes,
System.SysUtils, System.SysUtils,
System.Generics.Collections, System.Generics.Collections,
System.Generics.Defaults,
Myc.Data.Scalar, Myc.Data.Scalar,
Myc.Ast.Nodes, Myc.Ast.Nodes,
Myc.Ast.Scope; Myc.Ast.Scope;
@@ -121,9 +122,7 @@ type
public public
constructor Create(AName: string); constructor Create(AName: string);
function Accept(const Visitor: IAstVisitor): TAstValue; override; function Accept(const Visitor: IAstVisitor): TAstValue; override;
property IsResolved: Boolean read GetIsResolved; property IsResolved: Boolean read GetIsResolved;
property Name: string read FName; property Name: string read FName;
property Address: TResolvedAddress read GetAddress; property Address: TResolvedAddress read GetAddress;
end; end;
@@ -187,14 +186,20 @@ type
private private
FParameters: TArray<IIdentifierNode>; FParameters: TArray<IIdentifierNode>;
FBody: IExpressionNode; FBody: IExpressionNode;
FScopeDescriptor: IScopeDescriptor; // Backing field for the new property FScopeDescriptor: IScopeDescriptor;
FUpvalues: TArray<IIdentifierNode>;
FUpvalueSourceAddresses: TArray<TResolvedAddress>;
function GetParameters: TArray<IIdentifierNode>; function GetParameters: TArray<IIdentifierNode>;
function GetBody: IExpressionNode; function GetBody: IExpressionNode;
function GetScopeDescriptor: IScopeDescriptor; function GetScopeDescriptor: IScopeDescriptor;
function GetUpvalues: TArray<IIdentifierNode>;
function GetUpvalueSourceAddresses: TArray<TResolvedAddress>;
public public
constructor Create(const AParameters: TArray<IIdentifierNode>; const ABody: IExpressionNode); constructor Create(const AParameters: TArray<IIdentifierNode>; const ABody: IExpressionNode);
function Accept(const Visitor: IAstVisitor): TAstValue; override; function Accept(const Visitor: IAstVisitor): TAstValue; override;
procedure SetUpvalueData(const AUpvalues: TArray<IIdentifierNode>; const ASourceAddresses: TArray<TResolvedAddress>);
property ScopeDescriptor: IScopeDescriptor read GetScopeDescriptor; property ScopeDescriptor: IScopeDescriptor read GetScopeDescriptor;
property Upvalues: TArray<IIdentifierNode> read GetUpvalues;
end; end;
{ TFunctionCallNode } { TFunctionCallNode }
@@ -303,21 +308,46 @@ type
function Accept(const Visitor: IAstVisitor): TAstValue; override; function Accept(const Visitor: IAstVisitor): TAstValue; override;
end; end;
TResolvedAddressComparer = class(TEqualityComparer<TResolvedAddress>)
public
function Equals(const Left, Right: TResolvedAddress): Boolean; override;
function GetHashCode(const Value: TResolvedAddress): Integer; override;
end;
// --- Binder Implementation --- // --- Binder Implementation ---
TBinder = class(TAstTraverser) TBinder = class(TAstTraverser)
private private
FCurrentDescriptor: IScopeDescriptor; FCurrentDescriptor: IScopeDescriptor;
FUpvalueMapStack: TStack<TDictionary<TResolvedAddress, Integer>>;
FUpvalueNodesStack: TStack<TList<IIdentifierNode>>;
procedure EnterScope; procedure EnterScope;
procedure ExitScope; procedure ExitScope;
public public
constructor Create(const AInitialScope: IExecutionScope); constructor Create(const AInitialScope: IExecutionScope);
destructor Destroy; override;
function VisitIdentifier(const Node: IIdentifierNode): TAstValue; override; function VisitIdentifier(const Node: IIdentifierNode): TAstValue; override;
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue; override; function VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue; override;
function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAstValue; override; function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAstValue; override;
property CurrentDescriptor: IScopeDescriptor read FCurrentDescriptor; property CurrentDescriptor: IScopeDescriptor read FCurrentDescriptor;
end; end;
{ TResolvedAddressComparer }
function TResolvedAddressComparer.Equals(const Left, Right: TResolvedAddress): Boolean;
begin
Result := (Left.Kind = Right.Kind) and (Left.ScopeDepth = Right.ScopeDepth) and (Left.SlotIndex = Right.SlotIndex);
end;
function TResolvedAddressComparer.GetHashCode(const Value: TResolvedAddress): Integer;
begin
// Simple combining hash function
Result := 17;
Result := Result * 23 + Ord(Value.Kind);
Result := Result * 23 + Value.ScopeDepth;
Result := Result * 23 + Value.SlotIndex;
end;
{ TScopeDescriptor } { TScopeDescriptor }
constructor TScopeDescriptor.Create(AParent: IScopeDescriptor); constructor TScopeDescriptor.Create(AParent: IScopeDescriptor);
@@ -406,6 +436,8 @@ constructor TIdentifierNode.Create(AName: string);
begin begin
inherited Create; inherited Create;
FName := AName; FName := AName;
// Default to unresolved.
FResolvedAddress.Kind := akUnresolved;
FResolvedAddress.ScopeDepth := -1; FResolvedAddress.ScopeDepth := -1;
FResolvedAddress.SlotIndex := -1; FResolvedAddress.SlotIndex := -1;
end; end;
@@ -417,7 +449,8 @@ end;
function TIdentifierNode.GetIsResolved: Boolean; function TIdentifierNode.GetIsResolved: Boolean;
begin begin
Result := FResolvedAddress.ScopeDepth >= 0; // An identifier is resolved if its kind is not unresolved anymore.
Result := FResolvedAddress.Kind <> akUnresolved;
end; end;
function TIdentifierNode.GetName: string; function TIdentifierNode.GetName: string;
@@ -429,7 +462,6 @@ function TIdentifierNode.GetAddress: TResolvedAddress;
begin begin
if not IsResolved then if not IsResolved then
raise EInvalidOpException.Create('Identifier not bound'); raise EInvalidOpException.Create('Identifier not bound');
Result := FResolvedAddress; Result := FResolvedAddress;
end; end;
@@ -555,6 +587,19 @@ begin
FBody := ABody; FBody := ABody;
FParameters := AParameters; FParameters := AParameters;
FScopeDescriptor := nil; FScopeDescriptor := nil;
FUpvalues := [];
FUpvalueSourceAddresses := []; // Initialize new field
end;
function TLambdaExpressionNode.GetUpvalueSourceAddresses: TArray<TResolvedAddress>;
begin
Result := FUpvalueSourceAddresses;
end;
procedure TLambdaExpressionNode.SetUpvalueData(const AUpvalues: TArray<IIdentifierNode>; const ASourceAddresses: TArray<TResolvedAddress>);
begin
FUpvalues := AUpvalues;
FUpvalueSourceAddresses := ASourceAddresses;
end; end;
function TLambdaExpressionNode.Accept(const Visitor: IAstVisitor): TAstValue; function TLambdaExpressionNode.Accept(const Visitor: IAstVisitor): TAstValue;
@@ -577,6 +622,11 @@ begin
Result := FScopeDescriptor; Result := FScopeDescriptor;
end; end;
function TLambdaExpressionNode.GetUpvalues: TArray<IIdentifierNode>;
begin
Result := FUpvalues;
end;
{ TFunctionCallNode } { TFunctionCallNode }
constructor TFunctionCallNode.Create(const ACallee: IExpressionNode; const AArguments: array of IExpressionNode); constructor TFunctionCallNode.Create(const ACallee: IExpressionNode; const AArguments: array of IExpressionNode);
@@ -807,6 +857,21 @@ constructor TBinder.Create(const AInitialScope: IExecutionScope);
begin begin
inherited Create; inherited Create;
FCurrentDescriptor := TAst.CreateDescriptor(AInitialScope); FCurrentDescriptor := TAst.CreateDescriptor(AInitialScope);
FUpvalueMapStack := TStack<TDictionary<TResolvedAddress, Integer>>.Create;
FUpvalueNodesStack := TStack<TList<IIdentifierNode>>.Create;
end;
destructor TBinder.Destroy;
begin
while FUpvalueMapStack.Count > 0 do
FUpvalueMapStack.Pop.Free;
FUpvalueMapStack.Free;
while FUpvalueNodesStack.Count > 0 do
FUpvalueNodesStack.Pop.Free;
FUpvalueNodesStack.Free;
inherited;
end; end;
procedure TBinder.EnterScope; procedure TBinder.EnterScope;
@@ -821,17 +886,45 @@ end;
function TBinder.VisitIdentifier(const Node: IIdentifierNode): TAstValue; function TBinder.VisitIdentifier(const Node: IIdentifierNode): TAstValue;
var var
index, depth: Integer; originalDepth, originalIndex: Integer;
identNode: TIdentifierNode; identNode: TIdentifierNode;
upvalueMap: TDictionary<TResolvedAddress, Integer>;
upvalueNodes: TList<IIdentifierNode>;
originalAddress: TResolvedAddress;
upvalueIndex: Integer;
begin begin
identNode := Node as TIdentifierNode; identNode := Node as TIdentifierNode;
if identNode.IsResolved then if identNode.IsResolved then
Exit; Exit;
if (FCurrentDescriptor as TScopeDescriptor).FindSymbol(identNode.Name, index, depth) then if (FCurrentDescriptor as TScopeDescriptor).FindSymbol(identNode.Name, originalIndex, originalDepth) then
begin begin
identNode.FResolvedAddress.ScopeDepth := depth; if (originalDepth > 0) and (FUpvalueMapStack.Count > 0) then
identNode.FResolvedAddress.SlotIndex := index; begin
upvalueMap := FUpvalueMapStack.Peek;
upvalueNodes := FUpvalueNodesStack.Peek;
originalAddress.Kind := akLocalOrParent;
originalAddress.ScopeDepth := originalDepth;
originalAddress.SlotIndex := originalIndex;
if not upvalueMap.TryGetValue(originalAddress, upvalueIndex) then
begin
upvalueIndex := upvalueNodes.Count;
upvalueMap.Add(originalAddress, upvalueIndex);
upvalueNodes.Add(identNode);
end;
identNode.FResolvedAddress.Kind := akUpvalue;
identNode.FResolvedAddress.SlotIndex := upvalueIndex;
identNode.FResolvedAddress.ScopeDepth := 0;
end
else
begin
identNode.FResolvedAddress.Kind := akLocalOrParent;
identNode.FResolvedAddress.ScopeDepth := originalDepth;
identNode.FResolvedAddress.SlotIndex := originalIndex;
end;
end end
else else
raise Exception.CreateFmt('Undefined identifier: "%s"', [identNode.Name]); raise Exception.CreateFmt('Undefined identifier: "%s"', [identNode.Name]);
@@ -840,27 +933,65 @@ end;
function TBinder.VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue; function TBinder.VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue;
var var
param: IIdentifierNode; param: IIdentifierNode;
upvalueMap: TDictionary<TResolvedAddress, Integer>;
upvalueNodes: TList<IIdentifierNode>;
sourceAddresses: TArray<TResolvedAddress>;
sortedPairs: TArray<TPair<TResolvedAddress, Integer>>;
begin begin
EnterScope; FUpvalueMapStack.Push(TDictionary<TResolvedAddress, Integer>.Create(TResolvedAddressComparer.Default));
FUpvalueNodesStack.Push(TList<IIdentifierNode>.Create);
try try
(FCurrentDescriptor as TScopeDescriptor).Define('Self'); EnterScope;
try
(FCurrentDescriptor as TScopeDescriptor).Define('Self');
for param in Node.Parameters do for param in Node.Parameters do
(FCurrentDescriptor as TScopeDescriptor).Define(param.Name); (FCurrentDescriptor as TScopeDescriptor).Define(param.Name);
inherited VisitLambdaExpression(Node); inherited VisitLambdaExpression(Node);
// Annotate the lambda node with the completed scope descriptor. (Node as TLambdaExpressionNode).FScopeDescriptor := FCurrentDescriptor;
(Node as TLambdaExpressionNode).FScopeDescriptor := FCurrentDescriptor; finally
ExitScope;
end;
finally finally
ExitScope; upvalueMap := FUpvalueMapStack.Pop;
upvalueNodes := FUpvalueNodesStack.Pop;
// The map's keys are the source addresses, and values are the indices.
// We need to sort by index to get the addresses in the correct order.
sortedPairs := upvalueMap.ToArray;
TArray.Sort<TPair<TResolvedAddress, Integer>>(
sortedPairs,
TComparer<TPair<TResolvedAddress, Integer>>.Construct(
function(const Left, Right: TPair<TResolvedAddress, Integer>): Integer begin Result := Left.Value - Right.Value; end
)
);
SetLength(sourceAddresses, Length(sortedPairs));
for var i := 0 to High(sortedPairs) do
sourceAddresses[i] := sortedPairs[i].Key;
(Node as TLambdaExpressionNode).SetUpvalueData(upvalueNodes.ToArray, sourceAddresses);
upvalueMap.Free;
upvalueNodes.Free;
end; end;
end; end;
function TBinder.VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAstValue; function TBinder.VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAstValue;
var
slotIndex: Integer;
identNode: TIdentifierNode;
begin begin
(FCurrentDescriptor as TScopeDescriptor).Define(Node.Identifier.Name); identNode := Node.Identifier as TIdentifierNode;
inherited;
Node.Initializer.Accept(Self);
slotIndex := (FCurrentDescriptor as TScopeDescriptor).Define(Node.Identifier.Name);
identNode.FResolvedAddress.Kind := akLocalOrParent;
identNode.FResolvedAddress.ScopeDepth := 0;
identNode.FResolvedAddress.SlotIndex := slotIndex;
end; end;
{ TAst } { TAst }