dws2compiler.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 dws2Compiler;

interface

uses
{$IFDEF NEWVARIANTS}
  Variants,
{$ENDIF}
  Classes, SysUtils, dws2Exprs, dws2Symbols, dws2Tokenizer, dws2Errors,
  dws2Strings, dws2Functions, dws2Stack;

type
  TCompilerOption = (coOptimize, coSymbolDictionary, coContextMap);
  TCompilerOptions = set of TCompilerOption;

  TIncludeEvent = procedure(const scriptName: string; var scriptSource: string) of
    object;

  Tdws2Filter = class;

  TConfiguration = class(TPersistent)
  private
    FCompilerOptions: TCompilerOptions;
    FConnectors: TStrings;
    FDefaultResultType: Tdws2ResultType;
    FFilter: Tdws2Filter;
    FMaxDataSize: Integer;
    FOnInclude: TIncludeEvent;
    FOwner: TComponent;
    FResultType: Tdws2ResultType;
    FScriptPaths: TStrings;
    FStackChunkSize: Integer;
    FSystemTable: TSymbolTable;
    FTimeout: Integer;
    FUnits: TStrings;
  protected
    procedure InitSystemTable;
    procedure SetResultType(const Value: Tdws2ResultType);
    procedure SetFilter(const Value: Tdws2Filter);
  public
    constructor Create(Owner: TComponent);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure SetScriptPaths(const Value: TStrings);
    property Connectors: TStrings read FConnectors write FConnectors;
    property OnInclude: TIncludeEvent read FOnInclude write FOnInclude;
    property SystemTable: TSymbolTable read FSystemTable write FSystemTable;
    property Units: TStrings read FUnits write FUnits;
  published
    property Filter: Tdws2Filter read FFilter write SetFilter;
    property ResultType: Tdws2ResultType read FResultType write SetResultType;
    property CompilerOptions: TCompilerOptions read FCompilerOptions write FCompilerOptions;
    property MaxDataSize: Integer read FMaxDataSize write FMaxDataSize;
    property ScriptPaths: TStrings read FScriptPaths write SetScriptPaths;
    property Timeout: Integer read FTimeout write FTimeout;
    property StackChunkSize: Integer read FStackChunkSize write FStackChunkSize default C_DefaultStackChunkSize;
  end;

  Tdws2Filter = class(TComponent)
  private
    FSubFilter: Tdws2Filter;
    FDependencies: TStrings;
    FPrivateDependencies: TStrings;
    function GetDependencies: TStrings;
  protected
    procedure SetSubFilter(const Filter: Tdws2Filter); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property PrivateDependencies: TStrings read FPrivateDependencies;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Process(const Text: string; Msgs: TMsgs): string; virtual;
    property SubFilter: Tdws2Filter read FSubFilter write SetSubFilter;
    property Dependencies: TStrings read GetDependencies;
  end;

  TAddArgProcedure = procedure(ArgExpr: TExpr) of object;

  Tdws2Compiler = class
  private
    FCompilerOptions: TCompilerOptions;
    FConnectors: TStrings;
    FFilter: Tdws2Filter;
    FMsgs: TMsgs;
    FOnInclude: TIncludeEvent;
    FProg: TProgram;
    FScriptPaths: TStrings;
    FTok: TTokenizer;
    procedure CheckName(Name: string);
    procedure CompareFuncSymbols(A, B: TFuncSymbol; IsCheckingParameters: Boolean);
    function FindScriptPathForFile(const FileName: string): string;
    function GetScriptSource(ScriptName: string): string;
    function GetVarExpr(dataSym: TDataSymbol): TDataExpr;
    function GetVarParamExpr(dataSym: TVarParamSymbol): TExpr;
    function ReadAssign(Left: TExpr): TExpr;
    function ReadArray(TypeName: string): TTypeSymbol;
    function ReadCase: TCaseExpr;
    function ReadClass(TypeName: string): TTypeSymbol;
    function ReadConnectorSym(Name: string; var BaseExpr: TExpr; ConnectorType:
      IConnectorType; IsWrite: Boolean): TExpr;
    function ReadConnectorArray(Name: String; var BaseExpr: TExpr; ConnectorType: IConnectorType;
      IsWrite: Boolean): TExpr;
    procedure ReadConstDecl;
    function ReadConstValue: TExpr;
    function ReadBlock: TExpr;
    function ReadBlocks(EndTokens: TTokenTypes; var FinalToken: TTokenType): TExpr;
    function ReadEnumeration(TypeName: string): TEnumerationSymbol;
    function ReadExcept(TryExpr: TExpr): TExceptExpr;
    function ReadExpr: TExpr;
    function ReadExprAdd: TExpr;
    function ReadExprMult: TExpr;
    function ReadExternalVar(Sym: TExternalVarSymbol; IsWrite: Boolean): TFuncExpr;
    function ReadField(var Expr: TDataExpr; Sym: TFieldSymbol): TExpr;
    function ReadFor: TExpr;
    function ReadFunc(FuncSym: TFuncSymbol; IsWrite: Boolean; CodeExpr: TDataExpr = nil): TExpr;
    procedure ReadFuncArgs(AddArgProc: TAddArgProcedure; LDelim: TTokenType = ttBLEFT; RDelim: TTokenType = ttBRIGHT);
    function ReadIf: TIfExpr;
    function ReadInherited(IsWrite: Boolean): TExpr;
    function ReadInstr: TExpr;
    function ReadInstrSwitch: TExpr;
    function ReadMethodDecl(ClassSym: TClassSymbol; FuncKind: TFuncKind;
      IsClassMethod: Boolean): TMethodSymbol;
    function ReadMethodImpl(ClassSym: TClassSymbol; FuncKind: TFuncKind;
      IsClassMethod: Boolean): TMethodSymbol;
    function ReadName(IsWrite: Boolean = False): TExpr;
    // Created overloaded ReadNameList to deal with script positions
    procedure ReadNameList(Names: TStrings); overload;
    procedure ReadNameList(Names: TStrings; out PosArray: TScriptPosArray); overload;
    procedure ReadArrayParams(ArrayIndices: TSymbolTable);
    // Don't want to add param symbols to dictionary when a method implementation (they get thrown away)
    procedure ReadParams(Proc: TFuncSymbol; ParamsToDictionary: Boolean=True);
    function ReadProcDecl(FuncKind: TFuncKind; ClassSym: TClassSymbol;
      IsClassMethod: Boolean = False; IsType : Boolean = False): TFuncSymbol;
    procedure ReadProcBody(Proc: TFuncSymbol);
    function ReadProperty(ClassSym: TClassSymbol): TPropertySymbol;
    function ReadPropertyExpr(var Expr: TDataExpr; PropertySym: TPropertySymbol; IsWrite: Boolean): TExpr;
    function ReadRecord(TypeName: string): TTypeSymbol;
    function ReadRaise: TExpr;
    function ReadRepeat: TExpr;
    function ReadRootStatement: TExpr;
    function ReadScript(AName: string=''; ScriptType: TScriptSourceType=stMain): TExpr;  // AName might be the name of an INCLUDEd script
    function ReadStatement: TExpr;
    function ReadStringArray(Expr: TExpr; IsWrite: Boolean): TExpr;
    function ReadSwitch(SwitchName: string): Boolean;
    function ReadSymbol(Expr: TExpr; IsWrite: Boolean = False): TExpr;
    function ReadTerm: TExpr;
    function ReadTry: TExpr;
    function ReadType(TypeName: string = ''): TTypeSymbol;
    procedure ReadTypeDecl;
    procedure ReadUses;
    function ReadVarDecl: TExpr;
    function ReadWhile: TExpr;
    function ResolveUnitReferences(Units: TStrings): TInterfaceList;
    function CheckFuncParams(ParamsA, ParamsB: TSymbolTable; IndexSym: TSymbol = nil;
      TypSym: TSymbol = nil): Boolean;
    function CheckParams(A, B: TSymbolTable; CheckNames: Boolean): Boolean;
  protected
    function CreateProgram(SystemTable: TSymbolTable; ResultType: Tdws2ResultType;
      MaxDataSize: Integer; StackChunkSize: Integer): TProgram; virtual;
  public
    function Compile(Text: string; Conf: TConfiguration): TProgram;
    class function Evaluate(AContext: TProgram; AExpression: string): TExpr;
  end;

  Tdws2DefaultResult = class(Tdws2Result)
  private
    FText: string;
    function GetText: string;
  public
    procedure AddString(const Str: string);
    property Text: string read GetText;
  end;


  Tdws2DefaultResultType = class(Tdws2ResultType)
  public
    procedure AddResultSymbols(SymbolTable: TSymbolTable); override;
    function CreateProgResult: Tdws2Result; override;
  end;

  TPrintFunction = class(TInternalFunction)
  public
    procedure Execute; override;
  end;

  TPrintLnFunction = class(TInternalFunction)
  public
    procedure Execute; override;
  end;

