dxjs_postfix.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: DXJS_POSTFIX
//       Author: Alexander Baranovsky ([e-mail])
//               G.E. Ozz Nixon Jr. ([e-mail])
// ========================================================================
// Source Owner: DX, Inc. 2002, 2004
//    Copyright: All code is the property of DX, Inc. Licensed for
//               resell by Brain Patchwork DX (tm) and part of the
//               DX (r) product lines, which are (c) 1999-2002
//               DX, Inc. Source may not be distributed without
//               written permission from both Brain Patchwork DX,
//               and DX, Inc.
//      License: (Reminder), None of this code can be added to other
//               developer products without permission. This includes
//               but not limited to DCU's, DCP's, DLL's, OCX's, or
//               any other form of merging our technologies. All of
//               your products released to a public consumer be it
//               shareware, freeware, commercial, etc. must contain a
//               license notification somewhere visible in the
//               application.
// Code Version: (3rd Generation)
// ========================================================================
//  Description: token code interpreter
// ========================================================================
////////////////////////////////////////////////////////////////////////////

unit DXJS_POSTFIX;

interface
{$I DXJavaScript.def}

uses
   Classes,
{$IFDEF VARIANTS}
   Variants,
{$ENDIF}
  DXJS_RESSTR,
  DXJS_SHARE,
  DXJS_LIST;

type
   TProc=procedure of object;

   TPostfix=class
      JScript:Pointer;
      A:array[1..MaxPostfix] of Integer;
      Card:Integer;
      OP:Integer;
      N,CurrBoundTable,CurrBoundStack,SubRunCount,EvalCount:Integer;
      Stack,BoundStack:TScriptStack; // object not TList
      CallStack:TCallStack; // TList
      WithStack:TWithStack; // object not TList
      TryStack:TTryStack; // object not TList
      ArrProc:array[BOUND_OPER-100..BOUND_OPER] of TProc;
      EvalRes:TVariant;
      Ok:boolean;
      BreakpointList:TBreakpointList;
      constructor Create (aJScript:Pointer) ; 
      destructor Destroy;override;
      procedure SaveToStream (S:TStream) ;
      procedure LoadFromStream (S:TStream) ;
      function GetModuleID (PCodeLine:Integer) :Integer;
      function GetModuleLineID (PCodeLine:Integer) :Integer;
      function IsSourceLine:boolean;
      function NextSourceLine:Integer;
      function EndOfScript:boolean;
      function Top:Integer;
      function PopID:Integer;
      function PopPopID:Integer;
      function PopVariant:TVariant;
      procedure RetVariant (const Value:TVariant) ;
      function PopBoolean:TBoolean;
      procedure RetBoolean (const Value:TBoolean) ;
      procedure RetInteger (const Value:TInteger) ;
      function Run (RunMode:Integer=rmRun) :boolean;
      procedure ResetRun;
      procedure OperPrint;
      procedure OperPause;
      procedure OperBeginWith;
      procedure OperEndWith;
      procedure OperEvalIdentifier;
      procedure OperSwap;
      procedure OperPopRet;
      procedure OperHalt;
      procedure OperStart;
      procedure OperCreateObject;
      procedure OperCreateReference;
      procedure OperGetNextProp;
      procedure OperSaveCall;
      procedure OperCall;
      procedure OperPassByVal;
      procedure OperRet;
      procedure OperExit;
      procedure OperCondExit;
      procedure OperFinally;
      procedure OperCatch;
      procedure OperTryOn;
      procedure OperTryOff;
      procedure OperRaise;
      procedure OperClearError;
      procedure OperThrow;
      procedure OperGo;
      procedure OperGoFalse;
      procedure OperUnary;
      procedure OperMultiplicative;
      procedure OperAdditive;
      procedure OperBitwiseShift;
      procedure OperRelational;
      procedure OperEquality;
      procedure OperBinaryBitwise;
      procedure OperBinaryLogical;
      procedure OperAssign;
      procedure App (Const I:Integer) ;
      procedure Print (const FileName:string) ;
   end;

