dws2comp.pas

script language

    class function GetSymbolClass : Tdws2SymbolClass; override;
  end;

  Tdws2ClassesClass = class of Tdws2Classes;

  Tdws2Member = class(Tdws2Variable)
  public
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
  end;

  Tdws2Members = class(Tdws2Collection)
  protected
    class function GetSymbolClass : Tdws2SymbolClass; override;
  end;

  Tdws2Record = class(Tdws2Symbol)
  private
    FMembers: Tdws2Members;
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
  published
    property Members: Tdws2Members read FMembers write FMembers;
  end;

  Tdws2Records = class(Tdws2Collection)
  protected
    class function GetSymbolClass: Tdws2SymbolClass; override;
  end;

  Tdws2RecordsClass = class of Tdws2Records;

  Tdws2Element = class(Tdws2Symbol)
  private
    FIsUserDef: Boolean;
    FUserDefValue: Integer;
    procedure SetUserDefValue(const Value: Integer);
    procedure SetIsUserDef(const Value: Boolean);
  protected
    function GetDisplayName: string; override;
  public
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol; override;
  published
    property UserDefValue: Integer read FUserDefValue write SetUserDefValue;
    property IsUserDef: Boolean read FIsUserDef write SetIsUserDef;
  end;

  Tdws2Elements = class(Tdws2Collection)
  protected
    class function GetSymbolClass : Tdws2SymbolClass; override;
  end;

  Tdws2Enumeration = class(Tdws2Symbol)
  private
    FElements: Tdws2Elements;
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol; override;
  published
    property Elements: Tdws2Elements read FElements write FElements;
  end;

  Tdws2Enumerations = class(Tdws2Collection)
  protected
    class function GetSymbolClass: Tdws2SymbolClass; override;
  end;

  Tdws2EnumerationsClass = class of Tdws2Enumerations;

  TReadVarEvent = procedure(var Value: Variant) of object;
  TWriteVarEvent = procedure(Value: Variant) of object;
  TInstantiateEvent = procedure(var ExtObject: TObject) of object;

  Tdws2Global = class(Tdws2Variable)
  private
    FOnReadVar: TReadVarEvent;
    FOnWriteVar: TWriteVarEvent;
  public
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol; override;
    procedure Assign(Source: TPersistent); override;
  published
    property OnReadVar: TReadVarEvent read FOnReadVar write FOnReadVar;
    property OnWriteVar: TWriteVarEvent read FOnWriteVar write FOnWriteVar;
  end;

  Tdws2Instances = class(Tdws2Collection)
  protected
    class function GetSymbolClass : Tdws2SymbolClass; override;
  end;

  Tdws2InstancesClass = class of Tdws2Instances;

  Tdws2CustomInstance = class(Tdws2Variable)
  private
    FOnObjectDestroy: TObjectDestroyEvent;
    FOnInstantiate: TInstantiateEvent;
    FAutoDestroyExternalObject: Boolean;
    FOnInitialize: TInitializeEvent;
    FOnOptimize: TOptimizeEvent;
  protected
    procedure DoDestroy(ExternalObject: TObject); virtual;
    procedure DoInstantiate(var ExternalObject: TObject); virtual;
    function DoOptimize(Sender: TObject; FuncExpr: TExprBase): TExprBase; virtual;
    procedure DoInitialize(Sender: TObject); virtual;
  public
    constructor Create(Collection: TCollection); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
    procedure Assign(Source: TPersistent); override;
    property AutoDestroyExternalObject: Boolean read FAutoDestroyExternalObject
      write FAutoDestroyExternalObject default False;
    property OnObjectDestroy: TObjectDestroyEvent read FOnObjectDestroy write
      FOnObjectDestroy;
    property OnInstantiate: TInstantiateEvent read FOnInstantiate write
      FOnInstantiate;
    property OnInitialize: TInitializeEvent read FOnInitialize write FOnInitialize;
    property OnOptimize: TOptimizeEvent read FOnOptimize write FOnOptimize;
  end;

  Tdws2Instance = class(Tdws2CustomInstance)
  published
    property AutoDestroyExternalObject;
    property OnObjectDestroy;
    property OnInstantiate;
    property OnInitialize;
    property OnOptimize;
  end;

  Tdws2Synonyms = class(Tdws2Collection)
  protected
    class function GetSymbolClass : Tdws2SymbolClass; override;
  end;

  Tdws2SynonymsClass = class of Tdws2Synonyms;

  Tdws2Synonym = class(Tdws2Variable)
  public
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
  end;

  TSymbolTableType = (sttDefault, sttStatic, sttLinked);

  Tdws2Unit = class(Tdws2AbstractUnit)
  private
    FArrays: Tdws2Arrays;
    FClasses: Tdws2Classes;
    FConstants: Tdws2Constants;
    FEnumerations: Tdws2Enumerations;
    FForwards: Tdws2Forwards;
    FFunctions: Tdws2Functions;
    FInstances: Tdws2Instances;
    FRecords: Tdws2Records;
    FSynonyms: Tdws2Synonyms;
    FVariables: Tdws2Variables;
    FCollections: array[0..9] of Tdws2Collection;
    FTable: TSymbolTable;
    FStaticSymbols: Boolean;
    FStaticTable: TStaticSymbolTable; // static symbols
  protected
    class function GetArraysClass: Tdws2ArraysClass; virtual;
    class function GetClassesClass: Tdws2ClassesClass; virtual;
    class function GetConstantsClass: Tdws2ConstantsClass; virtual;
    class function GetEnumerationsClass: Tdws2EnumerationsClass; virtual;
    class function GetForwardsClass: Tdws2ForwardsClass; virtual;
    class function GetFunctionsClass: Tdws2FunctionsClass; virtual;
    class function GetInstancesClass: Tdws2InstancesClass; virtual;
    class function GetRecordsClass: Tdws2RecordsClass; virtual;
    class function GetVariablesClass: Tdws2VariablesClass; virtual;
    class function GetSynonymsClass: Tdws2SynonymsClass; virtual;
    procedure SetArrays(const Value: Tdws2Arrays);
    procedure SetClasses(const Value: Tdws2Classes);
    procedure SetConstants(const Value: Tdws2Constants);
    procedure SetEnumerations(const Value: Tdws2Enumerations);
    procedure SetForwards(const Value: Tdws2Forwards);
    procedure SetFunctions(const Value: Tdws2Functions);
    procedure SetRecords(const Value: Tdws2Records);
    procedure SetVariables(const Value: Tdws2Variables);
    procedure SetInstances(const Value: Tdws2Instances);
    procedure SetSynonyms(const Value: Tdws2Synonyms);
  protected
    function GetSymbol(Table: TSymbolTable; const Name: string): TSymbol;
    procedure AddCollectionSymbols(Collection: Tdws2Collection; Table: TSymbolTable); virtual;
    procedure AddUnitSymbols(Table: TSymbolTable); virtual;
    procedure SetStaticSymbols(const Value: Boolean);
    procedure InitUnitTable(SystemTable, UnitSyms, UnitTable: TSymbolTable);
    function GetUnitTable(SystemTable, UnitSyms: TSymbolTable): TSymbolTable;
      override;
    function CreateUnitTable(Parent: TSymbolTable;
      Typ: TSymbolTableType = sttDefault): TSymbolTable; virtual;
  public
    procedure GetDataTypes(List: TStrings);
    procedure GetClassTypes(List: TStrings);
    function InitStaticSymbols(SystemTable: TSymbolTable; UnitSyms: TSymbolTable): Boolean;
    procedure ReleaseStaticSymbols;
    property Table: TSymbolTable read FTable;
    property StaticTable: TStaticSymbolTable read FStaticTable;
  published
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Arrays: Tdws2Arrays read FArrays write SetArrays;
    property Classes: Tdws2Classes read FClasses write SetClasses;
    property Constants: Tdws2Constants read FConstants write SetConstants;
    property Dependencies;
    property Enumerations: Tdws2Enumerations read FEnumerations write SetEnumerations;
    property Forwards: Tdws2Forwards read FForwards write SetForwards;
    property Functions: Tdws2Functions read FFunctions write SetFunctions;
    property Instances: Tdws2Instances read FInstances write SetInstances;
    property Records: Tdws2Records read FRecords write SetRecords;
    property Synonyms: Tdws2Synonyms read FSynonyms write SetSynonyms;
    property UnitName;
    property Variables: Tdws2Variables read FVariables write SetVariables;
    property StaticSymbols: Boolean read FStaticSymbols write SetStaticSymbols default False;
  end;

  TInstantiateFunc = class(TAnonymousFunction, IObjectOwner)
  private
    FClassSym: TClassSymbol;
    FOnInstantiate: TInstantiateEvent;
    FOnObjectDestroy: TObjectDestroyEvent;
    FOnInitialize: TInitializeEvent;
    FOnOptimize: TOptimizeEvent;
    FScriptObj: IScriptObj;
  public
    procedure Execute; override;
    procedure Initialize; override;
    function Optimize(FuncExpr: TExprBase): TExprBase; override;
    procedure ReleaseObject;
    property ClassSym: TClassSymbol read FClassSym write FClassSym;
    property OnInstantiate: TInstantiateEvent read FOnInstantiate write FOnInstantiate;
    property OnObjectDestroy: TObjectDestroyEvent read FOnObjectDestroy write FOnObjectDestroy;
    property OnInitialize: TInitializeEvent read FOnInitialize write FOnInitialize;
    property OnOptimize: TOptimizeEvent read FOnOptimize write FOnOptimize;
  end;

  TReadVarEventFunc = class(TAnonymousFunction)
  private
    FOnReadVar: TReadVarEvent;
  public
    procedure Execute; override;
    property OnReadVar: TReadVarEvent read FOnReadVar write FOnReadVar;
  end;

  TWriteVarEventFunc = class(TAnonymousFunction)
  private
    FOnWriteVar: TWriteVarEvent;
  public
    procedure Execute; override;
    property OnWriteVar: TWriteVarEvent read FOnWriteVar write FOnWriteVar;
  end;

  TReadVarFunc = class(TAnonymousFunction)
  private
    FData: TData;
    FTyp: TSymbol;
  public
    constructor Create(FuncSym: TFuncSymbol);
    procedure Execute; override;
    procedure SetValue(const Data: TData);
  end;

  TWriteVarFunc = class(TAnonymousFunction)
  private
    FReadVarFunc: TReadVarFunc;
  public
    constructor Create(FuncSym: TFuncSymbol; ReadVarFunc: TReadVarFunc);
    procedure Execute; override;
  end;

