MycLib/Src/AST/Myc.Ast.Scope.pas

unit Myc.Ast.Scope;

interface

uses
    System.SysUtils,
    System.Generics.Collections,
    System.Classes,
    Myc.Data.Value,
    Myc.Ast.Types;

type
    IExecutionScope = interface;
    IScopeDescriptor = interface;

    // Defines how an identifier's address was resolved.
    TAddressKind = (akUnresolved, akLocalOrParent, akUpvalue);

    TResolvedAddress = record
        Kind: TAddressKind;
        ScopeDepth: Integer;
        SlotIndex: Integer;
        constructor Create(AKind: TAddressKind; AScopeDepth, ASlotIndex: Integer);
        class operator Initialize(out Dest: TResolvedAddress);
    public
        class operator Equal(const A: TResolvedAddress; B: TResolvedAddress): Boolean;
    end;

    // A resolved symbol, containing its runtime address and static type.
    TResolvedSymbol = record
        Address: TResolvedAddress;
        StaticType: IStaticType;
        constructor Create(const AAddress: TResolvedAddress; const AStaticType: IStaticType);
        class operator Initialize(out Dest: TResolvedSymbol);
    end;

    IValueCell = interface
        {$region 'private'}
        function GetValue: TDataValue;
        procedure SetValue(const AValue: TDataValue);
        {$endregion}
        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}

        // Defines a symbol and returns its runtime address
        function Define(const Name: string; const Value: TDataValue): TResolvedAddress;

        // Defines a variable at a given address and stores it directly in a shared cell (boxing).
        procedure DefineBoxed(SlotIndex: Integer; const Value: TDataValue);

        function Dump: string;
        procedure Clear;
        function Capture(const Address: TResolvedAddress): IValueCell;

        function GetNameID(const Name: String): Integer;
        // Resolves a name to an address by searching the runtime scope chain.
        function Resolve(const Name: string): TResolvedAddress;

        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, their slot indices and macros.
    // 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>;
        function GetType(SlotIndex: Integer): IStaticType;
        {$endregion}
        function CreateScope(const AParent: IExecutionScope): IExecutionScope;
        // Defines a symbol, returns its slot index.
        function Define(const Name: string; const AType: IStaticType = nil): Integer;
        // Updates the type of an already defined symbol (e.g., for lambda self-reference).
        procedure UpdateType(SlotIndex: Integer; const AType: IStaticType);

        // Finds a symbol, returns its address and type.
        function FindSymbol(const Name: string): TResolvedSymbol;

        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,
    System.SyncObjs;