implementation

uses
   DXString,
   SysUtils,// Exception, InToStr
   DXJS_MAIN,
   DXJS_EXTERN,
   DXJS_OBJECT,
   DXJS_CONV;

constructor TPostfix.Create;
var
   I:Integer;
begin
   JScript:=aJScript;
   Card:=0;
   N:=0;
   SubRunCount:=0;
   EvalCount:=0;
   Ok:=true;
   Stack:=TScriptStack.Create;
   BoundStack:=TScriptStack.Create;
   CallStack:=TCallStack.Create;
   WithStack:=TWithStack.Create;
   TryStack:=TTryStack.Create;
   BreakpointList:=TBreakpointList.Create;
   ArrProc[OP_PRINT]:=OperPrint;
   ArrProc[OP_PAUSE]:=OperPause;
   ArrProc[OP_BEGIN_WITH]:=OperBeginWith;
   ArrProc[OP_END_WITH]:=OperEndWith;
   ArrProc[OP_EVAL_IDENTIFIER]:=OperEvalIdentifier;
   ArrProc[OP_SWAP]:=OperSwap;
   ArrProc[OP_POP_RET]:=OperPopRet;
   ArrProc[OP_HALT]:=OperHalt;
   ArrProc[OP_START]:=OperStart;
   ArrProc[OP_CREATE_OBJECT]:=OperCreateObject;
   ArrProc[OP_CREATE_REFERENCE]:=OperCreateReference;
   ArrProc[OP_GET_NEXT_PROP]:=OperGetNextProp;
   ArrProc[OP_SAVE_CALL]:=OperSaveCall;
   ArrProc[OP_CALL]:=OperCall;
   ArrProc[OP_PASS_BY_VAL]:=OperPassByVal;
   ArrProc[OP_RET]:=OperRet;
   ArrProc[OP_EXIT]:=OperExit;
   ArrProc[OP_COND_EXIT]:=OperCondExit;
   ArrProc[OP_FINALLY]:=OperFinally;
   ArrProc[OP_CATCH]:=OperCatch;
   ArrProc[OP_TRY_ON]:=OperTryOn;
   ArrProc[OP_TRY_OFF]:=OperTryOff;
   ArrProc[OP_RAISE]:=OperRaise;
   ArrProc[OP_CLEAR_ERROR]:=OperClearError;
   ArrProc[OP_THROW]:=OperThrow;
   ArrProc[OP_GO]:=OperGo;
   ArrProc[OP_GO_FALSE]:=OperGoFalse;
   ArrProc[OP_DELETE]:=OperUnary;
   ArrProc[OP_VOID]:=OperUnary;
   ArrProc[OP_TYPEOF]:=OperUnary;
   ArrProc[OP_INC]:=OperUnary;
   ArrProc[OP_DEC]:=OperUnary;
   ArrProc[OP_PLUS1]:=OperUnary;
   ArrProc[OP_MINUS1]:=OperUnary;
   ArrProc[OP_BITWISE_NOT]:=OperUnary;
   ArrProc[OP_LOGICAL_NOT]:=OperUnary;
   ArrProc[OP_MULT]:=OperMultiplicative;
   ArrProc[OP_DIV]:=OperMultiplicative;
   ArrProc[OP_MOD]:=OperMultiplicative;
   ArrProc[OP_PLUS]:=OperAdditive;
   ArrProc[OP_MINUS]:=OperAdditive;
   ArrProc[OP_BITWISE_LEFT_SHIFT]:=OperBitwiseShift;
   ArrProc[OP_BITWISE_RIGHT_SHIFT]:=OperBitwiseShift;
   ArrProc[OP_BITWISE_UNSIGNED_RIGHT_SHIFT]:=OperBitwiseShift;
   ArrProc[OP_LT]:=OperRelational;
   ArrProc[OP_GT]:=OperRelational;
   ArrProc[OP_LE]:=OperRelational;
   ArrProc[OP_GE]:=OperRelational;
   ArrProc[OP_INSTANCEOF]:=OperRelational;
   ArrProc[OP_IN]:=OperRelational;
   ArrProc[OP_EQ]:=OperEquality;
   ArrProc[OP_NE]:=OperEquality;
   ArrProc[OP_ID]:=OperEquality;
   ArrProc[OP_NI]:=OperEquality;
   ArrProc[OP_BITWISE_OR]:=OperBinaryBitwise;
   ArrProc[OP_BITWISE_AND]:=OperBinaryBitwise;
   ArrProc[OP_BITWISE_XOR]:=OperBinaryBitwise;
   ArrProc[OP_LOGICAL_OR]:=OperBinaryLogical;
   ArrProc[OP_LOGICAL_AND]:=OperBinaryLogical;
   for I:=0 to AssignmentOperators.Count-1 do begin
      OP:=Integer (AssignmentOperators[I]) ;
      ArrProc[OP]:=OperAssign;
   end;
