MycLib/Src/AST/Myc.Ast.Compiler.Binder.pas

unit Myc.Ast.Compiler.Binder;

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.Types,
    Myc.Ast.Compiler.Binder.Upvalues,
    Myc.Ast.Identities,
    Myc.Ast;

type
    IAstBinder = interface(IAstVisitor)
        function Execute(const RootNode: IAstNode; out Layout: IScopeLayout): IAstNode;
    end;

    IFunctionDefinitionRegistry = interface
        procedure Register(const Address: TResolvedAddress; const ADef: IFunctionDefinition);
        function Resolve(const Address: TResolvedAddress): IFunctionDefinition;
    end;

    TAstBinder = class(TAstTransformer, IAstBinder)
    private
        type
            TUpvalueMap = TDictionary<TResolvedAddress, Integer>;

    private
        FCurrentBuilder: IScopeBuilder;
        FUpvalueStack: TObjectStack<TUpvalueMap>;

        FArgTypes: TArray<IStaticType>;
        FFunctionRegistry: IFunctionDefinitionRegistry;
        FBoxedDeclarations: THashSet<IVariableDeclarationNode>;
        FLog: ICompilerLog;

        FLambdaCounter: Integer;

        function IsValidIdentifier(const Name: string): Boolean;
        function ResolveSymbol(const Name: string; out Address: TResolvedAddress): Boolean;
        function CaptureUpvalue(const PhysicalAddress: TResolvedAddress): Integer;

    protected
        function VisitIdentifier(const Node: IIdentifierNode): IAstNode; override;
        function VisitVariableDeclaration(const Node: IVariableDeclarationNode): IAstNode; override;
        function VisitAssignment(const Node: IAssignmentNode): IAstNode; override;
        function VisitLambdaExpression(const Node: ILambdaExpressionNode): IAstNode; override;
        function VisitFunctionCall(const Node: IFunctionCallNode): IAstNode; override;

        function VisitConstant(const Node: IConstantNode): IAstNode; override;
        function VisitKeyword(const Node: IKeywordNode): IAstNode; override;
        function VisitCreateSeries(const Node: ICreateSeriesNode): IAstNode; override;

    public
        constructor Create(
            const AParentLayout: IScopeLayout;
            const AFunctionRegistry: IFunctionDefinitionRegistry;
            const AArgTypes: TArray<IStaticType>;
            const ALog: ICompilerLog
        );
        destructor Destroy; override;

        function Execute(const RootNode: IAstNode; out Layout: IScopeLayout): IAstNode;

        class function Bind(
            const ParentLayout: IScopeLayout;
            const RootNode: IAstNode;
            out Layout: IScopeLayout;
            const ALog: ICompilerLog;
            const AFunctionRegistry: IFunctionDefinitionRegistry = nil;
            const AArgTypes: TArray<IStaticType> = nil
        ): IAstNode; static;
    end;

implementation

uses
    System.Generics.Defaults,
    System.Character,
    System.Hash,
    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;

function TResolvedAddressComparer.Equals(const Left, Right: TResolvedAddress): Boolean;
begin
    Result := (Left = Right);
end;

function TResolvedAddressComparer.GetHashCode(const Value: TResolvedAddress): Integer;
begin
    Result := THashBobJenkins.GetHashValue(Value.Kind, SizeOf(TAddressKind), 0);
    Result := THashBobJenkins.GetHashValue(Value.ScopeDepth, SizeOf(Integer), Result);
    Result := THashBobJenkins.GetHashValue(Value.SlotIndex, SizeOf(Integer), Result);
end;

{ TAstBinder }

constructor TAstBinder.Create(
    const AParentLayout: IScopeLayout;
    const AFunctionRegistry: IFunctionDefinitionRegistry;
    const AArgTypes: TArray<IStaticType>;
    const ALog: ICompilerLog
);
begin
    inherited Create;
    FCurrentBuilder := TScope.CreateBuilder(AParentLayout);
    FUpvalueStack := TObjectStack<TUpvalueMap>.Create(True);
    FUpvalueStack.Push(TUpvalueMap.Create(TResolvedAddressComparer.Create));

    FFunctionRegistry := AFunctionRegistry;
    FArgTypes := AArgTypes;
    FLog := ALog;
    FBoxedDeclarations := nil;
    FLambdaCounter := 0;
end;

destructor TAstBinder.Destroy;
begin
    FUpvalueStack.Free;
    FBoxedDeclarations.Free;
    inherited;
end;

class function TAstBinder.Bind(
    const ParentLayout: IScopeLayout;
    const RootNode: IAstNode;
    out Layout: IScopeLayout;
    const ALog: ICompilerLog;
    const AFunctionRegistry: IFunctionDefinitionRegistry = nil;
    const AArgTypes: TArray<IStaticType> = nil
): IAstNode;
begin
    var binder := TAstBinder.Create(ParentLayout, AFunctionRegistry, AArgTypes, ALog) as IAstBinder;
    Result := binder.Execute(RootNode, Layout);
