Michael Schimmel
771 lines
26 KiB
ObjectPascal
771 lines
26 KiB
ObjectPascal
unit Myc.Ast.Scope;
|
|
|
|
interface
|
|
|
|
uses
|
|
System.SysUtils,
|
|
System.Generics.Collections,
|
|
System.Generics.Defaults,
|
|
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;
|
|
|
|
TResolvedAddressComparer = class(TEqualityComparer<TResolvedAddress>)
|
|
public
|
|
function Equals(const Left, Right: TResolvedAddress): Boolean; override;
|
|
function GetHashCode(const Value: TResolvedAddress): Integer; override;
|
|
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; const AStaticType: IStaticType = nil): 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.Hash,
|
|
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; // (* Will store static types *)
|
|
FValues: TArray<TScopeItem>; // (* Runtime values *)
|
|
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; const AStaticType: IStaticType = nil): 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>;
|
|
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);
|
|
function FindSymbol(const Name: string): TResolvedSymbol;
|
|
function CreateScope(const Parent: IExecutionScope): IExecutionScope;
|
|
procedure PopulateFromScope(Scope: TExecutionScope);
|
|
property Symbols: TDictionary<string, Integer> read FSymbols;
|
|
end;
|
|
|
|
{ TResolvedAddressComparer }
|
|
|
|
function TResolvedAddressComparer.Equals(const Left, Right: TResolvedAddress): Boolean;
|
|
begin
|
|
Result := (Left = Right); // Use the record's operator
|
|
end;
|
|
|
|
function TResolvedAddressComparer.GetHashCode(const Value: TResolvedAddress): Integer;
|
|
var
|
|
adr: TResolvedAddress;
|
|
begin
|
|
adr := Value;
|
|
// Use THashBobJenkins as requested
|
|
Result := THashBobJenkins.GetHashValue(adr.Kind, SizeOf(TAddressKind), 0);
|
|
Result := THashBobJenkins.GetHashValue(adr.ScopeDepth, SizeOf(Integer), Result);
|
|
Result := THashBobJenkins.GetHashValue(adr.SlotIndex, SizeOf(Integer), Result);
|
|
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;
|
|
|
|
// Ensure FDescriptor is always assigned
|
|
if Assigned(ADescriptor) then
|
|
FDescriptor := ADescriptor
|
|
else if Assigned(AParent) then
|
|
FDescriptor := AParent.CreateDescriptor // Inherit descriptor if nil
|
|
else
|
|
FDescriptor := TScope.CreateDescriptor(nil); // Create new root descriptor
|
|
|
|
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;
|
|
|
|
// Pre-allocate the runtime value array based on the compile-time descriptor's size.
|
|
if Assigned(ADescriptor) 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
|
|
// We create a *copy* to prevent modification of the live descriptor
|
|
// TScopeDescriptor.CreateDescriptor(Self) will do this.
|
|
Result := TScopeDescriptor.CreateDescriptor(Self);
|
|
end;
|
|
|
|
// (* MODIFIED: Signature changed, logic added *)
|
|
function TExecutionScope.Define(const Name: string; const Value: TDataValue; const AStaticType: IStaticType = nil): TResolvedAddress;
|
|
var
|
|
id: Integer;
|
|
index: Integer;
|
|
staticType: IStaticType;
|
|
begin
|
|
NeedNameToIndex;
|
|
id := GetNameID(Name);
|
|
if FNameToIndex.ContainsKey(id) then
|
|
raise Exception.CreateFmt('Variable "%s" is already defined in this scope.', [Name]);
|
|
|
|
// 1. Determine the static type
|
|
if Assigned(AStaticType) then
|
|
staticType := AStaticType
|
|
else
|
|
staticType := TTypes.Unknown; // Default if not provided
|
|
|
|
// 2. Define in the runtime storage (FValues)
|
|
index := Length(FValues);
|
|
SetLength(FValues, index + 1);
|
|
FValues[index].Value := Value;
|
|
FValues[index].IsBoxed := False;
|
|
FNameToIndex.Add(id, index);
|
|
|
|
// 3. Define in the compile-time descriptor (FDescriptor)
|
|
// This stores the static type information for the Binder/TypeChecker.
|
|
// Note: This relies on FDescriptor being non-nil (ensured in constructor)
|
|
var descSlot := FDescriptor.Define(Name, staticType);
|
|
|
|
// 4. Ensure runtime slot matches descriptor slot
|
|
// This is critical for root scope initialization.
|
|
Assert(descSlot = index, 'Scope descriptor slot mismatch during Define');
|
|
|
|
// 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;
|
|
FSlotTypes := [];
|
|
end;
|
|
|
|
destructor TScopeDescriptor.Destroy;
|
|
begin
|
|
FSlotTypes := nil;
|
|
FSymbols.Free;
|
|
inherited;
|
|
end;
|
|
|
|
class function TScopeDescriptor.CreateDescriptor(const Scope: IExecutionScope): IScopeDescriptor;
|
|
begin
|
|
// Create a *copy* of the descriptor chain
|
|
if (Scope is TExecutionScope) and (Assigned(Scope.Parent)) then
|
|
begin
|
|
// Recursively create parent descriptors
|
|
var res := TScopeDescriptor.Create(CreateDescriptor(Scope.Parent));
|
|
// Populate this descriptor level
|
|
res.PopulateFromScope(Scope as TExecutionScope);
|
|
Result := res;
|
|
end
|
|
else if (Scope is TExecutionScope) then
|
|
begin
|
|
// This is the root scope
|
|
var res := TScopeDescriptor.Create(nil);
|
|
res.PopulateFromScope(Scope as TExecutionScope);
|
|
Result := res;
|
|
end
|
|
else
|
|
Result := TScopeDescriptor.Create(nil); // Default empty descriptor
|
|
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
|
|
// (* MODIFIED: Initialize StaticType *)
|
|
Result.StaticType := TTypes.Unknown;
|
|
Result.Address.Kind := akUnresolved;
|
|
Result.Address.ScopeDepth := 0;
|
|
|
|
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); // (* Read type *)
|
|
exit;
|
|
end;
|
|
inc(Result.Address.ScopeDepth);
|
|
currentDescriptor := currentDescriptor.Parent;
|
|
end;
|
|
// (* If not found, Result.StaticType remains TTypes.Unknown *)
|
|
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
|
|
// (* MODIFIED: We are populating 'Self' from 'Scope's *internal* descriptor *)
|
|
// We must cast to access the descriptor implementation
|
|
if not (Scope.FDescriptor is TScopeDescriptor) then
|
|
exit; // Cannot populate from an unknown descriptor type
|
|
|
|
var scopeDesc := (Scope.FDescriptor as TScopeDescriptor);
|
|
|
|
// Recreate descriptor by copying all defined symbols and types.
|
|
SetLength(Self.FSlotTypes, Length(scopeDesc.FSlotTypes));
|
|
for i := 0 to High(Self.FSlotTypes) do
|
|
Self.FSlotTypes[i] := scopeDesc.FSlotTypes[i]; // Copy static type
|
|
|
|
for var pair in scopeDesc.FSymbols do
|
|
begin
|
|
// Add to variable symbol table.
|
|
if not Self.FSymbols.ContainsKey(pair.Key) then
|
|
Self.FSymbols.Add(pair.Key, pair.Value);
|
|
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.
|