dws2comp.pas

script language

{**********************************************************************}
{                                                                      }
{    "The contents of this file are subject to the Mozilla Public      }
{    License Version 1.1 (the "License"); you may not use this         }
{    file except in compliance with the License. You may obtain        }
{    a copy of the License at                                          }
{                                                                      }
{    http://www.mozilla.org/MPL/                                       }
{                                                                      }
{    Software distributed under the License is distributed on an       }
{    "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express       }
{    or implied. See the License for the specific language             }
{    governing rights and limitations under the License.               }
{                                                                      }
{    The Original Code is DelphiWebScriptII source code, released      }
{    January 1, 2001                                                   }
{                                                                      }
{    The Initial Developer of the Original Code is Matthias            }
{    Ackermann. Portions created by Matthias Ackermann are             }
{    Copyright (C) 2000 Matthias Ackermann, Switzerland. All           }
{    Rights Reserved.                                                  }
{                                                                      }
{    Contributor(s): Willibald Krenn, Eric Grange, Andreas Luleich     }
{                                                                      }
{**********************************************************************}

{$I dws2.inc}

unit dws2Comp;

interface

uses
{$IFDEF NEWVARIANTS}
  Variants,
{$ENDIF}
  Classes, SysUtils, dws2Compiler, dws2Debugger,
  dws2Exprs, dws2Symbols, dws2Stack, dws2Functions,
  // Built-In functions
{$IFNDEF DWS_NO_BUILTIN_FUNCTIONS}
  dws2MathFunctions, dws2StringFunctions, dws2TimeFunctions, dws2VariantFunctions,
{$ENDIF}
  dws2Errors;

type
  TDelphiWebScriptII = class;

  Tdws2EmptyUnit = class(TComponent, IUnknown, IUnit)
  private
    function GetUnitName: string;
    function GetDependencies: TStrings;
    function GetUnitTable(SystemTable, UnitSyms: TSymbolTable): TSymbolTable;
  protected
    FUnitName: string;
    FDependencies: TStrings;
    procedure AddUnitSymbols(SymbolTable: TSymbolTable); virtual; abstract;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  Tdws2UnitComponent = class(Tdws2EmptyUnit)
  private
    FScript: TDelphiWebScriptII;
    procedure SetScript(const Value: TDelphiWebScriptII);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  published
    property Script: TDelphiWebScriptII read FScript write SetScript;
  end;

  TDelphiWebScriptII = class(Tdws2EmptyUnit)
  private
    FCompiler: Tdws2Compiler;
    FConfig: TConfiguration;
  protected
    function GetOnInclude: TIncludeEvent;
    function GetVersion: string;
    procedure SetConfig(const Value: TConfiguration);
    procedure SetOnInclude(const Value: TIncludeEvent);
    procedure SetVersion(const Value: string);
    procedure AddUnitSymbols(SymbolTable: TSymbolTable); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddUnit(Un: IUnit);
    function Compile(const Text: string): TProgram; virtual;
    function RemoveUnit(Un: IUnit): Boolean;
  published
    property Config: TConfiguration read FConfig write SetConfig stored True;
    property OnInclude: TIncludeEvent read GetOnInclude write SetOnInclude;
    property Version: string read GetVersion write SetVersion stored False;
  end;

  Tdws2AbstractUnit = class(TComponent, IUnknown, IUnit)
  private
    FDependencies: TStrings;
    FScript: TDelphiWebScriptII;
    FUnitName: string;
    function GetDependencies: TStrings;
    procedure SetDependencies(const Value: TStrings);
    procedure SetScript(const Value: TDelphiWebScriptII);
    procedure SetUnitName(const Value: string);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetUnitName: string; virtual;
    function GetUnitTable(SystemTable, UnitSyms: TSymbolTable): TSymbolTable; virtual; abstract;
    property Dependencies: TStrings read FDependencies write SetDependencies;
    property UnitName: string read GetUnitName write SetUnitName;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Script: TDelphiWebScriptII read FScript write SetScript;
  end;

  TDataType = string;
  Tdws2Unit = class;

  Tdws2Symbol = class(TCollectionItem)
  private
    FIsGenerating: Boolean;
    FUnit: Tdws2Unit;
    FName: string;
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure CheckName(Table: TSymbolTable; Name: string);
    function GetDataType(Table: TSymbolTable; Name: string): TTypeSymbol;
    procedure Reset;
    property IsGenerating: Boolean read FIsGenerating;
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    function Generate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol; virtual; abstract;
    function GetNamePath: string; override;
    function GetUnit: Tdws2Unit;
  published
    property Name: string read FName write FName;
  end;

  Tdws2SymbolClass = class of Tdws2Symbol;

  Tdws2Collection = class(TOwnedCollection)
  private
    FUnit: Tdws2Unit;
  protected
    class function GetSymbolClass : Tdws2SymbolClass; virtual;
    function GetSymbols(const Name: String): Tdws2Symbol;
    function GetItem(Index: Integer): Tdws2Symbol;
    procedure SetItem(Index: Integer; Value: Tdws2Symbol);
    procedure Reset;
  public
    constructor Create(AOwner: TPersistent);
    function GetOwner: TPersistent; override;
    function GetUnit: Tdws2Unit;
    property Symbols[const Name: String]: Tdws2Symbol read GetSymbols;
    property Items[Index: Integer]: Tdws2Symbol read GetItem write SetItem;
  end;

  Tdws2Variable = class(Tdws2Symbol)
  private
    FDataType: TDataType;
  protected
    function GetDisplayName: string; override;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property DataType: TDataType read FDataType write FDataType;
  end;

  Tdws2Variables = class(Tdws2Collection)
  protected
    class function GetSymbolClass : Tdws2SymbolClass; override;
    function GetDisplayName: string;
  end;

  Tdws2VariablesClass = class of Tdws2Variables;

  Tdws2Parameter = class(Tdws2Variable)
  private
    FIsVarParam: Boolean;
    FIsWritable: Boolean;
    FDefaultValue: Variant;
    FHasDefaultValue: Boolean;
    procedure SetIsVarParam(const Value: Boolean);
    procedure SetHasDefaultValue(const Value: Boolean);
    procedure SetIsWritable(const Value: Boolean);
  protected
    procedure SetDefaultValue(const Value: Variant);
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
  published
    property IsVarParam: Boolean read FIsVarParam write SetIsVarParam default False;
    property IsWritable: Boolean read FIsWritable write SetIsWritable default True;
    property HasDefaultValue: Boolean read FHasDefaultValue write SetHasDefaultValue default False;
    property DefaultValue: Variant read FDefaultValue write SetDefaultValue;
  end;

  Tdws2Parameters = class(Tdws2Variables)
  protected
    class function GetSymbolClass : Tdws2SymbolClass; override;
  end;

  Tdws2Function = class;

  TFuncEvalEvent = procedure(Info: TProgramInfo) of object;
  TInitializeEvent = procedure(Sender: TObject) of object;
  TOptimizeEvent = function(Sender: TObject; FuncExpr: TExprBase): TExprBase of object;

  Tdws2Function = class(Tdws2Symbol, IUnknown, ICallable)
  private
    FOnEval: TFuncEvalEvent;
    FFuncType: TDataType;
    FParameters: Tdws2Parameters;
    FOnInitialize: TInitializeEvent;
    FOnOptimize: TOptimizeEvent;
  protected
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  protected
    function GetDisplayName: string; override;
    procedure Call(Caller: TProgram; Func: TFuncSymbol); virtual;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
    function GetParameters(Table: TSymbolTable): TParamList;
    procedure Initialize;
    function Optimize(FuncExpr: TExprBase): TExprBase;
  published
    property Parameters: Tdws2Parameters read FParameters write FParameters;
    property ResultType: TDataType read FFuncType write FFuncType;
    property OnEval: TFuncEvalEvent read FOnEval write FOnEval;
    property OnInitialize: TInitializeEvent read FOnInitialize write FOnInitialize;
    property OnOptimize: TOptimizeEvent read FOnOptimize write FOnOptimize;
  end;

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

  Tdws2FunctionsClass = class of Tdws2Functions;

  Tdws2Array = class(Tdws2Symbol)
  private
    FDataType: TDataType;
    FLowBound: Integer;
    FHighBound: Integer;
  protected
    procedure SetIsDynamic(const Value: Boolean);
    function GetIsDynamic: Boolean;
    function GetDisplayName: string; override;
    function GetBoundStored: Boolean;
  public
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
    procedure Assign(Source: TPersistent); override;
  published
    property DataType: TDataType read FDataType write FDataType;
    property LowBound: Integer read FLowBound write FLowBound stored GetBoundStored;
    property HighBound: Integer read FHighBound write FHighBound stored GetBoundStored;
    property IsDynamic: Boolean read GetIsDynamic write SetIsDynamic default False;
  end;

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

  Tdws2ArraysClass = class of Tdws2Arrays;

  Tdws2Constant = class(Tdws2Variable)
  protected
    FValue: Variant;
    function GetDisplayName: string; override;
  public
    procedure Assign(Source: TPersistent); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
  published
    property Value: Variant read FValue write FValue;
  end;

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

  Tdws2ConstantsClass = class of Tdws2Constants;

  Tdws2Forward = class(Tdws2Symbol)
  protected
    function GetDisplayName: string; override;
  public
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
  end;

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

  Tdws2ForwardsClass = class of Tdws2Forwards;

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

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

  Tdws2Property = class(Tdws2Symbol)
  private
    FDataType: TDataType;
    FReadAccess: string;
    FWriteAccess: string;
    FParameters: Tdws2Parameters;
    FIsDefault: Boolean;
    FIndexType: TDataType;
    FIndexValue: Variant;
  protected
    function GetDisplayName: string; override;
    function GetIsDefault: Boolean;
    procedure SetIsDefault(Value: Boolean);
    procedure SetParameters(const Value: Tdws2Parameters);
  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 DataType: TDataType read FDataType write FDataType;
    property ReadAccess: string read FReadAccess write FReadAccess;
    property WriteAccess: string read FWriteAccess write FWriteAccess;
    property Parameters: Tdws2Parameters read FParameters write SetParameters;
    property IsDefault: Boolean read GetIsDefault write SetIsDefault;
    property IndexType: TDataType read FIndexType write FIndexType;
    property IndexValue: Variant read FIndexValue write FIndexValue;
  end;

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


  TAssignExternalObjectEvent = procedure(Info: TProgramInfo; var ExtObject: TObject) of object;
  TMethodEvalEvent = procedure(Info: TProgramInfo; ExtObject: TObject) of object;

  Tdws2Method = class(Tdws2Function)
  private
    FAttributes: TMethodAttributes;
    FKind: TMethodKind;
    FOnEval: TMethodEvalEvent;
    FResultType: TDataType;
    procedure SetResultType(const Value: TDataType);
  protected
    function GetDisplayName: string; override;
    procedure Call(Caller: TProgram; Func: TFuncSymbol); override;
  public
    procedure Assign(Source: TPersistent); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol; override;
  published
    property Attributes: TMethodAttributes read FAttributes write FAttributes default [];
    property Kind: TMethodKind read FKind write FKind;
    property OnEval: TMethodEvalEvent read FOnEval write FOnEval;
    property ResultType: TDataType read FResultType write SetResultType;
  end;

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

  Tdws2Constructor = class(Tdws2Function)
  private
    FAttributes: TMethodAttributes;
    FOnAssignExternalObject: TAssignExternalObjectEvent;
    FOnEval: TMethodEvalEvent;
    function GetResultType: string;
  protected
    function GetDisplayName: string; override;
    procedure Call(Caller: TProgram; Func: TFuncSymbol); override;
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    function DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil): TSymbol;
      override;
  published
    property Attributes: TMethodAttributes read FAttributes write FAttributes default [];
    property OnAssignExternalObject: TAssignExternalObjectEvent read FOnAssignExternalObject write FOnAssignExternalObject;
    property OnEval: TMethodEvalEvent read FOnEval write FOnEval;
    property ResultType: string read GetResultType;
  end;

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

  Tdws2Class = class(Tdws2Symbol)
  private
    FAncestor: string;
    FConstructors: Tdws2Constructors;
    FFields: Tdws2Fields;
    FMethods: Tdws2Methods;
    FOnObjectDestroy: TObjectDestroyEvent;
    FProperties: Tdws2Properties;
  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 Ancestor: string read FAncestor write FAncestor;
    property Constructors: Tdws2Constructors read FConstructors write FConstructors;
    property Fields: Tdws2Fields read FFields write FFields;
    property Methods: Tdws2Methods read FMethods write FMethods;
    property OnObjectDestroy: TObjectDestroyEvent read FOnObjectDestroy write FOnObjectDestroy;
    property Properties: Tdws2Properties read FProperties write FProperties;
  end;

  Tdws2Classes = class(Tdws2Collection)
  protected