dws2symbols.pas

script language

  // Enumeration type. E. g. "type myEnum = (One, Two, Three);"
  TEnumerationSymbol = class(TNameSymbol)
  private
    FElements: TSymbolTable;
  protected
    function GetCaption: string; override;
    function GetDescription: string; override;
  public
    constructor Create(Name: string; BaseType: TTypeSymbol);
    destructor Destroy; override;
    procedure AddElement(Element: TElementSymbol);
    property Elements: TSymbolTable read FElements;
  end;

  IObjectOwner = interface
    procedure ReleaseObject;
  end;

  // A table of symbols connected to other symboltables (property Parents)
  TSymbolTable = class
  private
    FAddrGenerator: TAddrGenerator;
    FCurrHot: Word;
    FHot: array[0..SymbolCacheSize - 1] of TSymbol;
    FSymbols: TList;
    FParents: TList;
    FDestructionList: TList;
    FObjects: TInterfaceList;
    function GetParentCount: Integer;
    function GetParents(Index: Integer): TSymbolTable;
  protected
    procedure ClearHotList;
    function GetSymbol(Index: Integer): TSymbol;
    procedure SetSymbol(Index: Integer; Value: TSymbol);
    function GetCount: Integer;
  public
    constructor Create(Parent: TSymbolTable = nil; AddrGenerator: TAddrGenerator = nil);
    destructor Destroy; override;

    procedure BeforeDestruction; override;
    procedure InsertParent(Index: Integer; Parent: TSymbolTable); virtual;
    function RemoveParent(Parent: TSymbolTable): Integer; virtual;
    function IndexOfParent(Parent: TSymbolTable): Integer;
    procedure MoveParent(CurIndex, NewIndex: Integer);
    procedure ClearParents;
    procedure AddParent(Parent: TSymbolTable);

    function AddSymbol(Sym: TSymbol): Integer;
    function FindLocal(const Name: string): TSymbol; virtual;
    procedure AddToDestructionList(Sym: TSymbol);
    function Remove(Sym: TSymbol): Integer;
    procedure Clear;

    function FindSymbol(const Name: string): TSymbol; virtual;
    function HasSymbol(const Name: string): Boolean;
    procedure ReplaceSymbol(OldSym, NewSym: TSymbol);

    procedure AddObjectOwner(AOwner : IObjectOwner);

    procedure Initialize; virtual;

    property AddrGenerator: TAddrGenerator read FAddrGenerator;
    property Count: Integer read GetCount;
    property Symbols[x: Integer]: TSymbol read GetSymbol write SetSymbol; default;
    property ParentCount: Integer read GetParentCount;
    property Parents[Index: Integer]: TSymbolTable read GetParents;
  end;

  TSymbolTableClass = class of TSymbolTable;

  TStaticSymbolTable = class (TSymbolTable)
  private
    FRefCount: Integer;
    FInitialized: Boolean;
  public
    constructor Create(Parent: TStaticSymbolTable = nil; Reference: Boolean = True);
    destructor Destroy; override;
    procedure Initialize; override;
    procedure InsertParent(Index: Integer; Parent: TSymbolTable); override;
    function RemoveParent(Parent: TSymbolTable): Integer; override;
    procedure _AddRef;
    procedure _Release;
  end;

  TLinkedSymbolTable = class (TSymbolTable)
  private
    FParent: TStaticSymbolTable;
  public
    constructor Create(Parent: TStaticSymbolTable; AddrGenerator: TAddrGenerator = nil);
    destructor Destroy; override;
    function FindLocal(const Name: string): TSymbol; override;
    function FindSymbol(const Name: string): TSymbol; override;
    procedure Initialize; override;
    property Parent: TStaticSymbolTable read FParent;
  end;

  IScriptObj = interface
    ['{8D534D1E-4C6B-11D5-8DCB-0000216D9E86}']
    function GetClassSym: TClassSymbol;
    function GetData: TData;
    procedure SetData(Dat: TData);
    function GetExternalObject: TObject;
    procedure SetExternalObject(Value: TObject);
    property ClassSym: TClassSymbol read GetClassSym;
    property Data: TData read GetData write SetData;
    property ExternalObject: TObject read GetExternalObject write SetExternalObject;
  end;

