dws2exprs.pas

script language

  TOrExpr = class(TNumberBooleanOpExpr)
    function Eval: Variant; override;
  end;

  // a xor b
  TXorExpr = class(TNumberBooleanOpExpr)
    function Eval: Variant; override;
  end;

  // Float(x)
  TConvFloatExpr = class(TUnaryOpExpr)
    constructor Create(Prog: TProgram; Pos: TScriptPos; Expr: TExpr);
    function Eval: Variant; override;
    function Optimize: TExpr; override;
  end;

  // TDateTime(x)
  TConvDateTimeExpr = class(TUnaryOpExpr)
    constructor Create(Prog: TProgram; Pos: TScriptPos; Expr: TExpr);
    function Eval: Variant; override;
    function Optimize: TExpr; override;
  end;

  // Integer(enum)
  TConvIntegerExpr = class(TUnaryOpExpr)
    constructor Create(Prog: TProgram; Pos: TScriptPos; Expr: TExpr);
    function Eval: Variant; override;
    function Optimize: TExpr; override;
  end;

  // A list of expressions
  TExprList = class(TList)
  protected
    function GetExpr(const x: Integer): TExpr;
    procedure SetExpr(const x: Integer; const Value: TExpr);
  public
    destructor Destroy; override;
    procedure AddExpr(AExpr: TExpr);
    procedure Initialize;
    procedure Optimize(Shrink: Boolean = True);
    property Expr[const x: Integer]: TExpr read GetExpr write SetExpr; default;
  end;

  // Helper object for access to symbols
  IInfo = interface
    ['{8D534D16-4C6B-11D5-8DCB-0000216D9E86}']
    function Call: IInfo; overload;
    function Call(const Params: array of Variant): IInfo; overload;
    function Element(const Indices: array of Integer): IInfo;
    function GetConstructor(MethName: string; ExtObject: TObject): IInfo;
    function GetData: TData;
    function GetExternalObject: TObject;
    function GetMember(s: string): IInfo;
    function GetMethod(s: string): IInfo;
    function GetScriptObj: IScriptObj;
    function GetParameter(s: string): IInfo;
    function GetTypeSym: TSymbol;
    function GetValue: Variant;
    procedure SetData(const Data: TData);
    procedure SetExternalObject(ExtObject: TObject);
    procedure SetValue(const Value: Variant);
    property Data: TData read GetData write SetData;
    property ExternalObject: TObject read GetExternalObject write
      SetExternalObject;
    property Member[s: string]: IInfo read GetMember;
    property Method[s: string]: IInfo read GetMethod;
    property ScriptObj: IScriptObj read GetScriptObj;
    property Parameter[s: string]: IInfo read GetParameter;
    property TypeSym: TSymbol read GetTypeSym;
    property Value: Variant read GetValue write SetValue;
  end;

  // Informations about the program in external procedures
  TProgramInfo = class
  private
    FCaller: TProgram;
    FFuncSym: TFuncSymbol;
    FLevel: Integer;
    FScriptObj: IScriptObj;
    FTable: TSymbolTable;
    function GetData(s: string): TData;
    function GetFunc(s: string): IInfo;
    procedure SetFuncSym(const Value: TFuncSymbol);
    function GetValue(s: string): Variant;
    function GetVars(s: string): IInfo;
    procedure SetData(s: string; const Value: TData);
    procedure SetValue(s: string; const Value: Variant);
    procedure SetResult(const Value: Variant);
    function GetResult: Variant;
  public
    constructor Create(Table: TSymbolTable; Caller: TProgram = nil);
    function GetOrCreateObjectID(AObject: TObject): Integer;
    function GetExternalObjForVar(s: string): TObject;
    // cycle ancestry heirarchy and find the nearest matching type
    function FindNearestClassMatch(AObject: TObject): IInfo;
    function GetTemp(DataType: string): IInfo;
    property Caller: TProgram read FCaller write FCaller;
    property Data[s: string]: TData read GetData write SetData;
    property Func[s: string]: IInfo read GetFunc;
    property FuncSym: TFuncSymbol read FFuncSym write SetFuncSym;
    property Method[s: string]: IInfo read GetFunc;
    property ScriptObj: IScriptObj read FScriptObj write FScriptObj;
    property Result: Variant read GetResult write SetResult;
    property Value[s: string]: Variant read GetValue write SetValue; default;
    property Vars[s: string]: IInfo read GetVars;
  end;

  // A instance of a script class FClassSym. Instance data in FData,
  TScriptObj = class(TInterfacedObject, IScriptObj)
  private
    FClassSym: TClassSymbol;
    FData: TData;
    FExternalObj: TObject;
    FProg: TProgram;
    FOnObjectDestroy: TObjectDestroyEvent;
  protected
    { IScriptObj }
    function GetClassSym: TClassSymbol;
    function GetData: TData;
    procedure SetData(Dat: TData);
    function GetExternalObject: TObject;
    procedure SetExternalObject(Value: TObject);
  public
    constructor Create(ClassSym: TClassSymbol; Prog: TProgram = nil);
    destructor Destroy; override;
    procedure BeforeDestruction; override;
    property OnObjectDestroy: TObjectDestroyEvent read FOnObjectDestroy write FOnObjectDestroy;
  end;

  function GetMethodExpr(meth: TMethodSymbol; Expr: TDataExpr; RefKind: TRefKind;
    Pos: TScriptPos; IsInstruction: Boolean; ForceStatic : Boolean = False): TFuncExpr;

  procedure DestroyScriptObject(ScriptObj: IScriptObj);

  function GetDataInfo(Typ: TSymbol) : IInfo;

