dxjs_main.pas

Well known and usefull component for delphi 7

    AllocateEvalSpace;
  end;
  ScriptState := ss_Compiled;
end;

function TJScript.Run(RunMode: Integer = rmRun): boolean;
begin
  ScriptState := ss_Running;
  result := Postfix.Run(RunMode);
  if not result then begin
    if Assigned(fOnShowError) then fOnShowError(Error)
    else ShowError(Error);
  end;
  ScriptState := ss_Compiled;
end;

procedure TJScript.AddObject(const Name: String; Instance: TObject);
begin
  if Assigned(HostObjectList) then HostObjectList.AddObject(Name, Instance);
end;

procedure TJScript.AddRoutine(const Name: String; Address: Pointer);
begin
  if Assigned(HostDefinitionList) then
    HostDefinitionList.RegisterRoutine(Name, 0, Address, -1, KindDelphiRoutine);
end;

procedure TJScript.AddMethod(AClass: TClass; const Name: String; Address: Pointer);
var
  D: TDefinition;
begin
  if Assigned(HostDefinitionList) then begin
    D := HostDefinitionList.RegisterRoutine(Name, 0, Address, Integer(AClass.ClassInfo), KindDelphiMethod);
    D.AClass := AClass;
  end;
end;

procedure TJScript.AddConstructor(AClass: TClass; Address: Pointer);
begin
  if Assigned(HostConstructorList) then
    HostConstructorList.AddObject(DXString.UpperCase(AClass.ClassName), Address);
end;

procedure TJScript.AddProperty(AClass: TClass; const Name: String;
                               ReadAddr, WriteAddr: Pointer);
begin
  if Assigned(PropDefList) then
    PropDefList.RegisterProperty(AClass, Name, ReadAddr, WriteAddr);
end;

procedure TJScript.RemoveProperty(AClass: TClass; const Name: String);
var
  I: Integer;
  PropDef: TPropDef;
begin
  if Assigned(RemovePropList) then begin
    RemovePropList.AddObject(Name, TObject(AClass));
    for I:=0 to PropDefList.Count - 1 do begin
      PropDef := TPropDef(PropDefList.Objects[I]);
      if (PTypeInfo(PropDef.ClassID) = AClass.ClassInfo) and
         StrEql(PropDefList[I], Name) then begin
        PropDefList.Delete(I);
        PropDef.Free;
        Exit;
      end;
    end;
  end;
end;

procedure TJScript.AddHostVariable(const Name: String; Address: Pointer);
begin
  HostVariableList.AddObject(Name, Address);
end;

procedure TJScript.AddConstant(const Name: String; const Value: Variant);
begin
  ConstantList.AddConstant(Name, Value);
end;

procedure TJScript.ShowError(const Error: Variant);
var
  S: String;
  SO: TScriptObject;
begin
  SO := VariantToScriptObject(Error);
  S := ToString(SO.GetProperty('script time')) + ' error' + BR +
      ToString(SO.GetProperty('description')) + BR +
      'Module: ' + ToString(SO.GetProperty('module')) + BR +
      'File: ' + ToString(SO.GetProperty('file')) + BR +
      'Line number: ' + ToString(SO.GetProperty('line number')) + BR +
      ToString(SO.GetProperty('line'));
  if IsConsole then writeln(S)
  Else ErrMessageBox(S);
end;

procedure TJScript.CreateErrorObject(E: Exception);
var
  SO: TErrorObject;
  ModuleID, ModuleLineID: Integer;
  Module: TModule;
  P: Integer;
begin
  SO := TErrorObject.Create(Self);
  case ScriptState of
    ss_Compiling:begin
      P := Postfix.Card;
      SO.PutProperty('script time', 'Compile-time');
    end;
{    ssRunning:}
    Else begin
      P := Postfix.N;
      SO.PutProperty('script time', 'Run-time');
    end;
  end;
  ModuleID := Postfix.GetModuleID(P);
  ModuleLineID := Postfix.GetModuleLineID(P);
  Module := Modules[ModuleID];
  SO.PutProperty('description', E.Message);
  if Module <> nil then begin
    SO.PutProperty('module', Module.Name);
    if Module.FileName <> '' then SO.PutProperty('file', Module.FileName);
    if ModuleLineID < Module.Count then
      SO.PutProperty('line', Module.Strings[ModuleLineID]);
    SO.PutProperty('line number', ModuleLineID + 1);
  end;
  Error := ScriptObjectToVariant(SO);
end;

procedure TJScript.ClearModule(const Modulename:String);
Var
   I:Integer;
Begin
   I:=Modules.IndexOf(Modulename);
   If I>=0 then begin
      TModule(Modules.List[I]).Text:='';
      TModule(Modules.List[I]).FileName:='';
   End;
End;

function TJScript.GetID(const Name: String): Integer;
begin
  result := SymbolTable.FastLookUpID(Name, 0);
end;

function TJScript.GetValue(ID: Integer): Variant;
begin
  result := SymbolTable.GetValue(ID);
end;

procedure TJScript.PutValue(ID: Integer; const Value: Variant);
begin
  SymbolTable.PutValue(ID, Value);