end;

destructor TPostfix.Destroy;
begin
   Stack.Free;
   BoundStack.Free;
   CallStack.Free;
   WithStack.Free;
   TryStack.Free;
   BreakpointList.Free;
   inherited;
end;

procedure TPostfix.SaveToStream (S:TStream) ;
begin
   SaveInteger (Card,S) ;
   S.WriteBuffer (A[1],SizeOf (A[1]) *Card) ;
end;

procedure TPostfix.LoadFromStream (S:TStream) ;
begin
   Card:=LoadInteger (S) ;
   S.ReadBuffer (A[1],SizeOf (A[1]) *Card) ;
end;

function TPostfix.Top:Integer;
var
   I:Integer;
begin
   I:=Card;
   if I>0 then begin
      result:=A[I];
      while (I>0) and (result<=BOUND_LINES) do begin
         Dec (I) ;
         result:=A[I];
         if I=0 then begin
            result:=0;
            Exit;
         end;
      end;
   end
   else result:=0;
end;

function TPostfix.PopID:Integer;
begin
   Stack.Pop (result) ;
end;

function TPostfix.PopPopID:Integer;
begin
   Stack.Pop (result) ;
   Stack.Pop (result) ;
end;

function TPostfix.PopVariant:TVariant;
begin
   result:=TJScript (JScript) .SymbolTable.GetValue (PopID) ;
end;

function TPostfix.PopBoolean:TBoolean;
begin
   result:=ToBoolean (PopVariant) ;
end;

procedure TPostfix.RetBoolean (const Value:TBoolean) ;
begin
   Stack.Push (TJScript (JScript) .SymbolTable.AppVariant (Value)) ;
end;

procedure TPostfix.RetInteger (const Value:TInteger) ;
begin
   Stack.Push (TJScript (JScript) .SymbolTable.AppVariant (Value)) ;
end;

procedure TPostfix.RetVariant (const Value:TVariant) ;
begin
   Stack.Push (TJScript (JScript) .SymbolTable.AppVariant (Value)) ;
end;

procedure TPostfix.OperPrint;
begin
   if isConsole then writeln (DXJS_MAIN.ToString (PopVariant)) ;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperBeginWith;
begin
   WithStack.Push (ToObject (PopVariant,JScript)) ;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperEndWith;
begin
   WithStack.Pop;
   //713 N:=N+1;
   Inc(N);
end;