implementation

uses
{$IFDEF NEWVARIANTS}
  Variants,
{$ENDIF}
  SysUtils, dws2Functions, TypInfo
{$IFDEF WIN32},
  Windows
{$ENDIF};

type
  IDataMaster = interface
    ['{8D534D17-4C6B-11D5-8DCB-0000216D9E86}']
    function GetCaption: string;
    function GetSize: Integer;
    procedure Read(const Data: TData);
    procedure Write(const Data: TData);
    property Caption: string read GetCaption;
    property Size: Integer read GetSize;
  end;

  // private implementation of IInfo
  TInfo = class(TInterfacedObject, IUnknown, IInfo)
  protected
    FCaller: TProgram;
    FChild: IInfo;
    FData: TData;
    FOffset: Integer;
    FProgramInfo: TProgramInfo;
    FDataMaster: IDataMaster;
    FTypeSym: TSymbol;
    function GetData: TData; virtual;
    function GetExternalObject: TObject; virtual;
    function GetMember(s: string): IInfo; virtual;
    function GetMethod(s: string): IInfo; virtual;
    function GetScriptObj: IScriptObj; virtual;
    function GetParameter(s: string): IInfo; virtual;
    function GetTypeSym: TSymbol;
    function GetValue: Variant; virtual;
    procedure SetData(const Value: TData); virtual;
    procedure SetExternalObject(ExtObject: TObject); virtual;
    procedure SetValue(const Value: Variant); virtual;
  public
    constructor Create(ProgramInfo: TProgramInfo; TypeSym: TSymbol; const Data:
      TData; Offset: Integer; DataMaster: IDataMaster = nil);
    function Call: IInfo; overload; virtual;
    function Call(const Params: array of Variant): IInfo; overload; virtual;
    function Element(const Indices: array of Integer): IInfo; virtual;
    function GetConstructor(MethName: string; ExtObject: TObject): IInfo; virtual;
    class function SetChild(ProgramInfo: TProgramInfo; ChildTypeSym: TSymbol;
      ChildData: TData; ChildOffset: Integer; ChildDataMaster: IDataMaster = nil):
      IInfo;
  end;

  TInfoConst = class(TInfo)
  private
    FData: TData;
  public
    constructor Create(ProgramInfo: TProgramInfo; TypeSym: TSymbol; const Value: Variant);
    function GetValue: Variant; override;
    function GetData: TData; override;
  end;

  TInfoData = class(TInfo)
    function GetValue: Variant; override;
    function GetData: TData; override;
    procedure SetData(const Value: TData); override;
    procedure SetValue(const Value: Variant); override;
  end;

  TInfoClass = class(TInfoData)
    FScriptObj: IScriptObj;
    function GetConstructor(MethName: string; ExtObject: TObject): IInfo; override;
    function GetMethod(s: string): IInfo; override;
    function GetScriptObj: IScriptObj; override;
  end;

  TInfoClassObj = class(TInfoClass)
    function GetMember(s: string): IInfo; override;
    constructor Create(ProgramInfo: TProgramInfo; TypeSym: TSymbol; const Data:
      TData; Offset: Integer; DataMaster: IDataMaster = nil);
  end;

  TInfoClassOf = class(TInfoClass)
    constructor Create(ProgramInfo: TProgramInfo; TypeSym: TSymbol; const Data:
      TData; Offset: Integer; DataMaster: IDataMaster = nil);
  end;

  TInfoRecord = class(TInfoData)
    function GetMember(s: string): IInfo; override;
  end;

  TInfoArray = class(TInfoData)
    function Element(const Indices: array of Integer): IInfo; override;
    function GetMember(s: string): IInfo; override;
  end;

  TTempParam = class(TParamSymbol)
  private
    FData: TData;
    FIsVarParam: Boolean;
  public
    constructor Create(ParamSym: TSymbol; ParamSize: Integer);
    property Data: TData read FData;
    property IsVarParam: Boolean read FIsVarParam;
  end;

  TInfoFunc = class(TInfo)
  protected
    FClassSym: TClassSymbol;
    FExternalObject: TObject;
    FScriptObj: IScriptObj;
    FParams: TSymbolTable;
    FParamSize: Integer;
    FResult: TData;
    FTempParams: TSymbolTable;
    FTempParamSize: Integer;
    FUsesTempParams: Boolean;
    procedure InitTempParams;
    function GetParameter(s: string): IInfo; override;
    function GetExternalObject: TObject; override;
    procedure SetExternalObject(ExtObject: TObject); override;
  public
    constructor Create(ProgramInfo: TProgramInfo; TypeSym: TSymbol; const Data:
      TData; Offset: Integer; DataMaster: IDataMaster; ScriptObj: IScriptObj; ClassSym:
      TClassSymbol);
    destructor Destroy; override;
    function Call: IInfo; overload; override;
    function Call(const Params: array of Variant): IInfo; overload; override;
  end;

  TInfoConnector = class(TInfoData)
    function GetMethod(s: string): IInfo; override;
    function GetMember(s: string): IInfo; override;
  end;

  TInfoConnectorCall = class(TInfo)
  protected
    FName: string;
    FConnectorType: IConnectorType;
  public
    constructor Create(ProgramInfo: TProgramInfo; TypeSym: TSymbol; const Data:
      TData; Offset: Integer; ConnectorType: IConnectorType; Name: string);
    function Call(const Params: array of Variant): IInfo; overload; override;
  end;

  TDataMaster = class(TInterfacedObject, IUnknown, IDataMaster)
  private
    FCaller: TProgram;
    FSym: TSymbol;
    function GetCaption: string;
    function GetSize: Integer;
  public
    constructor Create(Caller: TProgram; Sym: TSymbol);
    procedure Read(const Data: TData); virtual;
    procedure Write(const Data: TData); virtual;
  end;

  TExternalVarDataMaster = class(TDataMaster)
  public
    procedure Read(const Data: TData); override;
    procedure Write(const Data: TData); override;
  end;

  TPropertyDataMaster = class(TDataMaster)
  private
    FScriptObj: IScriptObj;
  public
    constructor Create(Caller: TProgram; Sym: TSymbol; ScriptObj: IScriptObj);
    procedure Read(const Data: TData); override;
    procedure Write(const Data: TData); override;
  end;

  TConnectorMemberDataMaster = class(TDataMaster)
  private
    FBaseValue: Variant;
    FName: string;
  public
    constructor Create(Caller: TProgram; Sym: TSymbol; BaseValue: Variant; Name:
      string);
    procedure Read(const Data: TData); override;
    procedure Write(const Data: TData); override;
  end;

  TCleanUpEvent = procedure(ScriptObj: IScriptObj; ExternalObject: TObject) of object;