end;

function TJScript.CallFunction(SubID: Integer; const Parameters: array of Variant): Variant;
var
  ID, I, L, LastCard, LastNP, LastOP, LastN, LastStackCard,
  TempBoundVar, StartPos, ParamCount,
  TempCurrBoundTable, TempCurrBoundStack: Integer;
begin
  ScriptState := ss_Running;
{  SymbolTable.SetupHostDefinitions;}
  LastCard := SymbolTable.Card;
  LastNP   := PostFix.Card;
  LastN    := Postfix.N;
  LastOP   := PostFix.OP;
  TempBoundVar := SymbolTable.MemBoundVar;
  LastStackCard := PostFix.Stack.Card;
  TempCurrBoundTable := Postfix.CurrBoundTable;
  TempCurrBoundStack := Postfix.CurrBoundStack;
  L := SymbolTable.AppLabel;
  SymbolTable.A[L].Level:=SubID;
//  SetLevel(L, SubID);
  StartPos := PostFix.Card;
  Postfix.App(SubID);
  Postfix.App(OP_SAVE_CALL);
  Postfix.App(L);
  ParamCount := 0;
  for I:=0 to Length(Parameters) - 1 do begin
    Inc(ParamCount);
    ID := SymbolTable.AppVariant(Parameters[I]);
    Postfix.App(ID);
  end;
  Postfix.App(SymbolTable.AppVariantConst(ParamCount));
  Postfix.App(OP_CALL);
  Postfix.App(OP_HALT);
  SymbolTable.A[L].Next:=Postfix.Card;
  Postfix.N := StartPos;
  Inc(Postfix.EvalCount);
  PostFix.Run;
  Dec(Postfix.EvalCount);
//  ShowMessageWindow('',GetValue(GetID('rslt')));
  if Postfix.Ok then result := Postfix.PopVariant;
  SymbolTable.EraseTail(LastCard);
  PostFix.Card := LastNP;
  SymbolTable.MemBoundVar := TempBoundVar;
  Postfix.CurrBoundTable := TempCurrBoundTable;
  Postfix.CurrBoundStack := TempCurrBoundStack;
  PostFix.Stack.Card := LastStackCard;
  PostFix.OP := LastOP;
  PostFix.N := LastN;
end;

procedure TJScript.SaveToStream(S: TStream);
begin
  SymbolTable.SaveToStream(S);
  Postfix.SaveToStream(S);
end;

procedure TJScript.LoadFromStream(S: TStream);
begin
  SymbolTable.LoadFromStream(S);
  Postfix.LoadFromStream(S);
  Postfix.N := 0;
  SymbolTable.SetupHostDefinitions;
end;

function TJScript.AddBreakpoint(const ModuleName: String; LineNumber: Integer): boolean;
var
  N: Integer;
begin
  N := SourceLineToPCodeLine(ModuleName, LineNumber);
  if N > 0 then begin
    Postfix.BreakpointList.Add(Pointer(N));
    result := true;
  end
  else result := false;
end;

function TJScript.RemoveBreakpoint(const ModuleName: String; LineNumber: Integer): boolean;
var
  N: Integer;
begin
  N := SourceLineToPCodeLine(ModuleName, LineNumber);
  if N > 0 then begin
    Postfix.BreakpointList.Remove(Pointer(N));
    result := true;
  end
  else result := false;
end;

procedure TJScript.RemoveAllBreakpoints;
begin
  Postfix.BreakpointList.Clear;
end;

function TJScript.SourceLineToPCodeLine(const ModuleName: String; LineNumber: Integer): Integer;
var
  Loop, ModuleID: Integer;
  Inside: boolean;

begin
  result := -1;
  ModuleID := Modules.IndexOf(ModuleName);
  if ModuleID > -1 then begin
     Inside := false;
     for Loop:=1 to Postfix.Card do begin
       if Postfix.A[Loop] <= BOUND_FILES then begin
         Inside := BOUND_FILES - Postfix.A[Loop] = ModuleID;
       end;
       if Inside then
         if BOUND_LINES - Postfix.A[Loop] = LineNumber then begin
           result := Loop;
           Exit;
         end;
     end;
  end;
end;

function TJScript.CurrentLineNumber: Integer;
begin
  result := -1;
  if ScriptState = ss_Compiling then result := Postfix.GetModuleLineID(Postfix.Card)
  else if Postfix.N > 0 then result := Postfix.GetModuleLineID(Postfix.N);
end;

function TJScript.CurrentLine: String;
var
  ModuleID, LineID: Integer;
begin
  result := '';
  ModuleID := Modules.IndexOf(CurrentModule);
  if (ModuleID >= 0) and (ModuleID < Modules.Count) then begin
    LineID := CurrentLineNumber;
    if LineID < Modules[ModuleID].Count then
      CurrentLine := Modules[ModuleID].Strings[LineID];
  end;
end;

function TJScript.CurrentModule: String;
var
  ModuleID: Integer;
