dxjs_postfix.pas

Well known and usefull component for delphi 7

   V1,V2:TVariant;
begin
   V1:=ToNumber (PopVariant) ;
   V2:=ToNumber (PopVariant) ;
   Case OP of
      OP_MULT:RetVariant (V2*V1);
      OP_DIV:begin
         if V1=0 then RetVariant (NaN)
         else RetVariant (V2/V1) ;
      end;
      else // OP = OP_MOD
         RetVariant (V2 mod V1) ;
   End;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperAdditive;
var
   V1,V2:TVariant;
begin
   V1:=PopVariant;
   V2:=PopVariant;
   if OP=OP_PLUS then begin
{$IFNDEF ECMA}
      if IsArray (V1) and IsArray (V2) then begin
         RetVariant (AddSets (V2,V1,JScript) ) ;
         //713 N:=N+1;
         Inc(N);
         Exit;
      end;
{$ENDIF}
      V1:=ToPrimitive (V1) ;
      V2:=ToPrimitive (V2) ;
      if (VarType (V1) =varString) or (VarType (V2) =varString) then begin
         V1:=ToString (V1) ;
         V2:=ToString (V2) ;
      end
      else begin
         V1:=ToNumber (V1) ;
         V2:=ToNumber (V2) ;
      end;
      RetVariant (V2+V1) ;
   end
   else begin// OP = OP_MINUS
{$IFNDEF ECMA}
      if IsArray (V1) and IsArray (V2) then begin
         RetVariant (SubSets (V2,V1,JScript) ) ;
         //713 N:=N+1;
         Inc(N);
         Exit;
      end;
{$ENDIF}
      V1:=ToNumber (V1) ;
      V2:=ToNumber (V2) ;
      RetVariant (V2-V1) ;
   end;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperBitwiseShift;
var
   V1,V2,V3:TInteger;
begin
   V1:=ToInt32 (PopVariant) ;
   V2:=ToInt32 (PopVariant) ;
   Case OP of
      OP_BITWISE_LEFT_SHIFT:V3:=V2 shl V1;
      OP_BITWISE_RIGHT_SHIFT:V3:=_shr (V2,V1);
      else // OP = OP_BITWISE_UNSIGNED_RIGHT_SHIFT
         V3:=V2 shr V1;
   End;
   RetInteger (V3) ;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperRelational;
var
   R,V1,V2:TVariant;
begin
   V1:=PopVariant;
   V2:=PopVariant;
   Case OP of
      OP_LT:RetVariant (RelationalComparison (V2,V1) );
      OP_GT:begin
         R:=RelationalComparison (V1,V2) ;
         if IsUndefined (R) then RetVariant (false)
         else RetVariant (R) ;
      end;
      OP_LE:begin
         R:=RelationalComparison (V1,V2) ;
         if IsUndefined (R) then RetVariant (false)
         else if IsBoolean (R) then RetVariant (not R)
         else RetVariant (true) ;
      end;
      OP_GE:begin
         R:=RelationalComparison (V2,V1) ;
         if IsUndefined (R) then RetVariant (false)
         else if IsBoolean (R) then RetVariant (not R)
         else RetVariant (true) ;
      end;
      OP_IN:begin
         RetBoolean (VariantToScriptObject (V1).HasProperty (ToString (V2) ) ) ;
      end;
      OP_INSTANCEOF:begin
         RetBoolean (VariantToScriptObject (V1).ClassProp=VariantToScriptObject (V2).ClassProp) ;
      end;
   End;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperEquality;
var
   V1,V2:TVariant;
begin
   V1:=PopVariant;
   V2:=PopVariant;
   Case OP of
      OP_EQ:RetBoolean (EqualityComparison (V1,V2) );
      OP_NE:RetBoolean (not EqualityComparison (V1,V2) );
      OP_ID:RetBoolean (StrictEqualityComparison (V1,V2) );
      else // if OP = OP_NI
         RetBoolean (not StrictEqualityComparison (V1,V2) ) ;
   end;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperBinaryBitwise;
var
   V1,V2:TInteger;
begin
   V1:=ToInt32 (PopVariant) ;
   V2:=ToInt32 (PopVariant) ;
   Case OP of
      OP_BITWISE_OR:RetInteger (V1 or V2);
      OP_BITWISE_AND:RetInteger (V1 and V2);
      else // OP = OP_BITWISE_XOR
         RetInteger (V1 xor V2) ;
   End;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperBinaryLogical;
var
   V1,V2:TBoolean;
begin
   V1:=PopBoolean;
   V2:=PopBoolean;
   if OP=OP_LOGICAL_OR then RetBoolean (V1 or V2)
   else // OP = OP_LOGICAL_AND
      RetBoolean (V1 and V2) ;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostFix.OperAssign;
var
   I1,I2:Integer;
   V1,V2,V3:TVariant;
   _IsDate: Boolean;