type
    TExecutionScope = class(TInterfacedObject, IExecutionScope)
    private
        type
            TValueCell = class(TInterfacedObject, IValueCell)
            private
                FValue: TDataValue;
                function GetValue: TDataValue;
                procedure SetValue(const AValue: TDataValue);
            public
                constructor Create(const AValue: TDataValue);
            end;

            TScopeItem = record
                Value: TDataValue;
                IsBoxed: Boolean;
                function GetContent: TDataValue; inline;
            end;

    private
        FParent: IExecutionScope;
        FDescriptor: IScopeDescriptor;
        FValues: TArray<TScopeItem>;
        FCapturedUpvalues: TArray<IValueCell>;
        FNames: TDictionary<string, Integer>;
        FNameStrings: TList<string>;
        FNameToIndex: TDictionary<Integer, Integer>;

        procedure DumpScope(const ABuilder: TStringBuilder; AIndent: Integer);
        procedure NeedNameToIndex;
        function GetParent: IExecutionScope;
        function GetNameToIndex: TDictionary<Integer, Integer>;
        function GetValues(const Address: TResolvedAddress): TDataValue;
        procedure SetValues(const Address: TResolvedAddress; const Value: TDataValue);
    public
        constructor Create(AParent: IExecutionScope; const ADescriptor: IScopeDescriptor; const ACapturedUpvalues: TArray<IValueCell>);
        destructor Destroy; override;
        procedure Clear;
        function GetNameID(const Name: String): Integer;
        function Resolve(const Name: string): TResolvedAddress;
        function Dump: string;
        function Define(const Name: string; const Value: TDataValue): TResolvedAddress;
        procedure DefineBoxed(SlotIndex: Integer; 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;
        property ValuesArray: TArray<TScopeItem> read FValues; // Expose FValues for PopulateFromScope
    end;

    TScopeDescriptor = class(TInterfacedObject, IScopeDescriptor)
    private
        FParent: IScopeDescriptor;
        FSymbols: TDictionary<string, Integer>;
        // FMacros: TDictionary<string, IMacroDefinitionNode>; // Entfernt
        FSlotTypes: TArray<IStaticType>; // Stores types by SlotIndex
        function GetParent: IScopeDescriptor;
        function GetSlotCount: Integer;
        function GetSymbols: TDictionary<string, Integer>;
        function GetType(SlotIndex: Integer): IStaticType;
    public
        constructor Create(const AParent: IScopeDescriptor);
        destructor Destroy; override;
        class function CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor; static;
        function Define(const Name: string; const AType: IStaticType): Integer;
        procedure UpdateType(SlotIndex: Integer; const AType: IStaticType = nil);
        // procedure DefineMacro(const Name: string; const Node: IMacroDefinitionNode); // Entfernt
        function FindSymbol(const Name: string): TResolvedSymbol;
        // function FindMacro(const Name: string): IMacroDefinitionNode; // Entfernt
        function CreateScope(const Parent: IExecutionScope): IExecutionScope;
        procedure PopulateFromScope(Scope: TExecutionScope);
        property Symbols: TDictionary<string, Integer> read FSymbols;
    end;

{ TResolvedAddress }

constructor TResolvedAddress.Create(AKind: TAddressKind; AScopeDepth, ASlotIndex: Integer);
begin
    Kind := AKind;
    ScopeDepth := AScopeDepth;
    SlotIndex := ASlotIndex;
end;

class operator TResolvedAddress.Equal(const A: TResolvedAddress; B: TResolvedAddress): Boolean;
begin
    Result := (A.Kind = B.Kind) and (A.ScopeDepth = B.ScopeDepth) and (A.SlotIndex = B.SlotIndex);
end;

class operator TResolvedAddress.Initialize(out Dest: TResolvedAddress);
begin
    Dest.Kind := akUnresolved;
    Dest.ScopeDepth := -1;
    Dest.SlotIndex := -1;
end;

{ TResolvedSymbol }

constructor TResolvedSymbol.Create(const AAddress: TResolvedAddress; const AStaticType: IStaticType);
begin
    Address := AAddress;
    StaticType := AStaticType;
end;

class operator TResolvedSymbol.Initialize(out Dest: TResolvedSymbol);
begin
    // TResolvedAddress has its own Initialize operator
    Dest.StaticType := TTypes.Unknown;
end;

{ TExecutionScope.TValueCell }

constructor TExecutionScope.TValueCell.Create(const AValue: TDataValue);
begin
    inherited Create;
    FValue := AValue;
end;

function TExecutionScope.TValueCell.GetValue: TDataValue;
begin
    Result := FValue;
end;

procedure TExecutionScope.TValueCell.SetValue(const AValue: TDataValue);
begin
    FValue := AValue;
end;

{ TExecutionScope }

constructor TExecutionScope.Create(
    AParent: IExecutionScope;
    const ADescriptor: IScopeDescriptor;
    const ACapturedUpvalues: TArray<IValueCell>
);
begin
    inherited Create;
    FParent := AParent;
    FDescriptor := ADescriptor;

    FValues := [];
    FCapturedUpvalues := ACapturedUpvalues;

    if FParent is TExecutionScope then
    begin
        FNames := (FParent as TExecutionScope).FNames;
        FNameStrings := (FParent as TExecutionScope).FNameStrings;
    end
    else
    begin
        FNames := TDictionary<string, Integer>.Create;
        FNameStrings := TList<string>.Create;
    end;

    if ADescriptor <> nil then
        SetLength(FValues, ADescriptor.SlotCount);
end;

destructor TExecutionScope.Destroy;
begin
    Clear;
    if not (FParent is TExecutionScope) then
    begin
        FNameStrings.Free;
        FNames.Free;
    end;
    inherited Destroy;
end;

function TExecutionScope.GetParent: IExecutionScope;
begin
    Result := FParent;
end;

procedure TExecutionScope.Clear;
begin
    FValues := [];
    FreeAndNil(FNameToIndex);
end;

function TExecutionScope.Capture(const Address: TResolvedAddress): IValueCell;
var
    targetScope: TExecutionScope;
    i: Integer;
begin
    case Address.Kind of
        akUpvalue:
        begin
            Assert(Assigned(FCapturedUpvalues), 'Attempt to access an upvalue in a scope with no closure context.');
            Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(FCapturedUpvalues)), 'Invalid upvalue index.');
            Result := FCapturedUpvalues[Address.SlotIndex];
        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 capture.');
            end;
            Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(targetScope.FValues)), 'Invalid slot index during capture.');

            // The check-and-update for JIT-boxing must be atomic.
            TMonitor.Enter(targetScope);
            try
                var item := targetScope.FValues[Address.SlotIndex];
                if item.IsBoxed then
                begin
                    // The variable is already boxed, so just return its cell.
                    Result := item.Value.AsIntf<IValueCell>;
                end
                else
                begin
                    // This is an unboxed variable. Box it "just-in-time" and update the scope.
                    Result := TValueCell.Create(item.Value);
                    targetScope.FValues[Address.SlotIndex].Value := TDataValue.FromIntf<IValueCell>(Result);
                    targetScope.FValues[Address.SlotIndex].IsBoxed := True;
                end;
            finally
                TMonitor.Exit(targetScope);
            end;
        end;
    else
        raise EInvalidOpException.Create('Cannot capture an unresolved address.');
    end;