// Return the external object for a variable name.
function GetExternalObjForID(Info: TProgramInfo; const AVarName: string): TObject;

// Get or create the DWS object ID (like a pointer) for a Delphi object instance.
//function GetOrCreateObjectID(Info: TProgramInfo; AObject: TObject; AClassName: string = ''): Integer;

function GetParameters(Symbol: Tdws2Symbol;
  Parameters: Tdws2Parameters; Table: TSymbolTable): TParamList;

implementation

uses
  dws2Strings, dws2CompStrings;

type
  EGenerationError = class(Exception);
  EHandledGenerationError = class(Exception);

function ValueToString(const Value : Variant) : String;
begin
  case VarType(Value) of
    varEmpty : result := 'Unassigned';
    varNull : result := 'Null';
    varString,varOleStr,varStrArg : result := Format('''%s''',[VarToStr(Value)]);
    varDate : result := Format('DateTime(%f)',[TVarData(Value).VDate]);
  else
    result := VarToStr(Value);
  end;
end;

function GetExternalObjForID(Info: TProgramInfo; const AVarName: string): TObject;
begin
  // Get param "Source" as object in Source_Obj
  Result := IScriptObj(IUnknown(Info[AVarName])).ExternalObject;
end;

//function GetOrCreateObjectID(Info: TProgramInfo; AObject: TObject; AClassName: string): Integer;
//var
//  ScriptObj: TScriptObj;
//begin
//  if Assigned(AObject) then                // if object was returned
//  begin
//    if AClassName = '' then
//      AClassName := AObject.ClassName;
//
//    // Find the Delphi object and return the Id
//    ScriptObj := Info.Caller.FindExternalObject(AObject);
//    if Assigned(ScriptObj) then            // if object found
//      Result := ScriptObj.Id               // return the object's Id
//    else                                   // if not found, register the object and return the Id
//      Result := Info.Vars[AClassName].GetConstructor('Create', AObject).Call.Value;
//  end
//  else                                     // no object returned
//    Result := 0;                           // return 'nil' Id
//end;