function IsBaseTypeCompatible(AType, BType: TBaseTypeId): Boolean;

implementation

uses
  SysUtils, dws2Functions, dws2Errors
{$IFDEF WIN32}
  ,Windows
{$ENDIF};

{ TSymbol }

constructor TSymbol.Create(Name: string; Typ: TSymbol);
begin
  FName := Name;
  FTyp := Typ;
  if Assigned(FTyp) then
    FSize := FTyp.FSize
  else
    FSize := 0;
end;

{ TVarSymbol }

function TSymbol.GetCaption: string;
begin
  Result := FName;
end;

function TSymbol.GetDescription: string;
begin
  Result := Caption;
end;

procedure TSymbol.InitData(Dat: TData; Offset: Integer);
begin
end;

procedure TSymbol.CopyData(FromData: TData; FromAddr: Integer; ToData: TData; ToAddr: Integer);
var
  x: Integer;
begin
  for x := 1 to FSize do
  begin
    VarCopy(ToData[ToAddr], FromData[FromAddr]);
    Inc(FromAddr);
    Inc(ToAddr);
  end;
end;

procedure TSymbol.Initialize;
begin
end;

function TSymbol.IsCompatible(typSym: TSymbol): Boolean;
begin
  result := False;
end;

function TSymbol.BaseType: TTypeSymbol;
begin
  result := nil;
end;

{ TRecordSymbol }

constructor TRecordSymbol.Create;
begin
  inherited Create(Name, nil);
  FMembers := TSymbolTable.Create(nil);
end;

destructor TRecordSymbol.Destroy;
begin
  FMembers.Free;
  inherited;
end;

procedure TRecordSymbol.AddMember(Member: TMemberSymbol);
begin
  Member.RecordSymbol := Self;
  Member.Offset := FSize;
  FSize := FSize + Member.Typ.Size;
  FMembers.AddSymbol(Member);
end;

procedure TRecordSymbol.InitData(Dat: TData; Offset: Integer);
var
  x: Integer;
begin
  for x := 0 to FMembers.Count - 1 do
    FMembers[x].InitData(Dat, Offset + TMemberSymbol(FMembers[x]).Offset);
end;

procedure TRecordSymbol.CopyData(FromData: TData; FromAddr: Integer;
  ToData: TData; ToAddr: Integer);
var
  x: Integer;
  m: TMemberSymbol;
begin
  for x := 0 to FMembers.Count - 1 do
  begin
    m := TMemberSymbol(FMembers[x]);
    m.Typ.CopyData(FromData, FromAddr + m.Offset,
      ToData, ToAddr + m.Offset);
  end;
end;

function TRecordSymbol.IsCompatible(typSym: TSymbol): Boolean;
var
  x: Integer;
begin
  typSym := typSym.BaseType;
  Result := (typSym is TRecordSymbol) and (FMembers.Count =
    TRecordSymbol(typSym).FMembers.Count);

  x := 0;
  while Result and (x < FMembers.Count) do
  begin
    Result := FMembers[x].Typ.IsCompatible(TRecordSymbol(TypSym).FMembers[x].Typ);
    Inc(x);
  end;
end;

function TRecordSymbol.GetCaption: string;
var
  x: Integer;
begin
  Result := 'record';
  if FMembers.Count > 0 then
  begin
    Result := Result + ' ' + FMembers[0].Typ.Caption;
    for x := 1 to FMembers.Count - 1 do
      Result := Result + ', ' + FMembers[x].Typ.Caption;
  end;
  Result := Result + ' end';
end;

function TRecordSymbol.GetDescription: string;
var
  x: Integer;
begin
  Result := 'record';
  for x := 0 to FMembers.Count - 1 do
    Result := Result + ' ' + FMembers[x].Description;
  Result := Result + ' end';
end;

{ TArraySymbol }

constructor TArraySymbol.Create(Name: string; LowBound, HighBound: Integer; Typ:
  TSymbol);
begin
  inherited Create(Name, Typ);
  SetBounds(LowBound, HighBound);
end;

procedure TArraySymbol.InitData(Dat: TData; Offset: Integer);
var
  x: Integer;