end;

function TExecutionScope.CreateDescriptor: IScopeDescriptor;
begin
    Result := TScopeDescriptor.CreateDescriptor(Self);
end;

function TExecutionScope.Define(const Name: string; const Value: TDataValue): TResolvedAddress;
var
    id: Integer;
    index: Integer;
begin
    NeedNameToIndex;
    id := GetNameID(Name);
    if FNameToIndex.ContainsKey(id) then
        raise Exception.CreateFmt('Variable "%s" is already defined in this scope.', [Name]);

    index := Length(FValues);
    SetLength(FValues, index + 1);
    FValues[index].Value := Value;
    FValues[index].IsBoxed := False;
    FNameToIndex.Add(id, index);

    // Return the address
    Result.Kind := akLocalOrParent;
    Result.ScopeDepth := 0;
    Result.SlotIndex := index;
end;

procedure TExecutionScope.DefineBoxed(SlotIndex: Integer; const Value: TDataValue);
begin
    Assert((SlotIndex >= 0) and (SlotIndex < Length(FValues)), 'Invalid slot index during DefineBoxed.');

    FValues[SlotIndex].Value := TDataValue.FromIntf<IValueCell>(TValueCell.Create(Value));
    FValues[SlotIndex].IsBoxed := True;
end;

procedure TExecutionScope.DumpScope(const ABuilder: TStringBuilder; AIndent: Integer);
var
    pair: TPair<Integer, Integer>;
    indentStr, boxedStr: string;
    sortedPairs: TArray<TPair<Integer, Integer>>;
    item: TScopeItem;
    val: TDataValue;
begin
    NeedNameToIndex;
    indentStr := ''.PadLeft(AIndent);
    if FNameToIndex.Count > 0 then
    begin
        sortedPairs := FNameToIndex.ToArray;
        TArray.Sort<TPair<Integer, Integer>>(
            sortedPairs,
            TComparer<TPair<Integer, Integer>>
                .Construct(function(const Left, Right: TPair<Integer, Integer>): Integer begin Result := Left.Value - Right.Value; end)
        );

        for pair in sortedPairs do
        begin
            item := FValues[pair.Value];
            if item.IsBoxed then
            begin
                boxedStr := ' (Boxed)';
                val := (item.Value.AsIntf<IValueCell>).Value;
            end
            else
            begin
                boxedStr := '';
                val := item.Value;
            end;
            ABuilder.AppendLine(indentStr + Format('  [%d] %s: %s%s', [pair.Value, FNameStrings[pair.Key], val.ToString, boxedStr]));
        end;
    end
    else
        ABuilder.AppendLine(indentStr + '  (empty)');

    if Assigned(FParent) then
    begin
        ABuilder.AppendLine(indentStr + '[Parent Scope]');
        (FParent as TExecutionScope).DumpScope(ABuilder, AIndent + 2);
    end;