{ TDelphiWebScriptII }

constructor TDelphiWebScriptII.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FUnitName := 'Default';
  FCompiler := Tdws2Compiler.Create;
  FConfig := TConfiguration.Create(Self);
  AddUnit(Self);
end;

destructor TDelphiWebScriptII.Destroy;
begin
  inherited;
  FCompiler.Free;
  FConfig.Free;
end;

function TDelphiWebScriptII.GetVersion: string;
begin
  Result := '2.0.beta.0';
end;

function TDelphiWebScriptII.Compile(const Text: string): TProgram;
begin
  Result := FCompiler.Compile(Text, FConfig);
end;

procedure TDelphiWebScriptII.SetVersion(const Value: string);
begin
  // This method is needed to make the IDE show the version in
  // the object inspector
end;

procedure TDelphiWebScriptII.AddUnit(Un: IUnit);
begin
  RemoveUnit(Un);
  if Assigned(Un) then
    FConfig.Units.AddObject(Un.GetUnitName, Pointer(Un));
end;

function TDelphiWebScriptII.RemoveUnit(Un: IUnit): Boolean;
var
  x: Integer;
begin
  x := FConfig.Units.IndexOfObject(Pointer(Un));
  if x >= 0 then
    FConfig.Units.Delete(x);
  Result := x >= 0;