implementation

uses Contnrs;

function GetBaseType(Sym : TSymbol) : TTypeSymbol;
begin
  if Assigned(Sym) then
    Result := Sym.BaseType
  else
    Result := nil;
end;

type
  TExceptionCreateMethod = class(TInternalMethod)
    procedure Execute(var ExternalObject: TObject); override;
  end;

  TDelphiExceptionCreateMethod = class(TInternalMethod)
    procedure Execute(var ExternalObject: TObject); override;
  end;

  TParamFunc = class(TInternalFunction)
    procedure Execute; override;
  end;

  TParamStrFunc = class(TInternalFunction)
    procedure Execute; override;
  end;

  TParamCountFunc = class(TInternalFunction)
    procedure Execute; override;
  end;

function Tdws2Compiler.ResolveUnitReferences(Units: TStrings): TInterfaceList;
var
  x, y, z: Integer;
  deps: TStrings;
  refCount: array of Integer;
  changed: Boolean;
  unitName: string;
begin
  // initialize reference count vector
  SetLength(refCount, Units.Count);

  // Calculate number of outgoing references
  for x := 0 to Units.Count - 1 do
  begin
    deps := IUnit(Pointer(Units.Objects[x])).GetDependencies;
    for y := 0 to deps.Count - 1 do
    begin
      if Units.IndexOf(deps[y]) < 0 then
        FMsgs.AddCompilerStop(NullPos, Format(CPE_UnitNotFound, [deps[y],
          Units[x]]));
    end;
    refCount[x] := deps.Count;
  end;

  Result := TInterfaceList.Create;
  try

    // Resolve references
    changed := True;
    while changed do
    begin
      changed := False;
      for x := 0 to Units.Count - 1 do
        // Find unit that is not referencing other units
        if refCount[x] = 0 then
        begin
          Result.Add(IUnit(Pointer(Units.Objects[x])));

          // Remove the references to this unit from all other units
          unitName := Units[x];
          for y := 0 to Units.Count - 1 do
          begin
            deps := IUnit(Pointer(Units.Objects[y])).GetDependencies;
            for z := 0 to deps.Count - 1 do
              if SameText(deps[z], unitName) then
                Dec(refCount[y]);
          end;

          refCount[x] := -1;
          changed := True;
        end;
    end;

    if Result.Count <> Units.Count then
      FMsgs.AddCompilerStop(NullPos, CPE_UnitCircularReference);
  except
    Result.Free;
    raise;
  end;