begin
   Stack.Pop (I1) ;//right
   with TJScript (JScript) .SymbolTable do begin
      V1:=GetValue (I1) ;
      if VarType (V1) =varUndefined then begin
         I1:=LookUpID (GetName (I1) ,0) ;
         if I1>0 then
            V1:=GetValue (I1) ;
      end;
   end;
   Stack.Pop (I2) ;//left
   with TJScript (JScript) .SymbolTable do begin
      if OP=OP_ASSIGN then V3:=V1
      else V2:=GetValue (I2) ; _IsDate := IsDate(V2);
      Case OP of
         OP_ASSIGN_PLUS:begin
            if IsArray (V1) and IsArray (V2) then  V3:=AddSets(V2,V1,JScript)
            else begin
               V1:=ToPrimitive (V1) ;
               V2:=ToPrimitive (V2) ;
               if (VarType (V1) =varString) or (VarType (V2) =varString) then begin
                  V1:=ToString (V1) ;
                  V2:=ToString (V2) ;
               end
               else begin
                  V1:=ToNumber (V1) ;
                  V2:=ToNumber (V2) ;
               end;
               if _IsDate then
                 V3:=IncDate(V2, ToInt32(V1))
               else
                 V3:=V2+V1;
            end;
         end;
         OP_ASSIGN_MINUS:begin
            if IsArray (V1) and IsArray (V2) then V3:=SubSets
(V2,V1,JScript)
            else begin
               V1:=ToNumber (V1) ;
               V2:=ToNumber (V2) ;
               if _IsDate then V3:=IncDate(V2, - ToInt32(V1))
               else V3:=V2-V1;
            end;
         end;
         OP_ASSIGN_MULT:V3:=ToNumber (V2) *ToNumber (V1);
         OP_ASSIGN_DIV:begin
            V1:=ToNumber (V1) ;
            V2:=ToNumber (V2) ;
            if V1=0 then V3:=NaN
            else V3:=V2/V1;
         end;
         OP_ASSIGN_BITWISE_AND:V3:=ToInteger (V2) and ToInteger (V1);
         OP_ASSIGN_BITWISE_OR:V3:=ToInteger (V2) or ToInteger (V1);
         OP_ASSIGN_BITWISE_LEFT_SHIFT:V3:=ToInteger (V2) shl ToInteger (V1);
         OP_ASSIGN_BITWISE_RIGHT_SHIFT:V3:=_shr (ToInteger (V2) ,ToInteger(V1) );
         OP_ASSIGN_BITWISE_UNSIGNED_RIGHT_SHIFT:V3:=ToInteger (V2) shr ToInteger (V1);
         OP_ASSIGN_BITWISE_XOR:V3:=ToInteger (V2) xor ToInteger (V1);
         OP_ASSIGN_MOD:V3:=ToInteger (V2) mod ToInteger (V1) ;
      End; {case}
      if Assigned (TJScript (JScript) .fOnChangedVariable) then
         TJScript (JScript) .fOnChangedVariable (TJScript (JScript) .Owner,
            TJScript (JScript) .SymbolTable.GetName (I2) ,V3) ;
      PutValue (I2,V3) ;
   end;
   Stack.Push (I2) ;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperPopRet;
var
   I:Integer;
begin
   Stack.Pop (I) ;
   //713 N:=N+1;
   Inc(N);
   if (EvalCount>0) and (I>0) then EvalRes:=TJScript (JScript) .SymbolTable.GetValue (I) ;
end;

procedure TPostfix.OperGo;
var
   L:Integer;
begin
   Stack.Pop (L) ;
   N:=TJScript (JScript) .SymbolTable.A[L].Entry;
end;

procedure TPostfix.OperGoFalse;
var
   I,L:Integer;
begin
   Stack.Pop (L) ;// label
   Stack.Pop (I) ;// expression
   if TVariant (TJScript (JScript) .SymbolTable.A[I].Address^) <>0 then N:=N+1
   else N:=TJScript (JScript) .SymbolTable.A[L].Entry;
end;

procedure TPostfix.OperHalt;
begin
end;

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

procedure TPostfix.OperSaveCall;
begin
   CallStack.Push (Stack.Top) ;
   CallStack.TopObject.N:=N;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperPassByVal;
var
   I1:Integer;
   A2:Pointer;
begin
   I1:=PopID;// formal parameter id
   Stack.Pop (Integer (A2) ) ;
   with TJScript (JScript) .SymbolTable do begin
      if A[I1].PType<>type_is_VARIANT then raise TScriptFailure.Create (reIncompatibleTypes) ;
      Variant (A[I1].Address^) :=Variant (A2^) ;
   end;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperCall;

   function FindThisID (SubID:Integer) :Integer;
   var
      I,J,ID:Integer;
      V:Variant;
   begin
      with TJScript (JScript) .SymbolTable do begin
         result:=GetThisID (SubID) ;
         for I:=Stack.Card downto 1 do
            if Stack.A[I]>0 then
               if GetKind (Stack.A[I]) =Kind_is_LABEL then begin
                  J:=I-2;
                  if J>=1 then begin
                     ID:=Stack.A[J];
                     if ID>0 then
                        if GetKind (ID) =Kind_is_VAR then begin
                           V:=GetVariant (ID) ;
                           if VarType (V) =varScriptObject then
                              result:=ID;
                        end;
                  end;
                  break;
               end;
      end;
   end;

