dws2exprs.pas

script language

      else
      begin
        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);
        Result.Typ := Expr.Typ;
      end;
    fkDestructor:
      begin
        Assert(RefKind = rkObjRef);
        if not ForceStatic and meth.IsVirtual then
          Result := TDestructorVirtualExpr.Create(Expr.Prog, Pos, meth, Expr,
            IsInstruction)
        else
          Result := TDestructorStaticExpr.Create(Expr.Prog, Pos, meth, Expr,
            IsInstruction)
      end;
  end;
end;

{ TProgram }

constructor TProgram.Create(SystemTable: TSymbolTable; ResultType: Tdws2ResultType; MaxDataSize: Integer; StackChunkSize: Integer = C_DefaultStackChunkSize);
begin
  FResultType := ResultType;
  FProgramState := psUndefined;

  FMsgs := TMsgs.Create;
  FRoot := Self;

  // Create the Symbol Dictionary
  FSymbolDictionary := TSymbolDictionary.Create;
  // Create Context Map
  FContextMap := TContextMap.Create;
  //Create Script Source List
  FSourceList := TScriptSourceList.Create;

  // Create the program stack
  FStack := TStack.Create(StackChunkSize, MaxDataSize);
  FAddrGenerator := TAddrGenerator.Create(0, agmPositive);

  // Initialize the system table
  FRootTable := TSymbolTable.Create(SystemTable, FAddrGenerator);
  FTable := FRootTable;

  FInitExpr := TBlockExpr.Create(Self, NullPos);

  // Initialize shortcuts to often used symbols
  FTypBoolean := SystemTable.FindSymbol(SYS_BOOLEAN) as TTypeSymbol;
  FTypDateTime := SystemTable.FindSymbol(SYS_DATETIME) as TTypeSymbol;
  FTypFloat := SystemTable.FindSymbol(SYS_FLOAT) as TTypeSymbol;
  FTypInteger := SystemTable.FindSymbol(SYS_INTEGER) as TTypeSymbol;
  FTypString := SystemTable.FindSymbol(SYS_STRING) as TTypeSymbol;
  FTypVariant := SystemTable.FindSymbol(SYS_VARIANT) as TTypeSymbol;
  FTypNil := TNilSymbol.Create;
  FTypObject := TClassSymbol(SystemTable.FindSymbol(SYS_TOBJECT));
end;

destructor TProgram.Destroy;
begin
  FResult.Free;
  FExpr.Free;
  FInitExpr.Free;
  FRootTable.Free;
  FStack.Free;
  FAddrGenerator.Free;
  FTypNil.Free;
  FMsgs.Free;
  FSymbolDictionary.Free;
  FContextMap.Free;
  FSourceList.Free;
  inherited;
end;

procedure TProgram.InitializeProgram;
begin
  // Program is already running
  if FProgramState = psRunning then
    Msgs.AddErrorStop(RTE_ScriptAlreadyRunning);

  // Compilation terminated with errors
  if FProgramState = psUndefined then
    Msgs.AddErrorStop(RTE_CantRunScript);

  if FProgramState <> psReadyToInitialize then
    Msgs.AddErrorStop('ProgramState should be "ReadyToInitialize"');

  // Initialize Result
  FResult.Free;
  FResult := FResultType.CreateProgResult;

  Msgs.Clear;

  // Stack
  FStack.Reset;
  FStack.Push(FAddrGenerator.DataSize);
  FStack.SaveBp(0, FStack.BasePointer);

  FProgramState := psRunning;
  try
    // Initialize global variables
    FInitExpr.Eval;
  finally
    FProgramState := psReadyToInitialize;
  end;

  // Debugger
  FIsDebugging := Assigned(FDebugger);
  if FIsDebugging then
    FDebugger.StartDebug(Self);

  // Result
  FResult.InitializeProgram(Self);

  FProgramState := psInitialized;

  FInfo := TProgramInfo.Create(FTable, Self);
end;

procedure TProgram.FinalizeProgram;
begin
  if FProgramState <> psTerminated then
    Msgs.AddError('ProgramState should be "Terminated"');

  try
    // Result
    FResult.FinalizeProgram(Self);

    // Flags
    FIsDebugging := False;

    // Stack
    FStack.Pop(FAddrGenerator.DataSize);

    // Debugger
    if Assigned(FDebugger) then
      FDebugger.StopDebug(Self);

    FProgramState := psReadyToInitialize;

    FreeAndNil(FInfo);
  except
    on e: EScriptError do
      ;
    on e: Exception do
      Msgs.AddError(e.Message);
  end;
end;

procedure TProgram.Execute;
begin
  Execute(0);
end;

procedure TProgram.Execute(TimeoutValue: Integer);
var
  terminator: TTerminatorThread;
begin
  try
    InitializeProgram;

    if FProgramState <> psInitialized then
      raise Exception.Create(RTE_StateInitializedExpected);

    if TimeoutValue > 0 then
      terminator := TTerminatorThread.Create(Self, TimeoutValue * 1000)
    else if FTimeout > 0 then
      terminator := TTerminatorThread.Create(Self, FTimeout * 1000)
    else
      terminator := nil;

    FProgramState := psRunning;

    // Run the script
    try
      InternalExecute;
    finally
      if Assigned(terminator) then
        terminator.Terminate;

      FProgramState := psTerminated;
    end;

    FinalizeProgram;
  except
    on e: EScriptError do
      ; // Error message in FMsgs
    on e: Exception do
      Msgs.AddExecutionError(e.Message);
  end;
  Msgs.SetScriptError(NullPos);