(* 910 - replaced - to support: with(object) { newproprty=something; } code
procedure TPostfix.OperEvalIdentifier;
var
   Loop,ID:Integer;
   PropertyName:string;
begin
{$IFDEF CODE_TRACER}
   DXCodeTracer.SendMessage(dxctInfo,'TPostFix.OperEvalIdentified');
{$ENDIF}
   ID:=PopID;
   PropertyName:=TJScript (JScript) .SymbolTable.GetName (ID) ;
   for Loop:=WithStack.Card downto 1 do begin
      if VariantToScriptObject (WithStack.A[Loop]).HasProperty (PropertyName) then begin
         ID:=TJScript (JScript) .SymbolTable.AppReference (WithStack.A[Loop],PropertyName) ;
         break;
      end;
   end;
   Stack.Push (ID) ;
   //713 N:=N+1;
   Inc(N);
end;
*)

procedure TPostfix.OperEvalIdentifier;
var
  I, ID: Integer;
  PropertyName: String;
begin
  ID := PopID;
  PropertyName := TJScript(JScript).SymbolTable.GetName(ID);
  If TJScript(JScript).SymbolTable.GetKind(ID)= Kind_is_Const then begin
     for I:=WithStack.Card downto 1 do begin
        ID := TJScript(JScript).SymbolTable.AppReference(WithStack.A[I],PropertyName);
        break;
     end;
  end;
  Stack.Push(ID);
  Inc(N);
end;

procedure TPostfix.OperPause;
begin
   TJScript (JScript) .Print;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperSwap;
begin
   Stack.Swap;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperUnary;
var
   V:Variant;
   I:Integer;
   B:Boolean;
begin
   I:=PopID;
   V:=TJScript (JScript) .SymbolTable.GetValue (I) ;
   Case OP of
      OP_INC:begin
         V:=ToNumber (V) ;
         Inc (V) ;
         if Assigned (TJScript (JScript) .fOnChangedVariable) then
            TJScript (JScript) .fOnChangedVariable (TJScript (JScript) .Owner,
               TJScript (JScript) .SymbolTable.GetName (I) ,V) ;
         TJScript (JScript) .SymbolTable.PutValue (I,V) ;
         Stack.Push (I) ;
      end;
      OP_DEC:begin
         V:=ToNumber (V) ;
         Dec (V) ;
         if Assigned (TJScript (JScript) .fOnChangedVariable) then
            TJScript (JScript) .fOnChangedVariable (TJScript (JScript) .Owner,
               TJScript (JScript) .SymbolTable.GetName (I) ,V) ;
         TJScript (JScript) .SymbolTable.PutValue (I,V) ;
         Stack.Push (I) ;
      end;
      OP_PLUS1:begin
         V:=ToNumber (V) ;
         V:=+V;
         RetVariant (V) ;
      end;
      OP_MINUS1:begin
         V:=ToNumber (V) ;
         V:=-V;
         RetVariant (V) ;
      end;
      OP_BITWISE_NOT:begin
         I:=ToInt32 (V) ;
         I:=not I;
         V:=I;
         RetVariant (V) ;
      end;
      OP_LOGICAL_NOT:begin
         B:=ToBoolean (V) ;
         B:=not B;
         V:=B;
         RetVariant (V) ;
      end;
      OP_TYPEOF:begin
         if TJScript (JScript) .SymbolTable.GetKind (I) =kind_is_SUB then
            RetVariant ('function')
         else if VarIsEmpty (V) then
            RetVariant ('undefined')
         else case TVarData (V) .VType of
   varDouble,varInteger, {original 2 types}
   {varSmallInt,}varSingle,varCurrency,{varShortInt}$0010,{varWord}$0012,{varLongWord}$0013,{varInt64}$0014,varDate:
            RetVariant ('number');
            varString:RetVariant ('string');
            varBoolean:RetVariant ('boolean');
{OZZ}
            varOleStr,varDispatch,varError{,varByte},
               varAny,varArray,varByRef:RetVariant('Delphi Variant');
{OZZ}
            else
               RetVariant ('object')
            end; {case}
      end;
      OP_DELETE:RetVariant (TJScript (JScript) .SymbolTable.Delete (I) );
      OP_VOID:RetVariant (Undefined) ;
   End;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperMultiplicative;
var