end;

procedure TDelphiWebScriptII.SetConfig(const Value: TConfiguration);
begin
  FConfig.Assign(Value);
end;

// Implementation of Tdws2EmptyUnit.AddUnitSymbols
procedure TDelphiWebScriptII.AddUnitSymbols(SymbolTable: TSymbolTable);
begin
  // The TDelphiWebScriptII component is the unit "Default"
  Config.ResultType.AddResultSymbols(SymbolTable);
end;

procedure TDelphiWebScriptII.SetOnInclude(const Value: TIncludeEvent);
begin
  Config.OnInclude := Value;
end;

function TDelphiWebScriptII.GetOnInclude: TIncludeEvent;
begin
  Result := Config.OnInclude;
end;

procedure TDelphiWebScriptII.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then
  begin
    if AComponent = FConfig.Filter then
      Config.Filter := nil
    else if AComponent = Config.ResultType then
      Config.ResultType := nil
    else if AComponent is Tdws2UnitComponent then
      Self.RemoveUnit(Tdws2UnitComponent(AComponent))
    else if AComponent is Tdws2AbstractUnit then
      Self.RemoveUnit(Tdws2AbstractUnit(AComponent));
  end;
end;

{ Tdws2Collection }

constructor Tdws2Collection.Create;
begin
  inherited Create(AOwner, GetSymbolClass);
  if AOwner is Tdws2Unit then
    FUnit := Tdws2Unit(AOwner)
  else if AOwner is Tdws2Symbol then
    FUnit := Tdws2Symbol(AOwner).GetUnit
  else
    FUnit := nil;
end;

function Tdws2Collection.GetOwner: TPersistent;
begin
  Result := inherited GetOwner;