end;

function TExecutionScope.Dump: string;
var
    builder: TStringBuilder;
begin
    builder := TStringBuilder.Create;
    try
        builder.AppendLine('[Current Scope]');
        DumpScope(builder, 0);
        Result := builder.ToString.TrimRight;
    finally
        builder.Free;
    end;
end;

function TExecutionScope.GetNameToIndex: TDictionary<Integer, Integer>;
begin
    NeedNameToIndex;
    Result := FNameToIndex;
end;

function TExecutionScope.GetValues(const Address: TResolvedAddress): TDataValue;
var
    item: TScopeItem;
begin
    case Address.Kind of
        akUpvalue:
        begin
            Assert(Assigned(FCapturedUpvalues), 'Attempt to access an upvalue in a scope with no closure context.');
            Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(FCapturedUpvalues)), 'Invalid upvalue index.');
            Result := FCapturedUpvalues[Address.SlotIndex].Value;
        end;
        akLocalOrParent:
        begin
            var targetScope := Self;
            for var i := 1 to Address.ScopeDepth do
            begin
                targetScope := targetScope.Parent as TExecutionScope;
                Assert(Assigned(targetScope), 'Invalid scope depth for GetValues.');
            end;
            Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(targetScope.FValues)), 'Invalid slot index for GetValues.');

            item := targetScope.FValues[Address.SlotIndex];
            if item.IsBoxed then
                Result := (item.Value.AsIntf<IValueCell>).Value
            else
                Result := item.Value;
        end;
    else
        raise EInvalidOpException.Create('Cannot get value for an unresolved address.');
    end;
end;

function TExecutionScope.GetNameID(const Name: String): Integer;
begin
    if not FNames.TryGetValue(Name, Result) then
    begin
        Result := FNameStrings.Add(Name);
        FNames.Add(Name, Result);
    end;
end;

procedure TExecutionScope.NeedNameToIndex;
begin
    if FNameToIndex = nil then
    begin
        FNameToIndex := TDictionary<Integer, Integer>.Create;
        if FDescriptor <> nil then
        begin
            for var item in FDescriptor.Symbols do
                FNameToIndex.AddOrSetValue(GetNameId(item.Key), item.Value);
        end;
    end;
end;

function TExecutionScope.Resolve(const Name: string): TResolvedAddress;
var
    nameID: Integer;
    slotIndex: Integer;
    currentScope: IExecutionScope;
    depth: Integer;
begin
    currentScope := Self;
    depth := 0;
    // GetNameID is shared (or recreated) across the scope chain
    nameID := GetNameID(Name);

    while Assigned(currentScope) do
    begin
        // We must cast to the implementation class to access 'NameToIndex'
        var execScopeImpl := (currentScope as TExecutionScope);

        // Accessing .NameToIndex property ensures NeedNameToIndex is called
        if execScopeImpl.NameToIndex.TryGetValue(nameID, slotIndex) then
        begin
            // Found in this scope
            Result.Kind := akLocalOrParent;
            Result.ScopeDepth := depth;
            Result.SlotIndex := slotIndex;
            exit;
        end;

        // Not found, go to parent
        inc(depth);
        currentScope := currentScope.Parent;
    end;

    // Not found in the entire chain
    Result := Default(TResolvedAddress); // Kind = akUnresolved
end;

procedure TExecutionScope.SetValues(const Address: TResolvedAddress; const Value: TDataValue);
var
    targetScope: TExecutionScope;
    i: Integer;
begin
    case Address.Kind of
        akUpvalue:
        begin
            Assert(Assigned(FCapturedUpvalues), 'Attempt to access an upvalue in a scope with no closure context.');
            Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(FCapturedUpvalues)), 'Invalid upvalue index.');
            FCapturedUpvalues[Address.SlotIndex].Value := 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 for SetValues.');
            end;
            Assert((Address.SlotIndex >= 0) and (Address.SlotIndex < Length(targetScope.FValues)), 'Invalid slot index for SetValues.');

            // Use a reference/pointer to modify the array element in place
            var pItem: ^TScopeItem := @targetScope.FValues[Address.SlotIndex];
            if pItem.IsBoxed then
                (pItem.Value.AsIntf<IValueCell>).Value := Value
            else
                pItem.Value := Value;
        end;
    else
        raise EInvalidOpException.Create('Cannot set value for an unresolved address.');
    end;
