dws2exprs.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, Michael Riepp,      }
{                    Andreas Luleich, Mark Ericksen                    }
{                                                                      }
{**********************************************************************}

{$I dws2.inc}

unit dws2Exprs;

interface

uses
  Classes, dws2Symbols, dws2Errors, dws2Strings, dws2Stack;

const
  C_DefaultStackChunkSize = 4096;

type
  TRelOps = (roEqual, roUnEqual, roLess, roLessEqual, roMore, roMoreEqual);

  TRefKind = (rkObjRef, rkClassOfRef);

  TExpr = class;
  TExprList = class;
  TProgram = class;
  TSymbolPositionList = class;

  // Interface for units
  IUnit = interface
    ['{8D534D12-4C6B-11D5-8DCB-0000216D9E86}']
    function GetUnitName: string;
    function GetUnitTable(SystemTable, UnitSyms: TSymbolTable): TSymbolTable;
    function GetDependencies: TStrings;
  end;

  TScriptSourceType = (stMain, stInclude{, stUnit}); // stUnit is left for the future

  // A specific ScriptSource entry. The text of the script contained in that unit.
  TScriptSourceItem = class
  private
    FNameReference: string;
    FSourceFile: TSourceFile;
    FSourceType: TScriptSourceType;
  public
    constructor Create(ANameReference: string; ASourceFile: TSourceFile; ASourceType: TScriptSourceType);
    property NameReference: string read FNameReference write FNameReference;
    property SourceFile: TSourceFile read FSourceFile;
    property SourceType: TScriptSourceType read FSourceType;
  end;

  // Manage a list of all the different Script Texts (files) used in the program.
  TScriptSourceList = class
  private
    FSourceList: TList;
    FMainScript: TScriptSourceItem;
    function GetSourceItem(Index: Integer): TScriptSourceItem;
    procedure SetSourceItem(Index: Integer; SourceItem: TScriptSourceItem);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure Add(ANameReference: string; ASourceFile: TSourceFile; ASourceType: TScriptSourceType);
    function FindScriptSourceItem(ScriptPos: TScriptPos): TScriptSourceItem; overload;
    function FindScriptSourceItem(SourceFile: TSourceFile): TScriptSourceItem; overload;
    function FindScriptSourceItem(SourceFileName: string): TScriptSourceItem; overload;
    function IndexOf(AScriptPos: TScriptPos): Integer; overload;
    function IndexOf(ASourceFile: TSourceFile): Integer; overload;
    function IndexOf(SourceFileName: string): Integer; overload;
    function Count: Integer;
    property Items[Index: Integer]: TScriptSourceItem read GetSourceItem write SetSourceItem; default;
    property MainScript: TScriptSourceItem read FMainScript;
  end;

  { Describe how the symbol at the position is being used. suReference would be
    a typical usage of the symbol. }
  TSymbolUsage = (suForward, suDeclaration, suImplementation, suReference);
  TSymbolUsages = set of TSymbolUsage;

  TSymbolPosition = class
  private
    FOwnerList: TSymbolPositionList; // pointer back to owning list
    FScriptPos: TScriptPos;     // location of symbol instance in script
    FSymUsages: TSymbolUsages;  // how symbol is used at this location (mutiple uses possible, Functions are Delcared/Implemented at same spot)
    function GetSymbol: TSymbol;// get symbol from parent
  public
    constructor Create(AOwningList: TSymbolPositionList; AScriptPos: TScriptPos; AUsages: TSymbolUsages);
    property Symbol: TSymbol read GetSymbol;     // get owner symbol
    property ScriptPos: TScriptPos read FScriptPos;
    property SymbolUsages: TSymbolUsages read FSymUsages write FSymUsages;
  end;

  {Re-list every symbol (pointer to it) and every position it is in in the script }
  TSymbolPositionList = class
  private
    FSymbol: TSymbol;       // pointer to the symbol
    FPosList: TList;        // list of positions where symbol is declared and used
    function GetPosition(Index: Integer): TSymbolPosition;
    procedure SetPosition(Index: Integer; SymPos: TSymbolPosition);
  protected
    // Used by TSymbolDictionary. Not meaningful to make public (symbol is known).
    function FindSymbolAtPosition(AbsolutePos: Integer): TSymbol; overload;
    function FindSymbolAtPosition(ACol, ALine: Integer): TSymbol; overload;
  public
    constructor Create(ASymbol: TSymbol);
    destructor Destroy; override;
    procedure Add(Pos: TScriptPos; UseTypes: TSymbolUsages);
    function FindUsage(UseType: TSymbolUsage): TSymbolPosition;
    function Count: Integer;
    property Items[Index: Integer]: TSymbolPosition read GetPosition write SetPosition; default;
    property Symbol: TSymbol read FSymbol;
  end;

  { List all symbols in the script. Each symbol list contains a list of the
    positions where it was used. }
  TSymbolDictionary = class
  protected
    FSymbolList: TList;
    function GetList(Index: Integer): TSymbolPositionList;
    procedure SetList(Index: Integer; PosList: TSymbolPositionList);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;  // clear the lists
    procedure Add(Sym: TSymbol; Pos: TScriptPos; UseTypes: TSymbolUsages=[suReference]);
    procedure Remove(Sym: TSymbol); // remove references to the symbol
    function FindSymbolAtPosition(AbsolutePos: Integer): TSymbol; overload;
    function FindSymbolAtPosition(ACol, ALine: Integer): TSymbol; overload;
    function FindSymbolPosList(Sym: TSymbol): TSymbolPositionList; overload;  // return list of symbol
    function FindSymbolPosList(SymName: string): TSymbolPositionList; overload;  // return list of symbol
    function FindSymbolPosListOfType(SymName: string; SymbolType: TSymbolClass): TSymbolPositionList; // return list of symbol given the desired type
    function FindSymbolUsage(Symbol: TSymbol; UseType: TSymbolUsage): TSymbolPosition; overload;
    function FindSymbolUsage(SymName: string; UseType: TSymbolUsage): TSymbolPosition; overload;
    function FindSymbolUsageOfType(SymName: string; SymbolType: TSymbolClass; UseType: TSymbolUsage): TSymbolPosition;
    function Count: Integer;
    property Items[Index: Integer]: TSymbolPositionList read GetList write SetList; default;
  end;

  // Context within the script. (A block of code) Can be nested
  TContext = class
  private
    FParentContext: TContext;
    FParentSymbol: TSymbol;     // a parent symbol would be a procedure/method, etc.
    FSubContexts: TList;        // contexts that are inside of this one
    FEndPos: TScriptPos;
    FStartPos: TScriptPos;
    FData: Pointer;             // pointer to some data element (for users)
    FLocalTable: TSymbolTable;  // symbol table associated with the context (begin..end blocks, TProcedures, etc)
  public
    constructor Create(AParent: TContext; AStartPos: TScriptPos; AParentSymbol: TSymbol);
    destructor Destroy; override;
    function IsPositionInContext(ACol, ALine: Integer; SourceFile: TSourceFile=nil): Boolean;
    property Parent: TContext read FParentContext;
    property ParentSym: TSymbol read FParentSymbol;
    property SubContexts: TList read FSubContexts;
    property StartPos: TScriptPos read FStartPos;
    property EndPos: TScriptPos read FEndPos;
    property Data: Pointer read FData write FData;
    property LocalTable: TSymbolTable read FLocalTable write FLocalTable;
  end;

  // Map the various script contexts. (Code blocks)
  TContextMap = class
  private
    FScriptContexts: TList;     // list of top-level contexts
    FCurrentContext: TContext;  // current context (used when adding and leaving)
  public
    constructor Create;
    destructor Destroy; override;
    { Push a context on to the stack - procedures have a symbol context.
      Standard Begin..end blocks do not have a ParentSymbol. }
    procedure OpenContext(AStartPos: TScriptPos; AParentSymbol: TSymbol);
    { Pop a context off the stack }
    procedure CloseContext(AEndPos: TScriptPos);
    function FindContext(AParentSymbol: TSymbol): TContext; overload;// return the first context group based on its parent
    function FindContext(ACol, ALine: Integer; SourceFile: TSourceFile=nil): TContext; overload;
    function FindContext(ScriptPos: TScriptPos): TContext; overload;
    property Contexts: TList read FScriptContexts;
    property Current: TContext read FCurrentContext; 
  end;

  // If a class needs completing this refers to the type of error
  TClassCompleteErrorType =
                   (ccePropAccessDeclMissing,    // property read/write access symbol declaration is missing
                    cceMethodImplMissing         // method implementation is missing
                   );

  // If a class needs completing this contains the information about the error
  // and includes a suggested fix
  TClassCompleteErrorInfo = record
    ErrorClass: TClassSymbol;
    ErrorType: TClassCompleteErrorType;   // TClassMemberError declared in dws2Symbols.pas
    SuggestedFix: string;
  end;

  // Dynamic list of all class completion errors encountered
  TClassCompleteNeeds = array of TClassCompleteErrorInfo;

  TProgramEvent = procedure (Prog: TProgram) of object;

  Tdws2ResultType = class;

  Tdws2Result = class
  private
    FResultType: Tdws2ResultType;
  protected
    constructor Create(ResultType: Tdws2ResultType);
    procedure InitializeProgram(Prog: TProgram); virtual;
    procedure FinalizeProgram(Prog: TProgram); virtual;
    property ResultType: Tdws2ResultType read FResultType;
  end;

  Tdws2ResultType = class(TComponent)
  private
    FOnInitializeProgram: TProgramEvent;
    FOnFinalizeProgram: TProgramEvent;
  public
    procedure AddResultSymbols(SymbolTable: TSymbolTable); virtual;
    function CreateProgResult: Tdws2Result; virtual;
  published
    property OnInitializeProgram: TProgramEvent read FOnInitializeProgram write FOnInitializeProgram;
    property OnFinalizeProgram: TProgramEvent read FOnFinalizeProgram write FOnFinalizeProgram;
  end;

  // Interface for external debuggers
  IDebugger = interface
    ['{8D534D14-4C6B-11D5-8DCB-0000216D9E86}']
    procedure StartDebug(MainProg: TProgram);
    procedure DoDebug(Prog: TProgram; Expr: TExpr);
    procedure StopDebug(MainProg: TProgram);
    procedure EnterFunc(Prog: TProgram; Expr: TExpr);
    procedure LeaveFunc(Prog: TProgram; Expr: TExpr);
  end;

  // Stops the script after given time (Timeout)
  TTerminatorThread = class(TThread)
    FProg: TProgram;
    FMillisecRemaining: Integer;
    constructor Create(Prog: TProgram; MilliSecToLive: Integer);
    procedure Execute; override;
  end;

  TProgramInfo = class;

  TProgramState = (psUndefined, psReadyToInitialize, psInitialized, psRunning, psRunningStopped, psTerminated);

  // A script executable program
  TProgram = class(TInterfacedObject)
  private
    FAddrGenerator: TAddrGenerator;
    FDebugger: IDebugger;
    FExpr: TExpr;
    FInitExpr: TExpr;
    FInfo: TProgramInfo;
    FIsDebugging: Boolean;
    FMsgs: TMsgs;
    FParameters: TData;
    FParent: TProgram;
    FProgramState: TProgramState;
    FResult: Tdws2Result;
    FResultType: Tdws2ResultType;
    FRoot: TProgram;
    FRootTable: TSymbolTable;
    FStack: TStack;
    FTable: TSymbolTable;
    FTimeout: Integer;
    FTypBoolean: TTypeSymbol;
    FTypDateTime: TTypeSymbol;
    FTypFloat: TTypeSymbol;
    FTypInteger: TTypeSymbol;
    FTypNil: TNilSymbol;
    FTypObject: TClassSymbol;
    FTypString: TTypeSymbol;
    FTypVariant: TTypeSymbol;
    FUserDef: TObject;
    FSymbolDictionary: TSymbolDictionary;
    FContextMap: TContextMap;
    FSourceList: TScriptSourceList;
    FClassCompleteNeeds: TClassCompleteNeeds;
  protected
    procedure DoStep(Expr: TExpr);
    procedure FinalizeProgram;
    procedure InitializeProgram;
    procedure InternalExecute;
    function GetLevel: Integer;
    function GetResult: Tdws2Result; virtual;
    function GetUserDef: TObject; virtual;
    procedure SetDebugger(const Value: IDebugger);
    procedure SetResult(const Value: Tdws2Result); virtual;
    procedure SetUserDef(const Value: TObject); virtual;
  public
    constructor Create(SystemTable: TSymbolTable; ResultType: Tdws2ResultType; MaxDataSize: Integer; StackChunkSize: Integer = C_DefaultStackChunkSize);
    destructor Destroy; override;
    procedure AddClassCompleteInfo(Info: TClassCompleteErrorInfo);
    procedure BeginProgram(IsRunningMainProgram: Boolean = True);
    procedure DestroyScriptObj(ScriptObj: IScriptObj);
    procedure EndProgram;
    procedure Execute; overload; virtual;
    procedure Execute(TimeoutValue: Integer); overload;
    procedure ExecuteParam(const Params: array of Variant); overload;
    procedure ExecuteParam(const Params: array of Variant; TimeoutValue: Integer); overload;
    procedure ExecuteParam(Params: OleVariant); overload;
    procedure ExecuteParam(Params: OleVariant; TimeoutValue: Integer); overload;
    function GetResultAddr(ResultSize: Integer): Integer;
    procedure Stop; virtual;
    procedure ReadyToInitialize; virtual;
    property Debugger: IDebugger read FDebugger write SetDebugger;
    property Expr: TExpr read FExpr write FExpr;
    property InitExpr: TExpr read FInitExpr;
    property Info: TProgramInfo read FInfo;
    property IsDebugging: Boolean read FIsDebugging;
    property Level: Integer read GetLevel;
    property Msgs: TMsgs read FMsgs write FMsgs;
    property Parameters: TData read FParameters;
    property Parent: TProgram read FParent;
    property ProgramState: TProgramState read FProgramState;
    property Result: Tdws2Result read GetResult write SetResult;
    property Root: TProgram read FRoot write FRoot;
    property Stack: TStack read FStack;
    property RootTable: TSymbolTable read FRootTable;
    property Table: TSymbolTable read FTable write FTable;
    property Timeout: Integer read FTimeout write FTimeout;
    property TypBoolean: TTypeSymbol read FTypBoolean;
    property TypDateTime: TTypeSymbol read FTypDateTime;
    property TypFloat: TTypeSymbol read FTypFloat;
    property TypInteger: TTypeSymbol read FTypInteger;
    property TypNil: TNilSymbol read FTypNil;
    property TypObject: TClassSymbol read FTypObject;
    property TypString: TTypeSymbol read FTypString;
    property TypVariant: TTypeSymbol read FTypVariant;
    property UserDef: TObject read GetUserDef write SetUserDef;
    property SymbolDictionary: TSymbolDictionary read FSymbolDictionary;
    property ContextMap: TContextMap read FContextMap;
    property SourceList: TScriptSourceList read FSourceList;
    property ClassCompleteNeeds: TClassCompleteNeeds read FClassCompleteNeeds write FClassCompleteNeeds;
  end;

  // Functions callable from a script program implement this interfaces
  ICallable = interface(IExecutable)
    ['{8D534D15-4C6B-11D5-8DCB-0000216D9E86}']
    procedure Call(Caller: TProgram; Func: TFuncSymbol);
  end;

  // A script procedure
  TProcedure = class(TProgram, IUnknown, ICallable)
  private
    FFunc: TFuncSymbol;
  protected
    function GetResult: Tdws2Result; override;
    function GetUserDef: TObject; override;
    procedure SetResult(const Value: Tdws2Result); override;
    procedure SetUserDef(const Value: TObject); override;
  public
    constructor Create(Parent: TProgram);
    destructor Destroy; override;
    procedure AssignTo(sym: TFuncSymbol);
    procedure Call(Caller: TProgram; Func: TFuncSymbol);
    procedure Execute; override;
    procedure Initialize;
    function Optimize(FuncExpr: TExprBase): TExprBase;
    procedure Stop; override;
    property Func: TFuncSymbol read FFunc write FFunc;
  end;

  // Base class of all expressions
  TExpr = class(TExprBase)
  private
    FPos: TScriptPos;
    FProg: TProgram;
    FTyp: TSymbol;
    function CreateEDelphiObj(ClassName, Message: string): IScriptObj;