end;

procedure TProgram.InternalExecute;
begin
  Assert(FProgramState = psRunning);
  try
    // Run the script
    FExpr.Eval;
  except
    on e: EExit do
      ;
    on e: EBreak do
      Msgs.AddInfo(RTE_InvalidBreak);
    on e: EContinue do
      Msgs.AddInfo(RTE_InvalidContinue);
    on e: EScriptException do
      Msgs.AddExecutionError(e.Pos, e.Message);
    on e: EScriptError do
      ;
    on e: Exception do
      Msgs.AddExecutionError(e.Message);
  end;
end;

procedure TProgram.ExecuteParam(const Params: array of Variant);
begin
  ExecuteParam(Params, 0)
end;

procedure TProgram.ExecuteParam(const Params: array of Variant; TimeoutValue: Integer);
var
  x, index: Integer;
begin
  SetLength(FParameters, High(Params) - Low(Params) + 1);
  index := 0;
  for x := Low(Params) to High(Params) do
  begin
    FParameters[index] := Params[x];
    Inc(index);
  end;

  Execute(TimeoutValue);
end;

procedure TProgram.ExecuteParam(Params: OleVariant);
begin
  ExecuteParam(Params, 0);
end;

procedure TProgram.ExecuteParam(Params: OleVariant; TimeoutValue: Integer);
var
  x: Integer;
begin
  if VarIsArray(Params) then
  begin
    SetLength(FParameters, VarArrayHighBound(Params, 1) + 1);
    for x := 0 to VarArrayHighBound(Params, 1) do
      FParameters[x] := Params[x];
  end
  else
  begin
    SetLength(FParameters, 1);
    FParameters[0] := Params;
  end;

  Execute(TimeoutValue);
end;

procedure TProgram.DoStep(Expr: TExpr);
begin
  if FRoot.ProgramState = psRunningStopped then
    Msgs.AddExecutionStop(Expr.Pos, RTE_ScriptStopped);

  if FRoot.IsDebugging then
    FRoot.Debugger.DoDebug(Self, Expr);
end;

procedure TProgram.SetDebugger(const Value: IDebugger);
begin
  if FRoot = Self then
    FDebugger := Value
  else
    FRoot.Debugger := Value;
end;

procedure TProgram.Stop;
begin
  if FProgramState = psRunning then
    FProgramState := psRunningStopped;
end;

function TProgram.GetLevel: Integer;
begin
  Result := FAddrGenerator.Level;
end;

function TProgram.GetResult: Tdws2Result;
begin
  Result := FResult;
end;

procedure TProgram.SetResult(const Value: Tdws2Result);
begin
  FResult := Value;
end;

function TProgram.GetUserDef: TObject;
begin
  Result := FUserDef;
end;

procedure TProgram.SetUserDef(const Value: TObject);
begin
  FUserDef := Value;
end;

// Called by the compiler if compilation has been finished successfully
procedure TProgram.ReadyToInitialize;
begin
  if FProgramState = psUndefined then
    FProgramState := psReadyToInitialize;
end;

// Starts the program but does not terminate it.
// Use .Info property to call procedures and call EndProgram() to
// terminate the program
procedure TProgram.BeginProgram(IsRunningMainProgram: Boolean);
begin
  try
    InitializeProgram;

    FProgramState := psRunning;

    if IsRunningMainProgram then
      InternalExecute;
  except
    on e: Exception do
      Msgs.AddExecutionError(e.Message);
  end;
end;

// Terminates the program previously started with BeginProgram()
procedure TProgram.EndProgram;
begin
  try
    FProgramState := psTerminated;
    FinalizeProgram;
  except
    on e: Exception do
      Msgs.AddExecutionError(e.Message);
  end;
end;

function TProgram.GetResultAddr(ResultSize: Integer): Integer;
begin
  Result := FAddrGenerator.GetStackAddr(ResultSize);
end;

procedure DestroyScriptObject(ScriptObj: IScriptObj);
begin
  // Pseudo-Program or Ignore ?? 
end;

{
procedure DestroyScriptObject(ScriptObj: IScriptObj);
var
  Prog: TProgram;
begin
  Prog := TProgram.Create(ScriptObj.ClassSym.Members,nil,MaxInt);
  try
    Prog.DestroyScriptObj(ScriptObj);
  finally
    Prog.Free;
  end;
end;
}

procedure TProgram.DestroyScriptObj(ScriptObj: IScriptObj);
var
  sym: TSymbol;
  func: TMethodSymbol;
  expr: TExpr;
begin
  try
    sym := ScriptObj.ClassSym.Members.FindSymbol(SYS_TOBJECT_DESTROY);

    if sym is TMethodSymbol then
    begin
      func := TMethodSymbol(sym);
      if (func.Kind = fkDestructor) and (func.Params.Count = 0) then
      begin
        expr :=
          TDestructorVirtualExpr.Create(Self, NullPos, func,
            TConstExpr.Create(Self, NullPos, ScriptObj.ClassSym, Scr