var
   I,SubID,ParamCount,ID,N1,ThisID:Integer;
   List:TList;
   V,This:Variant;
   SO:TScriptObject;
   CallAddr:Pointer;
   Arguments:TArgumentsObject;
   ClsName,MethName:string;

begin
   CallAddr:=nil;
   ParamCount:=PopVariant;
   N1:=N+1;
   SubID:=CallStack.TopObject.SubID;
   with TJScript (JScript) .SymbolTable do Begin
      Case getKind(SubID) of
         Kind_is_REF:begin
            ThisID:=SubID;
            This:=GetBase (SubID) ;
            SO:=VariantToScriptObject (This) ;
            ClsName:=SO.ClassProp;
            MethName:=GetName (SubID) ;
            if StrEql (ClsName,'ActiveX') then begin
try
               InvokeDisp (SO,MethName,ParamCount) ;
finally
               CallStack.Pop (SubID) ;
               N:=N1;
end;
               Exit;
            end;
            V:=GetValue (SubID) ;
            if VarType (V) =varUndefined then begin
               SubID:=LookUpID (GetName (SubID) ,0) ;
               if SubID=0 then raise TScriptFailure.Create (reFunctionNotFound) ;
               V:=GetValue (SubID) ;
               CallStack.TopObject.SubID:=SubID;
            end;
            SO:=VariantToScriptObject (V) ;
            SubID:=SO.SubID;
            CallAddr:=SO.CallAddr;
         end;
         Kind_is_VAR:begin
            V:=GetValue (SubID) ;
            if VarType (V) =varUndefined then begin
               SubID:=LookUpID (GetName (SubID) ,0) ;
               if SubID=0 then raise TScriptFailure.Create (reFunctionNotFound) ;
               V:=GetValue (SubID) ;
               CallStack.TopObject.SubID:=SubID;
            end;
            SO:=VariantToScriptObject (V) ;
            CallAddr:=SO.CallAddr;
            if SO.SubID>0 then SubID:=SO.SubID;
            ThisID:=FindThisID (SubID) ;
            if ThisID=0 then ThisID:=GetThisID (SubID) ;
            if ThisID=0 then This:=Undefined
            else This:=GetVariant (ThisID) ;
         end;
         else begin
            V:=GetValue (SubID) ;
            if VarType (V) =varScriptObject then begin
               SO:=VariantToScriptObject (V) ;
               CallAddr:=SO.CallAddr;
            end;
            ThisID:=FindThisID (SubID) ;
            if ThisID=0 then ThisID:=GetThisID (SubID) ;
            if ThisID=0 then This:=Undefined
            else This:=GetVariant (ThisID) ;
         end;
      end;
   End;
   N:=TJScript (JScript) .SymbolTable.A[SubID].Entry;
   if N<=0 then begin
      try
         if VarType (This) =varEmpty then
            This:=ScriptObjectToVariant (TJScript (JScript) .GlobalObject) ;
         Invoke (JScript,CallAddr,This,ParamCount,SO.KindProc) ;
         if ThisID>0 then
            TJScript (JScript) .SymbolTable.PutVariant (ThisID,This) ;
      finally
         CallStack.Pop (SubID) ;
         N:=N1;
      end;
      Exit;
   end;
   with TJScript (JScript) .SymbolTable do begin
      while ParamCount<A[SubID].Count do begin
         Stack.Push (UndefinedID) ;
         //713 ParamCount:=ParamCount+1;
         Inc(ParamCount);
      end;
//715      while ParamCount>A[SubID].Count do begin
//715         Stack.Pop (DummyInt) ;
//715         //713 ParamCount:=ParamCount-1;
//715         Dec(ParamCount);
//715      end;
   end;
   SetLength (CallStack.TopObject.Arguments,ParamCount) ;
   SO:=VariantToScriptObject (TJScript (JScript) .SymbolTable.GetVariant (SubID) ) ;
   Arguments:=TArgumentsObject (VariantToScriptObject (SO.GetProperty ('arguments') ) ) ;
   Arguments.PutProperty ('length',ParamCount) ;
   if ParamCount>0 then begin// reverse the actual parameter list
      List:=TList.Create;
      for I:=1 to ParamCount do List.Add (Pointer (PopID) ) ;
      for I:=0 to ParamCount-1 do begin
         ID:=Integer (List[I]) ;
         if I < TJScript(JScript).SymbolTable.A[SubID].Count then //715
            Stack.Push (Integer (TJScript (JScript) .SymbolTable.A[ID].Address ) ) ;
         V:=TJScript (JScript) .SymbolTable.GetVariant (ID) ;
         CallStack.TopObject.Arguments[ParamCount-I-1] := V; //715
         Arguments.Put(IntegerToString(ParamCount-I-1), V); //715
      end;
      List.Free;
   end;
   with TJScript (JScript) do begin