end;

function TAstBinder.Execute(const RootNode: IAstNode; out Layout: IScopeLayout): IAstNode;
begin
    FBoxedDeclarations := TUpvalueAnalyzer.Analyze(RootNode);

    Result := Accept(RootNode);
    if not Assigned(Result) then
        Result := TAst.Block([], nil);

    Layout := FCurrentBuilder.Build;
end;

function TAstBinder.IsValidIdentifier(const Name: string): Boolean;
var
    c: Char;
begin
    if Name.IsEmpty then
        exit(False);

    for c in Name do
        if not (c.IsLetterOrDigit or (c = '_') or (c = '-') or (c = '#')) then
            exit(False);

    c := Name[1];
    if not (c.IsLetter or (c = '_') or (c = '#')) then
        exit(False);

    Result := True;
end;

function TAstBinder.ResolveSymbol(const Name: string; out Address: TResolvedAddress): Boolean;
var
    layout: IScopeLayout;
    depth: Integer;
    slot: Integer;
begin
    layout := FCurrentBuilder;
    depth := 0;

    while Assigned(layout) do
    begin
        slot := layout.FindSlot(Name);
        if slot >= 0 then
        begin
            Address := TResolvedAddress.Create(akLocalOrParent, depth, slot);
            Result := True;
            exit;
        end;
        layout := layout.Parent;
        Inc(depth);
    end;

    Result := False;
end;

function TAstBinder.CaptureUpvalue(const PhysicalAddress: TResolvedAddress): Integer;
var
    currentMap: TUpvalueMap;
begin
    currentMap := FUpvalueStack.Peek;
    if not currentMap.TryGetValue(PhysicalAddress, Result) then
    begin
        Result := currentMap.Count;
        currentMap.Add(PhysicalAddress, Result);
    end;
end;

function TAstBinder.VisitConstant(const Node: IConstantNode): IAstNode;
begin
    Result := Node;
end;

function TAstBinder.VisitKeyword(const Node: IKeywordNode): IAstNode;
begin
    Result := Node;
end;

function TAstBinder.VisitCreateSeries(const Node: ICreateSeriesNode): IAstNode;
begin
    Result := Node;
end;

function TAstBinder.VisitIdentifier(const Node: IIdentifierNode): IAstNode;
var
    physAddr: TResolvedAddress;
    upvalueIndex: Integer;
    identity: INamedIdentity;
begin
    identity := Node.Identity.AsNamed;

    if Node.Address.Kind = akUnresolved then
    begin
        if not ResolveSymbol(Node.Name, physAddr) then
        begin
            if Assigned(FLog) then
                FLog.AddError(Format('Undefined identifier: "%s"', [Node.Name]), Node);
            Result := Node;
            Exit;
        end;

        if physAddr.ScopeDepth > 0 then
        begin
            upvalueIndex := CaptureUpvalue(physAddr);
            Result := TAst.Identifier(identity, TResolvedAddress.Create(akUpvalue, 0, upvalueIndex), TTypes.Unknown);
        end
        else
            Result := TAst.Identifier(identity, physAddr, TTypes.Unknown);
    end
    else
        Result := Node;
end;

function TAstBinder.VisitVariableDeclaration(const Node: IVariableDeclarationNode): IAstNode;
var
    slot: Integer;
    addr: TResolvedAddress;
    newInit: IAstNode;
    newIdent: IIdentifierNode;
    isBoxed: Boolean;
    identifier: IIdentifierNode;
    identIdentity: INamedIdentity;
begin
    identifier := Node.Target.AsIdentifier;
    identIdentity := identifier.Identity.AsNamed;

    if not IsValidIdentifier(identifier.Name) then
    begin
        if Assigned(FLog) then
            FLog.AddError(Format('Invalid identifier name: "%s".', [identifier.Name]), Node);
    end;

    if FCurrentBuilder.FindSlot(identifier.Name) >= 0 then
    begin
        if Assigned(FLog) then
            FLog.AddError(Format('Variable "%s" is already defined in this scope.', [identifier.Name]), Node);

        if Assigned(Node.Initializer) then
            Accept(Node.Initializer);

        Result := Node;
        Exit;
    end;

    slot := FCurrentBuilder.Define(identifier.Name);
    addr := TResolvedAddress.Create(akLocalOrParent, 0, slot);

    if Assigned(Node.Initializer) then
        newInit := Accept(Node.Initializer)
    else
        newInit := nil;

    newIdent := TAst.Identifier(identIdentity, addr, TTypes.Unknown);
    isBoxed := (FBoxedDeclarations <> nil) and FBoxedDeclarations.Contains(Node);
    Result := TAst.VarDecl(Node.Identity, newIdent, newInit, TTypes.Unknown, isBoxed);

    if Assigned(FFunctionRegistry) and (newInit <> nil) and (newInit.Kind = akLambdaExpression) then
        FFunctionRegistry.Register(addr, newInit.AsLambdaExpression);