function GetFuncExpr(Prog: TProgram; FuncSym: TFuncSymbol; ScriptObj: IScriptObj;
  ClassSym: TClassSymbol): TFuncExpr;
begin
  if FuncSym is TMethodSymbol then
  begin
    if Assigned(ScriptObj) then
      Result := GetMethodExpr(
        TMethodSymbol(funcSym),
        TConstExpr.Create(Prog, NullPos, ScriptObj.ClassSym, ScriptObj),
        rkObjRef, NullPos, True)
    else
      Result := GetMethodExpr(
        TMethodSymbol(funcSym),
        TConstExpr.Create(Prog, NullPos, ClassSym.ClassOf, ClassSym.Name),
        rkClassOfRef, NullPos, True)
  end
  else
    Result := TFuncExpr.Create(Prog, NullPos, TFuncSymbol(funcSym), True);
end;

function GetMethodExpr(meth: TMethodSymbol; Expr: TDataExpr; RefKind: TRefKind;
  Pos: TScriptPos; IsInstruction: Boolean; ForceStatic : Boolean): TFuncExpr;
begin
  // Create the correct TExpr for a method symbol
  Result := nil;

  // Return the right expression
  case meth.Kind of
    fkFunction, fkProcedure:
      if meth.IsClassMethod then
      begin
        if not ForceStatic and meth.IsVirtual and (RefKind = rkClassOfRef) then
          if (Expr is TConstExpr) and (VarType(Expr.Eval) = varString) then
            Result := TClassMethodVirtualNameExpr.Create(Expr.Prog, Pos, meth, Expr,
              IsInstruction)
          else
            Result := TClassMethodVirtualExpr.Create(Expr.Prog, Pos, meth, Expr,
              IsInstruction)
        else if not ForceStatic and meth.IsVirtual and (RefKind = rkObjRef) then
          if (Expr is TConstExpr) and (VarType(Expr.Eval) = varString) then
            Result := TClassMethodObjVirtualNameExpr.Create(Expr.Prog, Pos, meth, Expr,
              IsInstruction)
          else
            Result := TClassMethodObjVirtualExpr.Create(Expr.Prog, Pos, meth, Expr,
              IsInstruction)
        else
          Result := TClassMethodStaticExpr.Create(Expr.Prog, Pos, meth, Expr,
            IsInstruction)
      end
      else
      begin
        Assert(RefKind = rkObjRef);
        if not ForceStatic and meth.IsVirtual then
          Result := TMethodVirtualExpr.Create(Expr.Prog, Pos, meth, Expr,
            IsInstruction)
        else
          Result := TMethodStaticExpr.Create(Expr.Prog, Pos, meth, Expr,
            IsInstruction);
      end;
    fkConstructor:
      if RefKind = rkClassOfRef then
      begin
        if not ForceStatic and meth.IsVirtual {and not (Expr is TConstExpr)} then
          Result := TConstructorVirtualExpr.Create(Expr.Prog, Pos, meth, Expr,
            IsInstruction)
        else
          Result := TConstructorStaticExpr.Create(Expr.Prog, Pos, meth, Expr,
            IsInstruction);
      end