begin
  result := '';
  if ScriptState = ss_Compiling then
     ModuleID := Postfix.GetModuleID(Postfix.Card)
  else begin
    if Postfix.N = 0 then Exit;
    ModuleID := Postfix.GetModuleID(Postfix.N);
  end;
  if (ModuleID >= 0) and (ModuleID < Modules.Count) then
    result := Modules[ModuleID].Name;
end;

function TJScript.CurrentFunction: String;
begin
  result := '';
  if ScriptState = ss_Compiling then begin
    if Parser.CurrLevel > 0 then
       result := SymbolTable.GetName(Parser.CurrLevel);
  end
  else begin
    if Postfix.CallStack.TopObject <> nil then begin
      if Postfix.CallStack.TopObject.SubID > 0 then
         result := SymbolTable.GetName(Postfix.CallStack.TopObject.SubID);
    end;
  end;
end;

type
  TCallStackObject = class
    Arguments: array of Variant;
    CurrentLineNumber: Integer;
    CurrentModule: String;
    CurrentLine: String;
  end;

procedure TJScript.ExtractCallStack(CallStack: TStringList);
var
  Loop, Loop2, Temp: Integer;
  CallObject: TCallObject;
  CallStackObject: TCallStackObject;
begin
  for Loop:=0 to CallStack.Count - 1 do CallStack.Objects[Loop].Free;
  CallStack.Clear;
  for Loop:=0 to Postfix.CallStack.Count - 1 do begin
    CallObject := TCallObject(Postfix.CallStack[Loop]);
    Temp := Postfix.N;
    Postfix.N := CallObject.N;
    CallStackObject := TCallStackObject.Create;
    CallStackObject.CurrentModule := CurrentModule;
    CallStackObject.CurrentLine := CurrentLine;
    CallStackObject.CurrentLineNumber := CurrentLineNumber;
    Postfix.N := Temp;
    SetLength(CallStackObject.Arguments, Length(CallObject.Arguments));
    for Loop2:=0 to Length(CallObject.Arguments) - 1 do
      CallStackObject.Arguments[Loop2] := CallObject.Arguments[Loop2];
    CallStack.AddObject(SymbolTable.GetName(CallObject.SubID), CallStackObject);
  end;
end;

procedure TJScript.ResetRun;
begin
  SymbolTable.ResetRun;
  Postfix.ResetRun;
end;

procedure TJScript.Terminate;
var
  Loop: Integer;
  Instance: TForm;
begin
  if ScriptState = ss_Running then begin
    ScriptState := ss_Compiled;
    for Loop:=0 to OpenWindows.Count - 1 do begin
      Instance := TForm(OpenWindows[Loop]);
      if Instance <> nil then Begin
        Instance.Close;
        Instance.Free; //1-17-2003 OZZ
      End;
    end;
    OpenWindows.Clear; // 1-17-2003
  end;
end;

procedure TJScript.Print;
{$IFDEF DUMP}
Var
  I: Integer;
  Ws: String;
  Module: TModule;
  T: TextFile;
{$ENDIF}  
begin
{$IFDEF DUMP}
  Ws:='';
  I:=0;
  While I<Modules.List.Count do Begin
     Module := TModule(Modules.List[I]);
     Ws:=Ws+'// Module:'+Module.Name+#13#10+Module.Text+#13#10;
     Inc(I);
  End;
  AssignFile(T,'source.jsd');
  Rewrite(T);
  Writeln(T,Ws);
  CloseFile(T);
  SymbolTable.Print('Symbol.jsd');
  Postfix.Print('Postfix.jsd');
  StdDefinitionList.Print('StdDefinitionList.jsd');
  HostDefinitionList.Print('HostDefinitionList.jsd');
  PropDefList.Print('PropDefList.jsd');
  HostVariableList.Print('HostVariableList.jsd');
  ConstantList.Print('ConstantList.jsd');
{$ENDIF}
end;

function ToBoolean(const Value: TVariant): Boolean;
begin
  result := DXJS_CONV.ToBoolean(Value);
end;

function ToNumber(const Value: TVariant): Double;
begin
  result := DXJS_CONV.ToNumber(Value);
end;

function ToInteger(const Value: TVariant): Integer;
begin
  result := DXJS_CONV.ToInteger(Value);
end;

function ToString(const Value: TVariant): String;
begin
  Result := DXJS_CONV.ToStr(Value);
end;

function ToDelphiObject(Value: TVariant): TObject;
begin
  result := DXJS_CONV.ToDelphiObject(Value);
end;

function DelphiObjectToVariant(Instance: TObject): Variant;
begin
  result := DXJS_CONV.DelphiObjectToVariant(Instance);
end;

function GetProperty(const ScriptObject: Variant; PropertyName: String): Variant;
begin
  result := VariantToScriptObject(ScriptObject).GetProperty(PropertyName);
end;

function IsPrimitive(const Value: Variant): boolean;
begin
  result := VarType(Value) <> varScriptObject;
end;

procedure AddRTTIType(pti: PTypeInfo);
begin
  RTTITypeList.AddObject(pti^.Name, TObject(pti));
end;

initialization
  Initialization_Share;
  RTTITypeList := TStringList.Create;
  AddRTTIType(TypeInfo(TObject));
finalization
  Finalization_Share;
  RTTITypeList.Free;
end.