5894411a35
Adopts the Swift/LLVM model: Apache License 2.0 with the Runtime Library Exception text used verbatim by the Swift project. SPDX identifier: Apache-2.0 WITH Swift-exception. Apache 2.0 brings an explicit patent grant and patent-retaliation clause that BSD-3 lacks. The Runtime Library Exception ensures binaries produced by the Blaise compiler do not inherit attribution obligations from the linked-in RTL. * LICENSE — full Apache 2.0 + RLE text (replaces the deleted LICENCE). * NOTICE — project header plus QBE attribution (MIT, vendored). * docs/language-rationale.adoc — new Project Governance section capturing the decision, alternatives considered, and rationale. * SPDX headers updated across all .pas, .pp, .inc, .c source files, build scripts, PasBuild plugins, and the Makefile. * project.xml license field updated. * tools/migrate_full.py HEADER template updated so generated self-hosting source carries the new licence.
1085 lines
36 KiB
ObjectPascal
1085 lines
36 KiB
ObjectPascal
{
|
||
Blaise - An Object Pascal Compiler
|
||
Copyright (c) 2026 Graeme Geldenhuys
|
||
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
|
||
Licensed under the Apache License v2.0 with Runtime Library Exception.
|
||
See LICENSE file in the project root for full license terms.
|
||
}
|
||
|
||
unit uSymbolTable;
|
||
|
||
{$mode objfpc}{$H+}
|
||
|
||
interface
|
||
|
||
uses
|
||
Classes, SysUtils, contnrs;
|
||
|
||
type
|
||
{ ------------------------------------------------------------------ }
|
||
{ Type descriptors }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
TTypeKind = (
|
||
tyInteger, { Int32 — QBE 'w' }
|
||
tyInt64, { Int64 — QBE 'l' }
|
||
tyUInt32, { UInt32 — QBE 'w' unsigned }
|
||
tyByte, { Byte — QBE 'b' }
|
||
tyBoolean, { Boolean — stored as byte, 0/1 only }
|
||
tyString, { ARC-managed UTF-8 string }
|
||
tyRecord, { Stack-allocated aggregate (Phase 2) }
|
||
tyClass, { Heap-allocated, single-inheritance (Phase 2) }
|
||
tyInterface, { Zero-GUID interface reference (Phase 3) }
|
||
tyVoid, { No value — used as procedure return type }
|
||
tyNil, { Pseudo-type for the nil literal; compatible with tyClass }
|
||
tyPointer, { Typed or untyped pointer — QBE 'l'; see TPointerTypeDesc }
|
||
tyEnum, { Enumeration type — stored as QBE 'w' (Integer); see TEnumTypeDesc }
|
||
tyOpenArray, { Open-array parameter — two-register ABI: data ptr + high index }
|
||
tyStaticArray, { Fixed-size array: stack-allocated, compile-time bounds }
|
||
tyPChar, { Opaque C pointer for interop: PChar(str) / string(pchar) }
|
||
tySet { Bit-set over an enum base type — QBE 'w' (≤32 members) or 'l' (≤64) }
|
||
);
|
||
|
||
TTypeDesc = class
|
||
public
|
||
Kind: TTypeKind;
|
||
Name: string;
|
||
function IsNumeric: Boolean;
|
||
function IsString: Boolean;
|
||
function IsOrdinal: Boolean;
|
||
function IsRecord: Boolean;
|
||
{ Size in bytes for QBE allocation. }
|
||
function ByteSize: Integer;
|
||
{ QBE alloc alignment: 4 for integer-only records, 8 for pointer/string. }
|
||
function AllocAlign: Integer;
|
||
{ True storage footprint for a single value: 1 for Byte/Boolean, 4 for Integer,
|
||
8 for pointer/string/Int64. Use for array element sizing; ByteSize pads
|
||
small scalars to 4 for standalone-variable alignment. }
|
||
function RawSize: Integer;
|
||
end;
|
||
|
||
{ Typed or untyped pointer descriptor.
|
||
BaseType = nil means untyped 'Pointer'; non-nil means '^BaseType'. }
|
||
TPointerTypeDesc = class(TTypeDesc)
|
||
public
|
||
BaseType: TTypeDesc; { not owned; nil = untyped Pointer }
|
||
end;
|
||
|
||
{ Open-array parameter descriptor.
|
||
Carries the element type; the two-register ABI (data ptr + high index)
|
||
is handled entirely in the parser, semantic pass, and codegen. }
|
||
TOpenArrayTypeDesc = class(TTypeDesc)
|
||
public
|
||
ElementType: TTypeDesc; { not owned }
|
||
end;
|
||
|
||
{ Static array descriptor: fixed-size, stack-allocated, compile-time bounds.
|
||
Element access: base_ptr + (I − LowBound) × ElementType.ByteSize. }
|
||
TStaticArrayTypeDesc = class(TTypeDesc)
|
||
public
|
||
ElementType: TTypeDesc; { not owned }
|
||
LowBound: Integer;
|
||
HighBound: Integer;
|
||
end;
|
||
|
||
{ Enum type descriptor. Members are ordered; ordinal values are 0..N-1.
|
||
Stored as QBE 'w' (same as Integer). Each member is also registered in
|
||
the symbol table as a skConstant with this type descriptor. }
|
||
TEnumTypeDesc = class(TTypeDesc)
|
||
public
|
||
Members: TStringList; { owned — ordered member names }
|
||
constructor Create(const AName: string);
|
||
destructor Destroy; override;
|
||
function OrdinalOf(const AMember: string): Integer;
|
||
end;
|
||
|
||
{ Set type descriptor. BaseType is the element enum; BitCount is the number
|
||
of bits required (= BaseType.Members.Count). Stored as QBE 'w' for ≤32
|
||
members, 'l' for 33–64. Each member ordinal N maps to bit (1 shl N). }
|
||
TSetTypeDesc = class(TTypeDesc)
|
||
public
|
||
BaseType: TEnumTypeDesc; { not owned }
|
||
BitCount: Integer; { = BaseType.Members.Count }
|
||
end;
|
||
|
||
{ Field entry inside a record type descriptor. }
|
||
TFieldInfo = class
|
||
public
|
||
Name: string;
|
||
TypeDesc: TTypeDesc; { not owned }
|
||
Offset: Integer; { byte offset from record base }
|
||
IsWeak: Boolean; { set when the class field was declared [Weak];
|
||
field cleanup emits _WeakClear for weak fields
|
||
and field assignment bypasses addref/release. }
|
||
end;
|
||
|
||
{ One entry in a class vtable — tracks slot index and implementing method. }
|
||
TVTableEntry = class
|
||
public
|
||
Slot: Integer; { index in vtable }
|
||
MethName: string; { unqualified method name }
|
||
ImplName: string; { fully-qualified QBE label, e.g. $TDog_Speak }
|
||
end;
|
||
|
||
{ Property descriptor — one per declared property on a class. }
|
||
TPropertyInfo = class
|
||
public
|
||
Name: string;
|
||
TypeDesc: TTypeDesc; { not owned — resolved by semantic analysis }
|
||
ReadField: string; { '' if method-backed read }
|
||
ReadMethod: string; { '' if field-backed read }
|
||
WriteField: string; { '' if method-backed write or read-only }
|
||
WriteMethod: string; { '' if field-backed write or read-only }
|
||
IndexParamName: string; { '' = non-indexed property }
|
||
IndexTypeDesc: TTypeDesc; { not owned; non-nil when IndexParamName <> '' }
|
||
end;
|
||
|
||
{ Type descriptor for zero-GUID interface types (Phase 3). }
|
||
TInterfaceTypeDesc = class(TTypeDesc)
|
||
private
|
||
FMethods: TStringList; { method names, case-insensitive }
|
||
FReturnTypes: TStringList; { parallel: return type name, '' = procedure }
|
||
FParent: TInterfaceTypeDesc; { not owned; nil if no parent }
|
||
public
|
||
constructor Create(const AName: string);
|
||
destructor Destroy; override;
|
||
procedure AddMethod(const AName: string; const AReturnTypeName: string);
|
||
function HasMethod(const AName: string): Boolean;
|
||
function MethodCount: Integer;
|
||
function MethodName(AIndex: Integer): string;
|
||
function MethodReturnTypeName(AIndex: Integer): string;
|
||
function MethodIndex(const AName: string): Integer;
|
||
property Parent: TInterfaceTypeDesc read FParent write FParent;
|
||
end;
|
||
|
||
{ Extended type descriptor for record types. }
|
||
TRecordTypeDesc = class(TTypeDesc)
|
||
private
|
||
FFields: TObjectList; { owned TFieldInfo }
|
||
FKeys: TStringList; { sorted, case-insensitive; Objects[] = TFieldInfo (not owned) }
|
||
FParent: TRecordTypeDesc; { not owned; nil for root classes }
|
||
FVTable: TObjectList; { owned TVTableEntry; nil if no virtual methods }
|
||
FImplements: TObjectList; { not owned — TInterfaceTypeDesc references }
|
||
FProperties: TObjectList; { owned TPropertyInfo }
|
||
FHasDestroyMethod: Boolean; { True when the class declares a 'Destroy' method }
|
||
public
|
||
constructor Create(const AName: string; AKind: TTypeKind);
|
||
destructor Destroy; override;
|
||
procedure AddField(const AName: string; AType: TTypeDesc);
|
||
function FindField(const AName: string): TFieldInfo;
|
||
function TotalSize: Integer;
|
||
function MaxAlign: Integer;
|
||
|
||
{ Vtable management }
|
||
function HasVTable: Boolean;
|
||
function VTableCount: Integer;
|
||
function VTableEntryAt(ASlot: Integer): TVTableEntry;
|
||
function FindVTableSlot(const AMethodName: string): Integer;
|
||
function AddVTableSlot(const AMethodName, AImplName: string): Integer;
|
||
procedure OverrideVTableSlot(ASlot: Integer; const AImplName: string);
|
||
procedure CopyVTableFrom(AParent: TRecordTypeDesc);
|
||
|
||
{ Interface implements tracking }
|
||
procedure AddImplements(AIntf: TInterfaceTypeDesc);
|
||
function ImplementsCount: Integer;
|
||
function ImplementsIntfAt(AIndex: Integer): TInterfaceTypeDesc;
|
||
|
||
{ Property tracking }
|
||
procedure AddProperty(AProp: TPropertyInfo);
|
||
function FindProperty(const AName: string): TPropertyInfo;
|
||
|
||
property Fields: TObjectList read FFields;
|
||
property Properties: TObjectList read FProperties;
|
||
property Parent: TRecordTypeDesc read FParent write FParent;
|
||
property HasDestroyMethod: Boolean
|
||
read FHasDestroyMethod write FHasDestroyMethod;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Symbols }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
TSymbolKind = (
|
||
skVariable,
|
||
skType,
|
||
skProcedure,
|
||
skFunction,
|
||
skParameter,
|
||
skVarParameter,
|
||
skConstant { built-in or user-declared constant; ConstValue holds the integer value }
|
||
);
|
||
|
||
TParamDesc = class
|
||
public
|
||
Name: string;
|
||
TypeDesc: TTypeDesc; { not owned }
|
||
IsConst: Boolean;
|
||
IsVar: Boolean;
|
||
end;
|
||
|
||
TSymbol = class
|
||
public
|
||
Name: string;
|
||
Kind: TSymbolKind;
|
||
TypeDesc: TTypeDesc; { not owned; nil for procedures }
|
||
Params: TObjectList; { owned TParamDesc; populated for procedures/functions }
|
||
ConstValue: Int64; { valid when Kind = skConstant; integer/bool/enum value }
|
||
ConstString: string; { valid when Kind = skConstant and type is tyString }
|
||
IsWeak: Boolean; { true for variables declared [Weak]; codegen
|
||
keys off this to emit _WeakAssign instead
|
||
of the strong addref/release pattern. }
|
||
IsGlobal: Boolean; { true for program-level variables; codegen uses
|
||
QBE data-section storage instead of stack alloc }
|
||
constructor Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc);
|
||
destructor Destroy; override;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Scope }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
TScope = class
|
||
private
|
||
FParent: TScope;
|
||
FSymbols: TObjectList; { owns all TSymbol in this scope }
|
||
FKeys: TStringList; { sorted, case-insensitive; Objects[] = TSymbol (not owned) }
|
||
public
|
||
constructor Create(AParent: TScope);
|
||
destructor Destroy; override;
|
||
property Parent: TScope read FParent;
|
||
{ Returns False if name already defined in this scope; caller must free ASymbol. }
|
||
function Define(ASymbol: TSymbol): Boolean;
|
||
function LookupLocal(const AName: string): TSymbol;
|
||
function Lookup(const AName: string): TSymbol;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ Symbol table }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
TSymbolTable = class
|
||
private
|
||
FScopeStack: TObjectList; { owned TScope, index 0 = global }
|
||
FAllTypes: TObjectList; { owned TTypeDesc }
|
||
FGenerics: TStringList; { non-owning: base name → TGenericTypeDef* (void ptr) }
|
||
|
||
FTypeInteger: TTypeDesc;
|
||
FTypeInt64: TTypeDesc;
|
||
FTypeUInt32: TTypeDesc;
|
||
FTypeByte: TTypeDesc;
|
||
FTypeBoolean: TTypeDesc;
|
||
FTypeString: TTypeDesc;
|
||
FTypeVoid: TTypeDesc;
|
||
FTypeNil: TTypeDesc;
|
||
FTypePointer: TPointerTypeDesc; { untyped Pointer }
|
||
FTypePChar: TTypeDesc; { opaque C pointer }
|
||
|
||
function GetCurrentScope: TScope;
|
||
function GetScopeDepth: Integer;
|
||
function NewType(AKind: TTypeKind; const AName: string): TTypeDesc;
|
||
procedure RegisterBuiltins;
|
||
public
|
||
constructor Create;
|
||
destructor Destroy; override;
|
||
|
||
{ Scope management }
|
||
function PushScope: TScope;
|
||
procedure PopScope;
|
||
property CurrentScope: TScope read GetCurrentScope;
|
||
property ScopeDepth: Integer read GetScopeDepth;
|
||
|
||
{ Symbol management — owns ASymbol on success; caller must free on False }
|
||
function Define(ASymbol: TSymbol): Boolean;
|
||
{ Define in global (outermost) scope regardless of current push depth. }
|
||
function DefineGlobal(ASymbol: TSymbol): Boolean;
|
||
function Lookup(const AName: string): TSymbol;
|
||
|
||
{ Type lookup — case-insensitive, returns nil if not found }
|
||
function FindType(const AName: string): TTypeDesc;
|
||
|
||
{ Creates a new TRecordTypeDesc, registers it in FAllTypes, and returns it.
|
||
Caller must then add fields and register it as a skType symbol. }
|
||
function NewRecordType(const AName: string): TRecordTypeDesc;
|
||
|
||
{ Creates a new class type descriptor (tyClass, heap-allocated). }
|
||
function NewClassType(const AName: string): TRecordTypeDesc;
|
||
|
||
{ Creates a new interface type descriptor (tyInterface). }
|
||
function NewInterfaceType(const AName: string): TInterfaceTypeDesc;
|
||
|
||
{ Creates a typed pointer descriptor '^BaseType'. Registered in FAllTypes. }
|
||
function NewPointerType(const AName: string; ABase: TTypeDesc): TPointerTypeDesc;
|
||
function NewEnumType(const AName: string): TEnumTypeDesc;
|
||
function NewSetType(const AName: string; ABase: TEnumTypeDesc): TSetTypeDesc;
|
||
|
||
{ Creates an open-array type descriptor for element type AElementType.
|
||
Registered in FAllTypes so the table owns the lifetime. }
|
||
function NewOpenArrayType(AElementType: TTypeDesc): TOpenArrayTypeDesc;
|
||
|
||
{ Creates a static array type descriptor. Registered in FAllTypes. }
|
||
function NewStaticArrayType(AElementType: TTypeDesc;
|
||
ALow, AHigh: Integer): TStaticArrayTypeDesc;
|
||
|
||
{ Generic template registry — stores TGenericTypeDef as TObject to avoid
|
||
circular unit dependency with uAST. Callers cast the result. }
|
||
procedure RegisterGeneric(const AName: string; ATempl: TObject);
|
||
function FindGeneric(const AName: string): TObject;
|
||
|
||
{ Convenience type accessors }
|
||
property TypeInteger: TTypeDesc read FTypeInteger;
|
||
property TypeInt64: TTypeDesc read FTypeInt64;
|
||
property TypeUInt32: TTypeDesc read FTypeUInt32;
|
||
property TypeByte: TTypeDesc read FTypeByte;
|
||
property TypeBoolean: TTypeDesc read FTypeBoolean;
|
||
property TypeString: TTypeDesc read FTypeString;
|
||
property TypeVoid: TTypeDesc read FTypeVoid;
|
||
property TypeNil: TTypeDesc read FTypeNil;
|
||
property TypePointer: TPointerTypeDesc read FTypePointer;
|
||
property TypePChar: TTypeDesc read FTypePChar;
|
||
end;
|
||
|
||
implementation
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ TTypeDesc }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
function TTypeDesc.IsNumeric: Boolean;
|
||
begin
|
||
Result := Kind in [tyInteger, tyInt64, tyUInt32, tyByte, tyEnum];
|
||
end;
|
||
|
||
function TTypeDesc.IsString: Boolean;
|
||
begin
|
||
Result := Kind = tyString;
|
||
end;
|
||
|
||
function TTypeDesc.IsOrdinal: Boolean;
|
||
begin
|
||
Result := Kind in [tyInteger, tyInt64, tyUInt32, tyByte, tyBoolean, tyEnum];
|
||
end;
|
||
|
||
function TTypeDesc.IsRecord: Boolean;
|
||
begin
|
||
Result := Kind = tyRecord;
|
||
end;
|
||
|
||
function TTypeDesc.RawSize: Integer;
|
||
begin
|
||
case Kind of
|
||
tyByte, tyBoolean: Result := 1;
|
||
tyInteger, tyUInt32, tyEnum: Result := 4;
|
||
tyInt64, tyString, tyClass, tyPointer, tyNil: Result := 8;
|
||
tyRecord: Result := TRecordTypeDesc(Self).TotalSize;
|
||
tySet: if TSetTypeDesc(Self).BitCount <= 32 then Result := 4 else Result := 8;
|
||
tyStaticArray:
|
||
Result := (TStaticArrayTypeDesc(Self).HighBound -
|
||
TStaticArrayTypeDesc(Self).LowBound + 1) *
|
||
TStaticArrayTypeDesc(Self).ElementType.RawSize;
|
||
else
|
||
Result := 8;
|
||
end;
|
||
end;
|
||
|
||
function TTypeDesc.ByteSize: Integer;
|
||
begin
|
||
case Kind of
|
||
tyInteger, tyUInt32, tyEnum: Result := 4;
|
||
tyInt64: Result := 8;
|
||
tyByte, tyBoolean: Result := 4; { stored as word, same as AllocAlign }
|
||
tyString: Result := 8; { pointer size on 64-bit }
|
||
tyRecord: Result := TRecordTypeDesc(Self).TotalSize;
|
||
tyNil: Result := 8;
|
||
tySet: if TSetTypeDesc(Self).BitCount <= 32 then Result := 4 else Result := 8;
|
||
tyStaticArray:
|
||
Result := (TStaticArrayTypeDesc(Self).HighBound -
|
||
TStaticArrayTypeDesc(Self).LowBound + 1) *
|
||
TStaticArrayTypeDesc(Self).ElementType.RawSize;
|
||
else
|
||
Result := 8;
|
||
end;
|
||
end;
|
||
|
||
function TTypeDesc.AllocAlign: Integer;
|
||
begin
|
||
case Kind of
|
||
tyInteger, tyUInt32, tyEnum: Result := 4;
|
||
tyByte, tyBoolean: Result := 4; { round up to word boundary }
|
||
tyInt64, tyString: Result := 8;
|
||
tyRecord: Result := TRecordTypeDesc(Self).MaxAlign;
|
||
tySet: if TSetTypeDesc(Self).BitCount <= 32 then Result := 4 else Result := 8;
|
||
tyStaticArray: Result := TStaticArrayTypeDesc(Self).ElementType.AllocAlign;
|
||
else
|
||
Result := 8;
|
||
end;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ TRecordTypeDesc }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
constructor TRecordTypeDesc.Create(const AName: string; AKind: TTypeKind);
|
||
begin
|
||
inherited Create;
|
||
Kind := AKind;
|
||
Name := AName;
|
||
FFields := TObjectList.Create(True);
|
||
FKeys := TStringList.Create;
|
||
FKeys.Sorted := True;
|
||
FKeys.CaseSensitive := False;
|
||
FKeys.Duplicates := dupIgnore;
|
||
FVTable := nil; { allocated on first use }
|
||
FImplements := TObjectList.Create(False); { not owned }
|
||
FProperties := TObjectList.Create(True); { owned TPropertyInfo }
|
||
end;
|
||
|
||
destructor TRecordTypeDesc.Destroy;
|
||
begin
|
||
FProperties.Free;
|
||
FImplements.Free;
|
||
FKeys.Free;
|
||
FFields.Free;
|
||
FVTable.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TRecordTypeDesc.AddField(const AName: string; AType: TTypeDesc);
|
||
var
|
||
Info: TFieldInfo;
|
||
Offset: Integer;
|
||
begin
|
||
Offset := TotalSize; { next available byte (includes vptr if present) }
|
||
Info := TFieldInfo.Create;
|
||
Info.Name := AName;
|
||
Info.TypeDesc := AType;
|
||
Info.Offset := Offset;
|
||
FFields.Add(Info);
|
||
FKeys.AddObject(AName, Info);
|
||
end;
|
||
|
||
function TRecordTypeDesc.FindField(const AName: string): TFieldInfo;
|
||
var
|
||
Idx: Integer;
|
||
begin
|
||
if FKeys.Find(AName, Idx) then
|
||
Result := TFieldInfo(FKeys.Objects[Idx])
|
||
else
|
||
Result := nil;
|
||
end;
|
||
|
||
function TRecordTypeDesc.TotalSize: Integer;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
{ vptr (8 bytes) precedes all fields when this class has a vtable }
|
||
if HasVTable then
|
||
Result := 8
|
||
else
|
||
Result := 0;
|
||
for I := 0 to FFields.Count - 1 do
|
||
Inc(Result, TFieldInfo(FFields.Items[I]).TypeDesc.ByteSize);
|
||
end;
|
||
|
||
function TRecordTypeDesc.MaxAlign: Integer;
|
||
var
|
||
I, A: Integer;
|
||
begin
|
||
Result := 4;
|
||
if HasVTable then
|
||
Result := 8; { vptr requires 8-byte alignment }
|
||
for I := 0 to FFields.Count - 1 do
|
||
begin
|
||
A := TFieldInfo(FFields.Items[I]).TypeDesc.AllocAlign;
|
||
if A > Result then
|
||
Result := A;
|
||
end;
|
||
end;
|
||
|
||
function TRecordTypeDesc.HasVTable: Boolean;
|
||
begin
|
||
Result := (FVTable <> nil) and (FVTable.Count > 0);
|
||
end;
|
||
|
||
function TRecordTypeDesc.VTableCount: Integer;
|
||
begin
|
||
if FVTable = nil then
|
||
Result := 0
|
||
else
|
||
Result := FVTable.Count;
|
||
end;
|
||
|
||
function TRecordTypeDesc.VTableEntryAt(ASlot: Integer): TVTableEntry;
|
||
begin
|
||
if (FVTable = nil) or (ASlot < 0) or (ASlot >= FVTable.Count) then
|
||
Result := nil
|
||
else
|
||
Result := TVTableEntry(FVTable.Items[ASlot]);
|
||
end;
|
||
|
||
function TRecordTypeDesc.FindVTableSlot(const AMethodName: string): Integer;
|
||
var
|
||
I: Integer;
|
||
E: TVTableEntry;
|
||
begin
|
||
Result := -1;
|
||
if FVTable = nil then Exit;
|
||
for I := 0 to FVTable.Count - 1 do
|
||
begin
|
||
E := TVTableEntry(FVTable.Items[I]);
|
||
if SameText(E.MethName, AMethodName) then
|
||
begin
|
||
Result := I;
|
||
Exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function TRecordTypeDesc.AddVTableSlot(const AMethodName, AImplName: string): Integer;
|
||
var
|
||
E: TVTableEntry;
|
||
begin
|
||
if FVTable = nil then
|
||
FVTable := TObjectList.Create(True);
|
||
E := TVTableEntry.Create;
|
||
E.Slot := FVTable.Count;
|
||
E.MethName := AMethodName;
|
||
E.ImplName := AImplName;
|
||
FVTable.Add(E);
|
||
Result := E.Slot;
|
||
end;
|
||
|
||
procedure TRecordTypeDesc.OverrideVTableSlot(ASlot: Integer; const AImplName: string);
|
||
begin
|
||
if (FVTable <> nil) and (ASlot >= 0) and (ASlot < FVTable.Count) then
|
||
TVTableEntry(FVTable.Items[ASlot]).ImplName := AImplName;
|
||
end;
|
||
|
||
procedure TRecordTypeDesc.AddImplements(AIntf: TInterfaceTypeDesc);
|
||
begin
|
||
FImplements.Add(AIntf);
|
||
end;
|
||
|
||
function TRecordTypeDesc.ImplementsCount: Integer;
|
||
begin
|
||
Result := FImplements.Count;
|
||
end;
|
||
|
||
function TRecordTypeDesc.ImplementsIntfAt(AIndex: Integer): TInterfaceTypeDesc;
|
||
begin
|
||
Result := TInterfaceTypeDesc(FImplements.Items[AIndex]);
|
||
end;
|
||
|
||
procedure TRecordTypeDesc.CopyVTableFrom(AParent: TRecordTypeDesc);
|
||
var
|
||
I: Integer;
|
||
Src, Dst: TVTableEntry;
|
||
begin
|
||
if (AParent = nil) or (AParent.VTableCount = 0) then Exit;
|
||
if FVTable = nil then
|
||
FVTable := TObjectList.Create(True);
|
||
for I := 0 to AParent.VTableCount - 1 do
|
||
begin
|
||
Src := AParent.VTableEntryAt(I);
|
||
Dst := TVTableEntry.Create;
|
||
Dst.Slot := Src.Slot;
|
||
Dst.MethName := Src.MethName;
|
||
Dst.ImplName := Src.ImplName;
|
||
FVTable.Add(Dst);
|
||
end;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ TInterfaceTypeDesc }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
procedure TRecordTypeDesc.AddProperty(AProp: TPropertyInfo);
|
||
begin
|
||
FProperties.Add(AProp);
|
||
end;
|
||
|
||
function TRecordTypeDesc.FindProperty(const AName: string): TPropertyInfo;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
for I := 0 to FProperties.Count - 1 do
|
||
if SameText(TPropertyInfo(FProperties.Items[I]).Name, AName) then
|
||
begin
|
||
Result := TPropertyInfo(FProperties.Items[I]);
|
||
Exit;
|
||
end;
|
||
Result := nil;
|
||
end;
|
||
|
||
constructor TInterfaceTypeDesc.Create(const AName: string);
|
||
begin
|
||
inherited Create;
|
||
Kind := tyInterface;
|
||
Name := AName;
|
||
FMethods := TStringList.Create;
|
||
FMethods.CaseSensitive := False;
|
||
FReturnTypes := TStringList.Create;
|
||
FParent := nil;
|
||
end;
|
||
|
||
destructor TInterfaceTypeDesc.Destroy;
|
||
begin
|
||
FReturnTypes.Free;
|
||
FMethods.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TInterfaceTypeDesc.AddMethod(const AName: string;
|
||
const AReturnTypeName: string);
|
||
begin
|
||
FMethods.Add(AName);
|
||
FReturnTypes.Add(AReturnTypeName);
|
||
end;
|
||
|
||
function TInterfaceTypeDesc.HasMethod(const AName: string): Boolean;
|
||
begin
|
||
Result := FMethods.IndexOf(AName) >= 0;
|
||
end;
|
||
|
||
function TInterfaceTypeDesc.MethodCount: Integer;
|
||
begin
|
||
Result := FMethods.Count;
|
||
end;
|
||
|
||
function TInterfaceTypeDesc.MethodName(AIndex: Integer): string;
|
||
begin
|
||
Result := FMethods.Strings[AIndex];
|
||
end;
|
||
|
||
function TInterfaceTypeDesc.MethodReturnTypeName(AIndex: Integer): string;
|
||
begin
|
||
Result := FReturnTypes.Strings[AIndex];
|
||
end;
|
||
|
||
function TInterfaceTypeDesc.MethodIndex(const AName: string): Integer;
|
||
begin
|
||
Result := FMethods.IndexOf(AName);
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ TSymbol }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
constructor TSymbol.Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc);
|
||
begin
|
||
inherited Create;
|
||
Name := AName;
|
||
Kind := AKind;
|
||
TypeDesc := AType;
|
||
Params := TObjectList.Create(True);
|
||
IsWeak := False;
|
||
end;
|
||
|
||
destructor TSymbol.Destroy;
|
||
begin
|
||
Params.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ TScope }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
constructor TScope.Create(AParent: TScope);
|
||
begin
|
||
inherited Create;
|
||
FParent := AParent;
|
||
FSymbols := TObjectList.Create(True);
|
||
FKeys := TStringList.Create;
|
||
FKeys.Sorted := True;
|
||
FKeys.CaseSensitive := False;
|
||
FKeys.Duplicates := dupIgnore; { we check manually before inserting }
|
||
end;
|
||
|
||
destructor TScope.Destroy;
|
||
begin
|
||
FKeys.Free;
|
||
FSymbols.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TScope.Define(ASymbol: TSymbol): Boolean;
|
||
var
|
||
Idx: Integer;
|
||
begin
|
||
if FKeys.Find(ASymbol.Name, Idx) then
|
||
begin
|
||
Result := False;
|
||
Exit;
|
||
end;
|
||
FSymbols.Add(ASymbol);
|
||
{ Store the TSymbol pointer directly in the string list's Objects slot. }
|
||
FKeys.AddObject(ASymbol.Name, ASymbol);
|
||
Result := True;
|
||
end;
|
||
|
||
function TScope.LookupLocal(const AName: string): TSymbol;
|
||
var
|
||
Idx: Integer;
|
||
begin
|
||
if FKeys.Find(AName, Idx) then
|
||
Result := TSymbol(FKeys.Objects[Idx])
|
||
else
|
||
Result := nil;
|
||
end;
|
||
|
||
function TScope.Lookup(const AName: string): TSymbol;
|
||
var
|
||
S: TScope;
|
||
begin
|
||
S := Self;
|
||
while S <> nil do
|
||
begin
|
||
Result := S.LookupLocal(AName);
|
||
if Result <> nil then
|
||
Exit;
|
||
S := S.FParent;
|
||
end;
|
||
Result := nil;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ TEnumTypeDesc }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
constructor TEnumTypeDesc.Create(const AName: string);
|
||
begin
|
||
inherited Create;
|
||
Kind := tyEnum;
|
||
Name := AName;
|
||
Members := TStringList.Create;
|
||
end;
|
||
|
||
destructor TEnumTypeDesc.Destroy;
|
||
begin
|
||
Members.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TEnumTypeDesc.OrdinalOf(const AMember: string): Integer;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
for I := 0 to Members.Count - 1 do
|
||
if SameText(Members.Strings[I], AMember) then
|
||
begin
|
||
Result := I;
|
||
Exit;
|
||
end;
|
||
Result := -1;
|
||
end;
|
||
|
||
{ ------------------------------------------------------------------ }
|
||
{ TSymbolTable }
|
||
{ ------------------------------------------------------------------ }
|
||
|
||
constructor TSymbolTable.Create;
|
||
begin
|
||
inherited Create;
|
||
FScopeStack := TObjectList.Create(True);
|
||
FAllTypes := TObjectList.Create(True);
|
||
FGenerics := TStringList.Create;
|
||
FGenerics.CaseSensitive := True;
|
||
{ Global scope — parent = nil }
|
||
FScopeStack.Add(TScope.Create(nil));
|
||
RegisterBuiltins;
|
||
end;
|
||
|
||
destructor TSymbolTable.Destroy;
|
||
begin
|
||
FGenerics.Free;
|
||
FScopeStack.Free;
|
||
FAllTypes.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TSymbolTable.NewType(AKind: TTypeKind; const AName: string): TTypeDesc;
|
||
begin
|
||
Result := TTypeDesc.Create;
|
||
Result.Kind := AKind;
|
||
Result.Name := AName;
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewRecordType(const AName: string): TRecordTypeDesc;
|
||
begin
|
||
Result := TRecordTypeDesc.Create(AName, tyRecord);
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewClassType(const AName: string): TRecordTypeDesc;
|
||
begin
|
||
Result := TRecordTypeDesc.Create(AName, tyClass);
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewInterfaceType(const AName: string): TInterfaceTypeDesc;
|
||
begin
|
||
Result := TInterfaceTypeDesc.Create(AName);
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewPointerType(const AName: string; ABase: TTypeDesc): TPointerTypeDesc;
|
||
begin
|
||
Result := TPointerTypeDesc.Create;
|
||
Result.Kind := tyPointer;
|
||
Result.Name := AName;
|
||
Result.BaseType := ABase;
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewEnumType(const AName: string): TEnumTypeDesc;
|
||
begin
|
||
Result := TEnumTypeDesc.Create(AName);
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewSetType(const AName: string; ABase: TEnumTypeDesc): TSetTypeDesc;
|
||
begin
|
||
Result := TSetTypeDesc.Create;
|
||
Result.Kind := tySet;
|
||
Result.Name := AName;
|
||
Result.BaseType := ABase;
|
||
Result.BitCount := ABase.Members.Count;
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewOpenArrayType(AElementType: TTypeDesc): TOpenArrayTypeDesc;
|
||
begin
|
||
Result := TOpenArrayTypeDesc.Create;
|
||
Result.Kind := tyOpenArray;
|
||
Result.Name := 'array of ' + AElementType.Name;
|
||
Result.ElementType := AElementType;
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
function TSymbolTable.NewStaticArrayType(AElementType: TTypeDesc;
|
||
ALow, AHigh: Integer): TStaticArrayTypeDesc;
|
||
begin
|
||
Result := TStaticArrayTypeDesc.Create;
|
||
Result.Kind := tyStaticArray;
|
||
Result.Name := Format('array[%d..%d] of %s', [ALow, AHigh, AElementType.Name]);
|
||
Result.ElementType := AElementType;
|
||
Result.LowBound := ALow;
|
||
Result.HighBound := AHigh;
|
||
FAllTypes.Add(Result);
|
||
end;
|
||
|
||
procedure TSymbolTable.RegisterGeneric(const AName: string; ATempl: TObject);
|
||
begin
|
||
FGenerics.AddObject(AName, ATempl);
|
||
end;
|
||
|
||
function TSymbolTable.FindGeneric(const AName: string): TObject;
|
||
var
|
||
Idx: Integer;
|
||
begin
|
||
Idx := FGenerics.IndexOf(AName);
|
||
if Idx >= 0 then
|
||
Result := FGenerics.Objects[Idx]
|
||
else
|
||
Result := nil;
|
||
end;
|
||
|
||
procedure TSymbolTable.RegisterBuiltins;
|
||
var
|
||
Sym: TSymbol;
|
||
TObjectDesc: TRecordTypeDesc;
|
||
begin
|
||
{ Primitive types }
|
||
FTypeInteger := NewType(tyInteger, 'Integer');
|
||
FTypeInt64 := NewType(tyInt64, 'Int64');
|
||
FTypeUInt32 := NewType(tyUInt32, 'UInt32');
|
||
FTypeByte := NewType(tyByte, 'Byte');
|
||
FTypeBoolean := NewType(tyBoolean, 'Boolean');
|
||
FTypeString := NewType(tyString, 'string');
|
||
FTypeVoid := NewType(tyVoid, 'void');
|
||
FTypeNil := NewType(tyNil, 'nil');
|
||
FTypePointer := NewPointerType('Pointer', nil); { untyped pointer }
|
||
FTypePChar := NewType(tyPChar, 'PChar');
|
||
|
||
{ Register type names as skType symbols in global scope }
|
||
Define(TSymbol.Create('Integer', skType, FTypeInteger));
|
||
Define(TSymbol.Create('Int64', skType, FTypeInt64));
|
||
Define(TSymbol.Create('UInt32', skType, FTypeUInt32));
|
||
Define(TSymbol.Create('Cardinal', skType, FTypeUInt32)); { FPC/Delphi alias }
|
||
Define(TSymbol.Create('PtrUInt', skType, FTypeInt64)); { FPC: pointer-sized unsigned = QWord on 64-bit }
|
||
Define(TSymbol.Create('Byte', skType, FTypeByte));
|
||
Define(TSymbol.Create('Boolean', skType, FTypeBoolean));
|
||
Define(TSymbol.Create('string', skType, FTypeString));
|
||
Define(TSymbol.Create('Pointer', skType, FTypePointer));
|
||
Define(TSymbol.Create('PChar', skType, FTypePChar));
|
||
|
||
{ TObject — root of the class hierarchy; no fields, no parent }
|
||
TObjectDesc := NewClassType('TObject');
|
||
TObjectDesc.AddVTableSlot('Destroy', '$TObject_Destroy');
|
||
Define(TSymbol.Create('TObject', skType, TObjectDesc));
|
||
|
||
{ IInterface — root of the interface hierarchy; no methods }
|
||
Define(TSymbol.Create('IInterface', skType, NewInterfaceType('IInterface')));
|
||
|
||
{ Boolean constants }
|
||
Sym := TSymbol.Create('True', skConstant, FTypeBoolean);
|
||
Sym.ConstValue := 1;
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('False', skConstant, FTypeBoolean);
|
||
Sym.ConstValue := 0;
|
||
Define(Sym);
|
||
|
||
{ Integer range constants — MaxInt is the 32-bit maximum; all Copy(S,N,MaxInt)
|
||
uses mean "rest of string" which works for strings shorter than 2 GB. }
|
||
Sym := TSymbol.Create('MaxInt', skConstant, FTypeInteger);
|
||
Sym.ConstValue := 2147483647;
|
||
Define(Sym);
|
||
|
||
{ Built-in I/O procedures }
|
||
Sym := TSymbol.Create('Write', skProcedure, nil);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('WriteLn', skProcedure, nil);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('StdErr', skConstant, FTypeInteger);
|
||
Sym.ConstValue := 2;
|
||
Define(Sym);
|
||
|
||
{ Built-in set procedures }
|
||
Sym := TSymbol.Create('Include', skProcedure, nil);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Exclude', skProcedure, nil);
|
||
Define(Sym);
|
||
|
||
{ Built-in memory management }
|
||
Sym := TSymbol.Create('GetMem', skFunction, FTypePointer);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('ReallocMem', skFunction, FTypePointer);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('FreeMem', skProcedure, nil);
|
||
Define(Sym);
|
||
|
||
{ Built-in string operations }
|
||
Sym := TSymbol.Create('Format', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Length', skFunction, FTypeInteger);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Pos', skFunction, FTypeInteger);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Copy', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('UpperCase', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('LowerCase', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Trim', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('SameText', skFunction, FTypeBoolean);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('IntToStr', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Int64ToStr', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('StrToInt', skFunction, FTypeInteger);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('StrToInt64', skFunction, FTypeInt64);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('CompareStr', skFunction, FTypeInteger);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('CompareText', skFunction, FTypeInteger);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('OrdAt', skFunction, FTypeInteger);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Ord', skFunction, FTypeInteger);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('Chr', skFunction, FTypeString);
|
||
Define(Sym);
|
||
Sym := TSymbol.Create('UpCase', skFunction, FTypeString);
|
||
Define(Sym);
|
||
{ Inc/Dec — in-place increment/decrement (var param, 1 or 2 args) }
|
||
Sym := TSymbol.Create('Inc', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('Dec', skProcedure, nil); Define(Sym);
|
||
{ Memory utilities }
|
||
Sym := TSymbol.Create('ZeroMem', skProcedure, nil); Define(Sym);
|
||
{ CLI arguments }
|
||
Sym := TSymbol.Create('ParamCount', skFunction, FTypeInteger); Define(Sym);
|
||
Sym := TSymbol.Create('ParamStr', skFunction, FTypeString); Define(Sym);
|
||
{ File I/O }
|
||
Sym := TSymbol.Create('ReadFile', skFunction, FTypeString); Define(Sym);
|
||
Sym := TSymbol.Create('WriteFile', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('AppendFile', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('FileExists', skFunction, FTypeBoolean); Define(Sym);
|
||
Sym := TSymbol.Create('DeleteFile', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('CurrentExceptionMessage', skFunction, FTypeString); Define(Sym);
|
||
{ Environment and process }
|
||
Sym := TSymbol.Create('GetEnvVar', skFunction, FTypeString); Define(Sym);
|
||
Sym := TSymbol.Create('GetEnvironmentVariable', skFunction, FTypeString); Define(Sym);
|
||
Sym := TSymbol.Create('Exec', skFunction, FTypeInteger); Define(Sym);
|
||
Sym := TSymbol.Create('Halt', skProcedure, nil); Define(Sym);
|
||
{ File path manipulation }
|
||
Sym := TSymbol.Create('ChangeFileExt', skFunction, FTypeString); Define(Sym);
|
||
Sym := TSymbol.Create('ExtractFileName', skFunction, FTypeString); Define(Sym);
|
||
Sym := TSymbol.Create('ExtractFilePath', skFunction, FTypeString); Define(Sym);
|
||
Sym := TSymbol.Create('IncludeTrailingPathDelimiter', skFunction, FTypeString); Define(Sym);
|
||
{ Process management (used by Process.pas RTL) }
|
||
Sym := TSymbol.Create('ProcessCreate', skFunction, FTypePointer); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessSetExe', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessAddArg', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessExecute', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessRunning', skFunction, FTypeBoolean); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessReadOutput', skFunction, FTypeString); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessWaitOnExit', skProcedure, nil); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessExitCode', skFunction, FTypeInteger); Define(Sym);
|
||
Sym := TSymbol.Create('ProcessFree', skProcedure, nil); Define(Sym);
|
||
end;
|
||
|
||
function TSymbolTable.DefineGlobal(ASymbol: TSymbol): Boolean;
|
||
begin
|
||
Result := TScope(FScopeStack.Items[0]).Define(ASymbol);
|
||
end;
|
||
|
||
function TSymbolTable.GetCurrentScope: TScope;
|
||
begin
|
||
Result := TScope(FScopeStack.Items[FScopeStack.Count - 1]);
|
||
end;
|
||
|
||
function TSymbolTable.GetScopeDepth: Integer;
|
||
begin
|
||
Result := FScopeStack.Count;
|
||
end;
|
||
|
||
function TSymbolTable.PushScope: TScope;
|
||
begin
|
||
Result := TScope.Create(CurrentScope);
|
||
FScopeStack.Add(Result);
|
||
end;
|
||
|
||
procedure TSymbolTable.PopScope;
|
||
begin
|
||
if FScopeStack.Count > 1 then
|
||
FScopeStack.Delete(FScopeStack.Count - 1);
|
||
end;
|
||
|
||
function TSymbolTable.Define(ASymbol: TSymbol): Boolean;
|
||
begin
|
||
Result := CurrentScope.Define(ASymbol);
|
||
end;
|
||
|
||
function TSymbolTable.Lookup(const AName: string): TSymbol;
|
||
begin
|
||
Result := CurrentScope.Lookup(AName);
|
||
end;
|
||
|
||
function TSymbolTable.FindType(const AName: string): TTypeDesc;
|
||
var
|
||
Sym: TSymbol;
|
||
begin
|
||
Sym := CurrentScope.Lookup(AName);
|
||
if (Sym <> nil) and (Sym.Kind = skType) then
|
||
Result := Sym.TypeDesc
|
||
else
|
||
Result := nil;
|
||
end;
|
||
|
||
end.
|