begin
  Dat[Offset] := Offset + 1; // ADDR
  Inc(Offset);
  Dat[Offset] := Elements; // DIM
  Inc(Offset);
  Dat[Offset] := Typ.Size; // SIZE
  Inc(Offset);
  for x := 1 to Elements do
  begin
    Typ.InitData(Dat, Offset);
    Offset := Offset + Typ.Size;
  end;
end;

function TArraySymbol.IsCompatible(typSym: TSymbol): Boolean;
begin
  typSym := typSym.BaseType;
  Result := (typSym is TArraySymbol)
    and (Elements = TArraySymbol(typSym).Elements)
    and Typ.IsCompatible(typSym.Typ);
end;

procedure TArraySymbol.SetBounds(LowBound, HighBound: Integer);
begin
  FLowBound := LowBound;
  FHighBound := HighBound;
  if Assigned(Typ) then
    FSize := 3 + Elements * Typ.Size; // ADDR + DIM + ELSIZE + DATA
end;

function TArraySymbol.GetCaption;
begin
  if Elements = 0 then
    Result := ''
  else
    Result := '[' + IntToStr(FLowBound) + '..' + IntToStr(FHighBound) + '] ';
  Result := 'array ' + Result + 'of ';
  if Assigned(FTyp) then
    Result := Result + FTyp.Caption
  else
    Result := Result + '<unknown>';
end;

function TArraySymbol.GetElements: Integer;
begin
  result := FHighBound - FLowBound + 1;
end;

procedure TArraySymbol.CopyData(FromData: TData; FromAddr: Integer;
  ToData: TData; ToAddr: Integer);
var
  x: Integer;
  FromSize, ToSize: Integer;
begin
  ToData[ToAddr] := ToAddr + 1; // ADR
  Inc(ToAddr);
  Inc(FromAddr);
  x := FromData[FromAddr];
  ToData[ToAddr] := x; // DIM
  Inc(ToAddr);
  Inc(FromAddr);
  FromSize := FromData[FromAddr];
  ToSize := Typ.Size;
  ToData[ToAddr] := ToSize;
  Inc(ToAddr);
  Inc(FromAddr);
  while x > 0 do
  begin
    Typ.CopyData(FromData, FromAddr, ToData, ToAddr);
    Inc(ToAddr, ToSize);
    Inc(FromAddr, FromSize);
    Dec(x);
  end;
end;

{ TFuncSymbol }

constructor TFuncSymbol.Create(Name: string; FuncKind: TFuncKind;
  FuncLevel: Integer);
begin
  inherited Create(Name, nil);
  FKind := FuncKind;
  FAddrGenerator := TAddrGenerator.Create(FuncLevel, agmNegative);
  FInternalParams := TSymbolTable.Create(nil, FAddrGenerator);
  FParams := TSymbolTable.Create(FInternalParams, FAddrGenerator);
  FSize := 1;
end;

destructor TFuncSymbol.Destroy;
begin
  FParams.Free;
  FInternalParams.Free;
  FAddrGenerator.Free;
  inherited;
end;

constructor TFuncSymbol.Generate(Table: TSymbolTable; FuncName: string;
  FuncParams: TParamList; FuncType: string);
var
  typSym: TSymbol;
begin
  if FuncType <> '' then
  begin
    Self.Create(FuncName, fkFunction, 1);
    // Set function type
    typSym := Table.FindSymbol(FuncType);
    if not (Assigned(typSym) and (typSym.BaseType <> nil)) then
      raise Exception.CreateFmt(CPE_TypeIsUnknown, [FuncType]);
    Self.SetType(typSym);
  end
  else
    Self.Create(FuncName, fkProcedure, 1);

  GenerateParams(Table, FuncParams);
end;

procedure TFuncSymbol.AddParam(param: TParamSymbol);
begin
  Params.AddSymbol(param);
end;

procedure TFuncSymbol.SetType;
begin
  FTyp := Value;
  FResult := TDataSymbol.Create(SYS_RESULT, Value);
  FInternalParams.AddSymbol(FResult);
end;

type TAddParamProc = procedure (param: TParamSymbol) of object;

procedure GenerateParams(const Name: String; Table: TSymbolTable; FuncParams: TParamList; AddProc: TAddParamProc);
var
  x: Integer;
  typSym: TSymbol;
  paramSym: TParamSymbol;