end;

function TAstBinder.VisitAssignment(const Node: IAssignmentNode): IAstNode;
var
    newIdent: IAstNode;
    newValue: IAstNode;
begin
    newIdent := Accept(Node.Target);
    newValue := Accept(Node.Value);

    Result := TAst.Assign(Node.Identity, newIdent, newValue, TTypes.Unknown);

    if Assigned(FFunctionRegistry) and (newValue <> nil) and (newValue.Kind = akLambdaExpression) then
    begin
        if newIdent.AsIdentifier.Address.Kind = akLocalOrParent then
            FFunctionRegistry.Register(newIdent.AsIdentifier.Address, newValue.AsLambdaExpression);
    end;
end;

function TAstBinder.VisitLambdaExpression(const Node: ILambdaExpressionNode): IAstNode;
var
    parentBuilder: IScopeBuilder;
    paramType: IStaticType;
    newParams: TArray<IIdentifierNode>;
    newBody: IAstNode;
    finalLayout: IScopeLayout;
    i, slot: Integer;
    addr: TResolvedAddress;
    capturedMap: TUpvalueMap;
    sortedPairs: TArray<TPair<TResolvedAddress, Integer>>;
    upvaluesList: TArray<TResolvedAddress>;
    startCount: Integer;
    hasNested: Boolean;
    paramIdentity: INamedIdentity;
    paramList: IParameterList;
begin
    startCount := FLambdaCounter;
    Inc(FLambdaCounter);

    parentBuilder := FCurrentBuilder;
    FCurrentBuilder := TScope.CreateBuilder(parentBuilder);

    capturedMap := TUpvalueMap.Create(TResolvedAddressComparer.Create);
    FUpvalueStack.Push(capturedMap);

    try
        FCurrentBuilder.Define('<self>');

        SetLength(newParams, Node.Parameters.Count);

        for i := 0 to Node.Parameters.Count - 1 do
        begin
            var paramNode := Node.Parameters[i];
            var paramName := paramNode.Name;
            paramIdentity := paramNode.Identity.AsNamed;

            if FCurrentBuilder.FindSlot(paramName) >= 0 then
            begin
                if Assigned(FLog) then
                    FLog.AddError(Format('Duplicate parameter name "%s".', [paramName]), Node);
            end
            else
                FCurrentBuilder.Define(paramName);

            slot := FCurrentBuilder.FindSlot(paramName);
            if slot < 0 then
                slot := 0;

            addr := TResolvedAddress.Create(akLocalOrParent, 0, slot);

            paramType := TTypes.Unknown;
            if (parentBuilder.Parent = nil) and (FArgTypes <> nil) and (i < Length(FArgTypes)) then
                paramType := FArgTypes[i];

            newParams[i] := TAst.Identifier(paramIdentity, addr, paramType);
        end;

        newBody := Accept(Node.Body);
        finalLayout := FCurrentBuilder.Build;

        sortedPairs := capturedMap.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(upvaluesList, Length(sortedPairs));
        for i := 0 to High(sortedPairs) do
        begin
            var rawAddr := sortedPairs[i].Key;
            if rawAddr.Kind = akLocalOrParent then
            begin
                Assert(rawAddr.ScopeDepth > 0, 'Logic Error: Trying to capture a local variable.');
                Dec(rawAddr.ScopeDepth);
            end;
            upvaluesList[i] := rawAddr;
        end;

    finally
        FCurrentBuilder := parentBuilder;
        FUpvalueStack.Pop;
    end;

    hasNested := FLambdaCounter > (startCount + 1);

    paramList := TParameterList.Create(newParams, Node.Parameters.Identity);

    Result := TAst.LambdaExpr(Node.Identity, paramList, newBody, finalLayout, nil, upvaluesList, hasNested, Node.IsPure);
end;

function TAstBinder.VisitFunctionCall(const Node: IFunctionCallNode): IAstNode;
begin
    if Node.Callee.Kind = akKeyword then
    begin
        if Node.Arguments.Count <> 1 then
        begin
            if Assigned(FLog) then
                FLog.AddError(Format('Keyword access :%s requires exactly one argument.', [Node.Callee.AsKeyword.Value.Name]), Node);
        end
        else
        begin
            var memberAccess := TAst.MemberAccess(Node.Identity, Accept(Node.Arguments[0]), Node.Callee.AsKeyword);
            Result := memberAccess;
            exit;
        end;
    end;
    Result := inherited VisitFunctionCall(Node);
end;

end.