end;

function Tdws2Compiler.Compile(Text: string; Conf: TConfiguration): TProgram;
var
  x: Integer;
  stackChunkSize: Integer;
  maxDataSize: Integer;
  unitsResolved: TInterfaceList;
  unitsTable: TSymbolTable;
  unitTables: TObjectList;
  unitTable: TSymbolTable;
  codeCompleteInfo: TClassCompleteErrorInfo;
begin
  FFilter := Conf.Filter;
  FConnectors := Conf.Connectors;
  FCompilerOptions := Conf.CompilerOptions;
  FOnInclude := Conf.OnInclude;
  FScriptPaths := Conf.ScriptPaths;

  maxDataSize := Conf.MaxDataSize;
  if maxDataSize = 0 then
    maxDataSize := MaxInt;

  StackChunkSize := Conf.StackChunkSize;
  if StackChunkSize <= 0 then
    StackChunkSize := 1;

  // Create the TProgram
  FProg := CreateProgram(Conf.SystemTable, Conf.ResultType, maxDataSize, stackChunkSize);
  Result := FProg;
  FMsgs := FProg.Msgs;

  FProg.Timeout := Conf.Timeout;

  try
    // Check for missing units
    if Assigned(FFilter) then
      for x := 0 to FFilter.Dependencies.Count - 1 do
      begin
        if Conf.Units.IndexOf(FFilter.Dependencies[x]) = -1 then
          FMsgs.AddCompilerError(Format(CPE_FilterDependsOnUnit,[FFilter.ClassName, FFilter.Dependencies[x]]));
      end;

    // Handle unit dependencies
    unitsResolved := ResolveUnitReferences(Conf.Units);
    try
      unitTables := TObjectList.Create(False);
      unitsTable := TSymbolTable.Create;
      try
        try
          // Get the symboltables of the units
          for x := 0 to unitsResolved.Count - 1 do
          begin
            unitTable := IUnit(unitsResolved[x]).GetUnitTable(Conf.SystemTable, unitsTable);
            unitTables.Add(unitTable);
            unitsTable.AddSymbol(TUnitSymbol.Create(IUnit(unitsResolved[x]).GetUnitName,unitTable));
          end;
        except
          on e: Exception do
          begin
            unitTables.OwnsObjects := True;
            raise;
          end;
        end;

        // Add the units to the program-symboltable
        for x := 0 to unitsTable.Count - 1 do
        begin
          FProg.Table.AddSymbol(TUnitSymbol.Create(
            TUnitSymbol(unitsTable[x]).Name,
            TUnitSymbol(unitsTable[x]).Table,
            True));
          FProg.Table.AddParent(TUnitSymbol(unitsTable[x]).Table);
        end;

      finally
        unitsTable.Free;