Michael Schimmel
387 lines
13 KiB
ObjectPascal
387 lines
13 KiB
ObjectPascal
unit Myc.Ast.Binding;
|
|
|
|
interface
|
|
|
|
uses
|
|
System.SysUtils,
|
|
System.Classes,
|
|
System.Generics.Collections,
|
|
Myc.Data.Scalar,
|
|
Myc.Data.Value,
|
|
Myc.Ast.Nodes,
|
|
Myc.Ast.Visitor,
|
|
Myc.Ast.Scope,
|
|
Myc.Ast.Analyzer,
|
|
Myc.Ast;
|
|
|
|
type
|
|
IAstBinder = interface(IAstVisitor)
|
|
function Execute(const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
|
|
end;
|
|
|
|
TAstBinder = class; // Forward declaration
|
|
|
|
TAstBinder = class(TAstTransformer, IAstBinder)
|
|
private
|
|
type
|
|
TUpvalueMapping = TDictionary<TResolvedAddress, Integer>;
|
|
private
|
|
FInitialScope: IExecutionScope;
|
|
FCurrentDescriptor: IScopeDescriptor;
|
|
FUpvalueStack: TStack<TUpvalueMapping>;
|
|
FNestedLambdaCount: Integer;
|
|
FBoxedDeclarations: THashSet<IVariableDeclarationNode>;
|
|
|
|
procedure EnterScope;
|
|
procedure ExitScope;
|
|
function IsValidIdentifier(const Name: string): Boolean;
|
|
|
|
protected
|
|
// --- Core Binding Logic (Mutators) ---
|
|
function VisitIdentifier(const Node: IIdentifierNode): IAstNode; override;
|
|
function VisitVariableDeclaration(const Node: IVariableDeclarationNode): IAstNode; override;
|
|
function VisitLambdaExpression(const Node: ILambdaExpressionNode): IAstNode; override;
|
|
// --- Transformation Logic ---
|
|
function VisitFunctionCall(const Node: IFunctionCallNode): IAstNode; override;
|
|
|
|
// --- Standard Traversal (Use inherited) ---
|
|
function VisitKeyword(const Node: IKeywordNode): IAstNode; override;
|
|
function VisitRecurNode(const Node: IRecurNode): IAstNode; override;
|
|
function VisitConstant(const Node: IConstantNode): IAstNode; override;
|
|
function VisitCreateSeries(const Node: ICreateSeriesNode): IAstNode; override;
|
|
function VisitAddSeriesItem(const Node: IAddSeriesItemNode): IAstNode; override;
|
|
function VisitSeriesLength(const Node: ISeriesLengthNode): IAstNode; override;
|
|
|
|
public
|
|
constructor Create(const AInitialScope: IExecutionScope);
|
|
destructor Destroy; override;
|
|
function Execute(const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
|
|
|
|
class function Bind(
|
|
const InitialScope: IExecutionScope;
|
|
const RootNode: IAstNode;
|
|
out Descriptor: IScopeDescriptor
|
|
): IAstNode; static;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
System.Generics.Defaults,
|
|
System.Character,
|
|
Myc.Data.Keyword;
|
|
|
|
type
|
|
TResolvedAddressComparer = class(TEqualityComparer<TResolvedAddress>)
|
|
public
|
|
function Equals(const Left, Right: TResolvedAddress): Boolean; override;
|
|
function GetHashCode(const Value: TResolvedAddress): Integer; override;
|
|
end;
|
|
|
|
{ TResolvedAddressComparer }
|
|
function TResolvedAddressComparer.Equals(const Left, Right: TResolvedAddress): Boolean;
|
|
begin
|
|
Result := (Left = Right);
|
|
end;
|
|
|
|
function TResolvedAddressComparer.GetHashCode(const Value: TResolvedAddress): Integer;
|
|
begin
|
|
Result := 17;
|
|
Result := Result * 23 + Ord(Value.Kind);
|
|
Result := Result * 23 + Value.ScopeDepth;
|
|
Result := Result * 23 + Value.SlotIndex;
|
|
end;
|
|
|
|
{ TAstBinder }
|
|
|
|
constructor TAstBinder.Create(const AInitialScope: IExecutionScope);
|
|
begin
|
|
inherited Create;
|
|
Assert(Assigned(AInitialScope));
|
|
|
|
FInitialScope := AInitialScope;
|
|
FCurrentDescriptor := AInitialScope.CreateDescriptor;
|
|
FUpvalueStack := TObjectStack<TUpvalueMapping>.Create(True); // Use Comparer
|
|
FNestedLambdaCount := 0;
|
|
FBoxedDeclarations := nil;
|
|
end;
|
|
|
|
destructor TAstBinder.Destroy;
|
|
begin
|
|
FUpvalueStack.Free;
|
|
FBoxedDeclarations.Free;
|
|
inherited;
|
|
end;
|
|
|
|
class function TAstBinder.Bind(const InitialScope: IExecutionScope; const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
|
|
begin
|
|
var binder := TAstBinder.Create(InitialScope) as IAstBinder;
|
|
Result := binder.Execute(RootNode, Descriptor);
|
|
end;
|
|
|
|
procedure TAstBinder.EnterScope;
|
|
begin
|
|
FCurrentDescriptor := TScope.CreateDescriptor(FCurrentDescriptor);
|
|
end;
|
|
|
|
procedure TAstBinder.ExitScope;
|
|
begin
|
|
FCurrentDescriptor := FCurrentDescriptor.Parent;
|
|
end;
|
|
|
|
function TAstBinder.IsValidIdentifier(const Name: string): Boolean;
|
|
var
|
|
c: Char;
|
|
begin
|
|
if Name.IsEmpty then
|
|
exit(False);
|
|
c := Name[1];
|
|
if not (c.IsLetter or (c = '_')) then
|
|
exit(False);
|
|
for c in Name do
|
|
begin
|
|
if not (c.IsLetterOrDigit or (c = '_') or (c = '-')) then
|
|
exit(False);
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function TAstBinder.Execute(const RootNode: IAstNode; out Descriptor: IScopeDescriptor): IAstNode;
|
|
begin
|
|
// Pre-pass: Find all variables that need boxing
|
|
FBoxedDeclarations := TUpvalueAnalyzer.Analyze(RootNode, FCurrentDescriptor.Parent);
|
|
try
|
|
EnterScope;
|
|
try
|
|
// Main pass: Run the mutator
|
|
Result := Accept(RootNode); // Accept returns IAstNode
|
|
if not Assigned(Result) then
|
|
Result := TAst.Block([]);
|
|
|
|
// Set the type of the root expression (e.g., the final 'do' block)
|
|
Descriptor := FCurrentDescriptor;
|
|
finally
|
|
ExitScope;
|
|
end;
|
|
finally
|
|
FBoxedDeclarations.Free; // Free the set
|
|
FBoxedDeclarations := nil;
|
|
end;
|
|
end;
|
|
|
|
function TAstBinder.VisitFunctionCall(const Node: IFunctionCallNode): IAstNode;
|
|
begin
|
|
// --- Transformation: Keyword-as-Function ---
|
|
if Node.Callee.Kind = akKeyword then
|
|
begin
|
|
var keywordNode := Node.Callee.AsKeyword;
|
|
if Length(Node.Arguments) <> 1 then
|
|
raise EArgumentException.CreateFmt(
|
|
'Keyword :%s expects exactly one argument (the record/map), but got %d',
|
|
[keywordNode.Value.Name, Length(Node.Arguments)]);
|
|
|
|
// Manually visit the argument, as we are replacing this node
|
|
var baseNode := Accept(Node.Arguments[0]);
|
|
var memberAccessNode := TAst.MemberAccess(baseNode, keywordNode);
|
|
|
|
// Visit the *new* node to bind it
|
|
Result := Accept(memberAccessNode);
|
|
exit;
|
|
end;
|
|
|
|
// --- Default: Bind as a standard function call ---
|
|
// Use the inherited implementation to visit children (Callee, Arguments)
|
|
// and mutate their properties in place.
|
|
Result := inherited VisitFunctionCall(Node);
|
|
|
|
// Set metadata for *this* node
|
|
(Node as TFunctionCallNode).IsTailCall := False; // Default, TCO (Phase 5) will set this
|
|
end;
|
|
|
|
function TAstBinder.VisitConstant(const Node: IConstantNode): IAstNode;
|
|
begin
|
|
// Binding pass does not assign types.
|
|
Result := Node;
|
|
end;
|
|
|
|
function TAstBinder.VisitKeyword(const Node: IKeywordNode): IAstNode;
|
|
begin
|
|
// Binding pass does not assign types.
|
|
Result := Node;
|
|
end;
|
|
|
|
function TAstBinder.VisitCreateSeries(const Node: ICreateSeriesNode): IAstNode;
|
|
begin
|
|
// Binding pass does not assign types.
|
|
Result := Node;
|
|
end;
|
|
|
|
function TAstBinder.VisitAddSeriesItem(const Node: IAddSeriesItemNode): IAstNode;
|
|
begin
|
|
// Visit children
|
|
Result := inherited VisitAddSeriesItem(Node);
|
|
// Binding pass does not assign types.
|
|
end;
|
|
|
|
function TAstBinder.VisitSeriesLength(const Node: ISeriesLengthNode): IAstNode;
|
|
begin
|
|
// Visit children
|
|
Result := inherited VisitSeriesLength(Node);
|
|
// Binding pass does not assign types.
|
|
end;
|
|
|
|
function TAstBinder.VisitLambdaExpression(const Node: ILambdaExpressionNode): IAstNode;
|
|
var
|
|
i: integer;
|
|
N: TLambdaExpressionNode;
|
|
adr: TResolvedAddress;
|
|
begin
|
|
N := (Node as TLambdaExpressionNode);
|
|
|
|
// We do *not* call inherited, as we must manage the scope manually.
|
|
|
|
FUpvalueStack.Push(TUpvalueMapping.Create(TResolvedAddressComparer.Create));
|
|
try
|
|
EnterScope;
|
|
try
|
|
// Define <self> (slot 0)
|
|
FCurrentDescriptor.Define('<self>');
|
|
|
|
// Define parameters
|
|
for i := 0 to High(N.Parameters) do
|
|
begin
|
|
var paramNode := N.Parameters[i]; // This is a TIdentifierNode
|
|
var slotIndex := FCurrentDescriptor.Define(paramNode.Name);
|
|
adr := TResolvedAddress.Create(akLocalOrParent, 0, slotIndex);
|
|
|
|
// --- Replace Node ---
|
|
// Create a new TBoundIdentifierNode (implementation is in Myc.Ast)
|
|
var boundParamNode := TAst.BoundIdentifier(paramNode.Name, adr);
|
|
// Replace it in the parameter array
|
|
N.Parameters[i] := boundParamNode;
|
|
end;
|
|
|
|
// Visit the body *within the new scope*
|
|
var lastNestedLambdaCount := FNestedLambdaCount;
|
|
N.Body := Accept(N.Body);
|
|
N.HasNestedLambdas := FNestedLambdaCount > lastNestedLambdaCount;
|
|
|
|
// Save the descriptor for the evaluator
|
|
N.ScopeDescriptor := FCurrentDescriptor;
|
|
finally
|
|
ExitScope;
|
|
end;
|
|
|
|
// --- Extract Upvalues ---
|
|
var upvalueMapping := FUpvalueStack.Peek;
|
|
var sortedPairs := upvalueMapping.ToArray;
|
|
// Sort by index (Value)
|
|
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
|
|
)
|
|
);
|
|
|
|
var uvArr: TArray<TResolvedAddress>;
|
|
SetLength(uvArr, Length(sortedPairs));
|
|
for i := 0 to High(uvArr) do
|
|
uvArr[i] := sortedPairs[i].Key;
|
|
N.Upvalues := uvArr;
|
|
|
|
finally
|
|
FUpvalueStack.Pop;
|
|
end;
|
|
|
|
inc(FNestedLambdaCount);
|
|
// Type will be set by TypeChecker
|
|
Result := Node;
|
|
end;
|
|
|
|
function TAstBinder.VisitRecurNode(const Node: IRecurNode): IAstNode;
|
|
begin
|
|
// Visit children
|
|
Result := inherited VisitRecurNode(Node);
|
|
// Binding pass does not assign types.
|
|
end;
|
|
|
|
function TAstBinder.VisitIdentifier(const Node: IIdentifierNode): IAstNode;
|
|
var
|
|
symbol: TResolvedSymbol;
|
|
adr: TResolvedAddress;
|
|
begin
|
|
// We only bind nodes that are the base parser type.
|
|
if Node.Kind = akIdentifier then
|
|
begin
|
|
symbol := FCurrentDescriptor.FindSymbol(Node.Name);
|
|
adr := symbol.Address;
|
|
|
|
if adr.Kind = akUnresolved then
|
|
raise Exception.CreateFmt('Undefined identifier: "%s"', [Node.Name]);
|
|
|
|
if adr.Kind = akLocalOrParent then
|
|
begin
|
|
if (adr.ScopeDepth > 0) and (FUpvalueStack.Count > 0) then
|
|
begin
|
|
// --- Handle Upvalue ---
|
|
var upvalueMap := FUpvalueStack.Peek;
|
|
// Adjust address to be relative to the captured scope
|
|
dec(adr.ScopeDepth);
|
|
|
|
var upvalueIndex: Integer;
|
|
if not upvalueMap.TryGetValue(adr, upvalueIndex) then
|
|
begin
|
|
// This is a new upvalue for this lambda
|
|
upvalueIndex := upvalueMap.Count;
|
|
upvalueMap.Add(adr, upvalueIndex);
|
|
end;
|
|
|
|
// Create final upvalue address
|
|
adr := TResolvedAddress.Create(akUpvalue, 0, upvalueIndex);
|
|
end;
|
|
// else: It's a local (ScopeDepth=0), adr is already correct.
|
|
end;
|
|
// else: It was already an upvalue (e.g. nested lambda), adr is correct.
|
|
|
|
// --- Replace Node ---
|
|
// Create the new TBoundIdentifierNode (implementation is in Myc.Ast)
|
|
Result := TAst.BoundIdentifier(Node.Name, adr);
|
|
end
|
|
else
|
|
begin
|
|
// It's already an akBoundIdentifier (or other specialized type), just return it.
|
|
Result := Node;
|
|
end;
|
|
end;
|
|
|
|
function TAstBinder.VisitVariableDeclaration(const Node: IVariableDeclarationNode): IAstNode;
|
|
var
|
|
slotIndex: Integer;
|
|
address: TResolvedAddress;
|
|
N: TVariableDeclarationNode;
|
|
begin
|
|
N := (Node as TVariableDeclarationNode);
|
|
|
|
if not IsValidIdentifier(N.Identifier.Name) then
|
|
raise Exception.CreateFmt('Invalid identifier name: "%s".', [N.Identifier.Name]);
|
|
|
|
// 1. Visit initializer *first*
|
|
if Assigned(N.Initializer) then
|
|
N.Initializer := Accept(N.Initializer);
|
|
|
|
// 2. Define variable in *current* scope
|
|
slotIndex := FCurrentDescriptor.Define(N.Identifier.Name);
|
|
address := TResolvedAddress.Create(akLocalOrParent, 0, slotIndex);
|
|
|
|
// 3. --- Replace Node ---
|
|
// Replace the TIdentifierNode with a new TBoundIdentifierNode
|
|
N.Identifier := TAst.BoundIdentifier(N.Identifier.Name, address);
|
|
|
|
// 4. Mutate this declaration node
|
|
N.IsBoxed := (FBoxedDeclarations <> nil) and FBoxedDeclarations.Contains(Node);
|
|
|
|
Result := Node;
|
|
end;
|
|
|
|
end.
|