end;

function TExecutionScope.TScopeItem.GetContent: TDataValue;
begin
    Result := Value;
    if IsBoxed then
        Result := Result.AsIntf<IValueCell>.Value;
end;

{ TScopeDescriptor }

constructor TScopeDescriptor.Create(const AParent: IScopeDescriptor);
begin
    inherited Create;
    FParent := AParent;
    FSymbols := TDictionary<string, Integer>.Create;
    // FMacros := TDictionary<string, IMacroDefinitionNode>.Create; // Entfernt
    FSlotTypes := [];
end;

destructor TScopeDescriptor.Destroy;
begin
    FSlotTypes := nil;
    // FMacros.Free; // Entfernt
    FSymbols.Free;
    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
    Result := TExecutionScope.Create(Parent, Self, nil);
end;

function TScopeDescriptor.Define(const Name: string; const AType: IStaticType): Integer;
begin
    Result := FSymbols.Count;
    FSymbols.Add(Name, Result);
    SetLength(FSlotTypes, Result + 1);
    FSlotTypes[Result] :=
        if AType <> nil then AType
        else TTypes.Unknown;
end;

procedure TScopeDescriptor.UpdateType(SlotIndex: Integer; const AType: IStaticType = nil);
begin
    if (SlotIndex < 0) or (SlotIndex >= Length(FSlotTypes)) then
        raise EArgumentOutOfRangeException.Create('Invalid SlotIndex in UpdateType.');
    FSlotTypes[SlotIndex] :=
        If AType <> nil then AType
        else TTypes.Unknown;
end;

function TScopeDescriptor.FindSymbol(const Name: string): TResolvedSymbol;
var
    currentDescriptor: IScopeDescriptor;
    slotIndex: Integer;
begin
    Result.Address.Kind := akUnresolved;
    Result.Address.ScopeDepth := 0;
    Result.StaticType := TTypes.Unknown;
    currentDescriptor := Self;
    while Assigned(currentDescriptor) do
    begin
        if currentDescriptor.Symbols.TryGetValue(Name, slotIndex) then
        begin
            Result.Address.Kind := akLocalOrParent;
            Result.Address.SlotIndex := slotIndex;
            Result.StaticType := currentDescriptor.GetType(slotIndex);
            exit;
        end;
        inc(Result.Address.ScopeDepth);
        currentDescriptor := currentDescriptor.Parent;
    end;
end;

function TScopeDescriptor.GetParent: IScopeDescriptor;
begin
    Result := FParent;
end;

function TScopeDescriptor.GetSlotCount: Integer;
begin
    Result := FSymbols.Count;
end;

function TScopeDescriptor.GetSymbols: TDictionary<string, Integer>;
begin
    Result := FSymbols;
end;

function TScopeDescriptor.GetType(SlotIndex: Integer): IStaticType;
begin
    if (SlotIndex < 0) or (SlotIndex >= Length(FSlotTypes)) then
        raise EArgumentOutOfRangeException.Create('Invalid SlotIndex in GetType.');
    Result := FSlotTypes[SlotIndex];
end;

procedure TScopeDescriptor.PopulateFromScope(Scope: TExecutionScope);
var
    i: Integer;
begin
    // Recreate descriptor by iterating all defined symbols in the runtime scope.
    SetLength(FSlotTypes, Length(Scope.ValuesArray)); // Size the array
    for i := 0 to High(FSlotTypes) do
        FSlotTypes[i] := TTypes.Unknown; // Fill with Unknown

    for var pair in Scope.NameToIndex do
    begin
        var name := Scope.NameStrings[pair.Key];
        var slotIndex := pair.Value;

        // Add to variable symbol table.
        if not FSymbols.ContainsKey(name) then
            FSymbols.Add(name, slotIndex);

        // We cannot recover the static type from the runtime scope.
        // FSlotTypes[slotIndex] remains TTypes.Unknown.

        // Makro-Logik hier entfernt
    end;
end;

{ TScope }

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.