begin
  for x := 0 to Length(FuncParams) - 1 do
  begin
    typSym := Table.FindSymbol(FuncParams[x].ParamType);
    if not Assigned(typSym) then
      raise Exception.CreateFmt(CPE_TypeForParamNotFound, [FuncParams[x].ParamType,
        FuncParams[x].ParamName, Name]);

    if FuncParams[x].IsVarParam then
      paramSym := TVarParamSymbol.Create(FuncParams[x].ParamName, typSym, FuncParams[x].IsWritable)
    else
      paramSym := TParamSymbol.Create(FuncParams[x].ParamName, typSym);

    if FuncParams[x].HasDefaultValue then
      paramSym.SetDefaultValue(FuncParams[x].DefaultValue,0);

    AddProc(paramSym);
  end;
end;

procedure TFuncSymbol.GenerateParams(Table: TSymbolTable; FuncParams: TParamList);
begin
  dws2Symbols.GenerateParams(Name,Table,FuncParams,AddParam);
end;

function TFuncSymbol.GetCaption: string;
var
  i: Integer;
  nam : String;
begin
  if Name <> '' then
    nam := Name
  else
    case Kind of
      fkFunction    : nam := 'function ';
      fkProcedure   : nam := 'procedure ';
      fkConstructor : nam := 'constructor ';
      fkDestructor  : nam := 'destructor ';
    end;

  if Params.Count > 0 then
  begin
    Result := Params[0].Typ.Caption;
    for i := 1 to Params.Count - 1 do
      Result := Result + ', ' + Params[i].Typ.Caption;
    Result := '(' + Result + ')';
  end
  else
    Result := '';

  if Typ <> nil then
    Result := nam + Result + ': ' + Typ.Name
  else
    Result := nam + Result;
end;

function TFuncSymbol.GetDescription: string;
var
  i: Integer;
begin
  if Params.Count > 0 then
  begin
    Result := Params.Symbols[0].Description;
    for i := 1 to Params.Count - 1 do
      Result := Result + '; ' + Params.Symbols[i].Description;
    Result := '(' + Result + ')';
  end
  else
    Result := '';
  case FKind of
    fkFunction:
      begin
        if Typ <> nil then
          Result := 'function ' + Name + Result + ': ' + Typ.Name
        else
          Result := 'function ' + Name + Result + ': ???';
      end;
    fkProcedure: Result := 'procedure ' + Name + Result;
    fkConstructor: Result := 'constructor ' + Name + Result;
    fkDestructor: Result := 'destructor ' + Name + Result;
  else
    Assert(False)
  end;
end;

procedure TFuncSymbol.Initialize;
begin
  inherited;
  FInternalParams.Initialize;
  if Assigned(FExecutable) then
    FExecutable.Initialize
  else if Level >= 0 then
    raise Exception.CreateFmt(CPE_ForwardNotImplemented, [Name]);
end;

function TFuncSymbol.Optimize(FuncExpr: TExprBase): TExprBase;
begin
  if Assigned(FExecutable) then
    Result := FExecutable.Optimize(FuncExpr)
  else
    Result := FuncExpr;
end;

function TFuncSymbol.GetLevel: Integer;
begin
  Result := FAddrGenerator.Level;
end;

function TFuncSymbol.GetParamSize: Integer;
begin
  Result := FAddrGenerator.DataSize;
end;

function TFuncSymbol.IsCompatible(typSym: TSymbol): Boolean;
var funcSym : TFuncSymbol;
begin
  typSym := typSym.BaseType;
  if typSym is TNilSymbol then
    Result := True
  else if Size <> typSym.Size then
    Result := False
  else begin
    Result := False;
    if not (typSym is TFuncSymbol) then
      Exit;
    funcSym := TFuncSymbol(typSym);
    if (Kind <> funcSym.Kind) or (Params.Count <> funcSym.Params.Count) then
      Exit;
    // TODO : Compare Params
    Result := True;
  end;
end;

procedure TFuncSymbol.InitData(Dat: TData; Offset: Integer);
const
  nilIntf: IUnknown = nil;
begin
  Dat[Offset] := nilIntf;
end;

{ TMethodSymbol }

constructor TMethodSymbol.Create(Name: string; FuncKind: TFuncKind;