dxjs_postfix.pas

Well known and usefull component for delphi 7

      BoundStack.Push (CurrBoundStack) ;
      BoundStack.Push (CurrBoundTable) ;
      BoundStack.Push (SymbolTable.MemBoundVar) ;
      SymbolTable.AllocateSub (SubID) ;
      SymbolTable.PutValue (SymbolTable.GetThisID (SubID) ,This) ;
      CurrBoundStack:=Stack.Card-ParamCount;
      CurrBoundTable:=SymbolTable.Card;
   end;
end;

procedure TPostfix.OperRet;
var
   I,L,SubID:Integer;
   V:Variant;
   SO:TScriptObject;
   CallObject:TCallObject;
   Arguments:TArgumentsObject;
begin
   CallStack.Pop (SubID) ;
   with TJScript (JScript) .SymbolTable do
      if GetKind (SubID) =Kind_is_REF then begin
         SubID:=VariantToScriptObject (GetValue (SubID) ).SubID;
      end;
   V:=PopVariant;
   L:=PopID;
   PopID;// subID
   N:=TJScript (JScript) .SymbolTable.A[L].Entry;
   with TJScript (JScript) do begin
      SymbolTable.DeallocateSub (SubID) ;
      BoundStack.Pop (SymbolTable.MemBoundVar) ;
      BoundStack.Pop (CurrBoundTable) ;
      BoundStack.Pop (CurrBoundStack) ;
   end;
   SO:=VariantToScriptObject (TJScript (JScript) .SymbolTable.GetVariant (SubID) ) ;
   Arguments:=TArgumentsObject (VariantToScriptObject (SO.GetProperty ('arguments') ) ) ;
   CallObject:=CallStack.TopObject;
   if CallObject=nil then Arguments.PutProperty ('length',0)
   else
      if SubID=CallObject.SubID then begin// recursive call
      Arguments.PutProperty ('length',CallObject.ParamCount) ;
      for I:=0 to CallObject.ParamCount-1 do
         Arguments.PutProperty (IntegerToString (I) ,CallObject.Arguments[I]) ;
   end;
   RetVariant (V) ;
end;

procedure TPostfix.OperCreateObject;
var
   SO:TScriptObject;
   V:Variant;
   TypeID: Integer; //715
   TypeSO, PrototypeSO: TScriptObject; //715
begin
   SO:=TObjectObject.Create (JScript) ;
   SO.PScript:=JScript;
   V:=ScriptObjectToVariant (SO) ;
   RetVariant (V) ;
   //713 N:=N+1;
   Inc(N);
  //715
  TypeID := A[N];
  if TypeID > 0 then begin
    with TJScript(JScript) do V := SymbolTable.GetValue(TypeID);
    if IsObject(V) then begin
      TypeSO := VariantToScriptObject(V);
      if TypeSO.HasProperty('prototype') then begin
        V := TypeSO.GetProperty('prototype');
        if IsObject(V) then begin
          PrototypeSO := VariantToScriptObject(V);
          SO.Prototype := PrototypeSO;
        end;
      end;
    end;
  end;
end;

procedure TPostfix.OperCreateReference;
var
   V1,V2,Base:TVariant;
   PropertyName:string;
   I2,RefID:Integer;
begin
   V1:=PopVariant;// property name
   I2:=PopID;// base object
   V2:=TJScript (JScript) .SymbolTable.GetValue (I2) ;
   if VarType (V2) =varUndefined then
      with TJScript (JScript) .SymbolTable do begin
         I2:=LookUpID (GetName (I2) ,0) ;
         if I2>0 then V2:=GetValue (I2) ;
      end;
   Base:=ToObject (V2,JScript) ;
   PropertyName:=ToString (V1) ;
   with TJScript (JScript) .SymbolTable do begin
{$IFNDEF ECMA}
      if (GetKind (I2) =Kind_is_VAR) and (VarType (V2) =varString) then
         PutVariant (I2,Base) ;// convert to object
{$ENDIF}
      RefID:=AppReference (Base,PropertyName) ;
   end;
   Stack.Push (RefID) ;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperGetNextProp;
var
   ID,IDCounter:Integer;
   Base:Variant;
   PropertyName:string;
   Index:Integer;
begin
   IDCounter:=PopID;// counter
   Base:=ToObject (PopVariant,JScript) ;// object
   ID:=PopID;// property holder
   Index:=TJScript (JScript) .SymbolTable.GetVariant (IDCounter) ;
   PropertyName:=VariantToScriptObject (Base).GetPropertyName (Index) ;
   if PropertyName='' then begin
      TJScript (JScript) .SymbolTable.PutVariant (IDCounter,0) ;
      RetBoolean (false) ;
   end
   else begin
      TJScript (JScript) .SymbolTable.PutVariant (ID,PropertyName) ;
      TJScript (JScript) .SymbolTable.PutVariant (IDCounter,Index+1) ;
      RetBoolean (true) ;
   end;
   //713 N:=N+1;
   Inc(N);
end;

procedure TPostfix.OperExit;
begin
   while (A[N]<>OP_RET) and
      (A[N]<>OP_FINALLY) and
      (A[N]<>OP_HALT) do
      //713 N:=N+1;
      Inc(N);
end;

procedure TPostfix.OperCondExit;
begin
   if VarIsEmpty (TJScript (JScript) .Error) then N:=N+1
   else OperExit;
end;

procedure TPostfix.OperClearError;
begin
   VarClear (TJScript (JScript) .Error) ;
   //713 N:=N+1;
   Inc(N);
end;

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

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

procedure TPostfix.OperTryOn;
begin
   TryStack.Push (N,TJScript (JScript) .SymbolTable.A[PopID].Entry) ;
   //713 N:=N+1;
   Inc(N);
end;

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

procedure TPostfix.OperThrow;
begin
   TJScript (JScript) .Error:=PopVariant;
   OperRaise;
end;

procedure TPostfix.OperRaise;

   procedure AdjustStack;
   begin
      while Stack.Card>CurrBoundStack do Stack.Pop (DummyInt) ;
   end;

label
   Again;
begin
   AdjustStack;
   RetVariant (TJScript (JScript) .Error) ;
Again:
   while (A[N]<>OP_RET) and
      (A[N]<>OP_FINALLY) and
      (A[N]<>OP_CATCH) and
      (A[N]<>OP_HALT) do begin
      if A[N]=OP_TRY_ON then
         TryStack.Push (N,TJScript (JScript) .SymbolTable.A[A[N-1]].Entry )
      else if A[N]=OP_TRY_OFF then
         TryStack.Pop;
      //713 N:=N+1;
      Inc(N);
   end;
   Case A[N] of
      OP_RET:begin
         OperRet;
         AdjustStack;
         RetVariant (TJScript (JScript) .Error) ;
         goto Again;
      end;
      OP_CATCH:begin
         if TryStack.Legal (N) then Ok:=true
         else goto Again;
      end;
      OP_FINALLY:begin
         if not TryStack.Legal (N) then goto Again;
      end;
   End;
end;

procedure TPostfix.App (Const I:Integer) ;
begin
   //713 Card:=Card+1;
   Inc(Card);
   A[Card]:=I;
end;

procedure TPostfix.Print (const FileName:string) ;
var
   T:Text;
   I,J,K:Integer;
   Module:TModule;
   S:string;

begin
   Module:=nil;
   AssignFile (T,FileName) ;
   Rewrite (T) ;
   try
      for I:=1 to Card do begin
         J:=A[I];
         writeln (T,'') ;
         write (T,I:4,' ') ;
         if J>0 then begin
            write (T,J:5,' ') ;
            with TJScript (JScript) do begin
               write (T,Norm (SymbolTable.GetName (J) ,16) ,' ') ;
               if SymbolTable.GetKind (J) in [kind_is_LABEL,kind_is_SUB] then
                  write (T,SymbolTable.A[J].Entry :13,'^ ')
               else if SymbolTable.GetKind (J) =kind_is_CONST then
                  write (T,SymbolTable.GetStrVal (J) :15) ;
               write (T,'     ') ;
               write (T,SymbolTable.A[J].Level:6,' ') ;
            end;
         end
         else if J<=BOUND_FILES then begin
            K:=BOUND_FILES-J;
            Module:=TJScript (JScript) .Modules[K];
            if Module<>nil then
               write (T,'Module ',Norm (Module.Name,12) ,' **************************') ;
         end
         else if J<=BOUND_LINES then begin
            K:=BOUND_LINES-J;
            if Module<>nil then begin
               if (K>=0) and (K<Module.Count) then S:=Module.Strings[K]
               else S:='';
               write (T,'Line ',K:5,':'+S) ;
            end;
         end
         else begin
            write (T,GetOperName (J) ) ;
         end;
      end;
   finally
      Close (T) ;
   end;
end;

function TPostfix.GetModuleID (PCodeLine:Integer) :Integer;
begin
   while A[PCodeLine]>BOUND_FILES do Dec (PCodeLine) ;
   result:=BOUND_FILES-A[PCodeLine];
end;

function TPostfix.GetModuleLineID (PCodeLine:Integer) :Integer;
begin
   if PCodeLine<0 then raise TScriptFailure.Create (reRecompileRequested)
   else begin
      while A[PCodeLine]>BOUND_LINES do Dec (PCodeLine) ;
      result:=BOUND_LINES-A[PCodeLine];
   end;
end;

function TPostfix.Run (RunMode:Integer=rmRun) :boolean;
var
   CallStackCount,NextLine:Integer;

begin
   //713 N:=N+1;
   Inc(N);
   Case EvalCount of
      0:NextLine:=NextSourceLine
      Else NextLine:=-1;
   End;
   CurrBoundStack:=Stack.Card;
   CurrBoundTable:=TJScript (JScript) .SymbolTable.Card;
   CallStackCount:=CallStack.Count;
   //713 SubRunCount:=SubRunCount+1;
   Inc(SubRunCount);
   repeat
      repeat
         while A[N]<=BOUND_LINES do begin
            if (EvalCount=0) and
               ((RunMode<>rmRun) or
               (BreakpointList.Count>0)) then begin
               if BreakpointList.Count>0 then
                  if BreakpointList.IndexOf (Pointer (N) ) <>-1 then begin
                     result:=true;
                     Exit;
                  end;
               case RunMode of
                  rmTraceInto:
                     if IsSourceLine then begin
                        result:=true;
                        Exit;
                     end;
                  rmNextSourceLine:
                     if N=NextLine then begin
                        result:=true;
                        Exit;
                     end;
                  rmStepOver:
                     if IsSourceLine and (CallStack.Count<=CallStackCount) then begin
                        result:=true;
                        Exit;
                     end;
               end;
            end;
            //713 N:=N+1;
            Inc(N);
         end;
         while A[N]>0 do begin
            Stack.Push (A[N]) ;
            //713 N:=N+1;
            Inc(N);
         end;
         OP:=A[N];
      until OP>BOUND_LINES;
{$IFDEF TRACE}
      DXString.ShowMessageWindow('POSTFIX.RUN()',strOperations[abs(op-BOUND_OPER)]);
{$ENDIF}
      if OP=OP_NOP then Inc(N) // Dec 27 N:=N+1
      else begin
         try
            ArrProc[OP]; // actual instruction!
         except
            on E:TScriptFailure do begin
               E.Message:=RunErrors[E.Code];
               TJScript (JScript) .CreateErrorObject (E) ;
               Ok:=false;
               if TryStack.Card=0 then begin
                  result:=false;
                  Exit;
               end;
               OperRaise;
            end;
{$IFDEF SCRIPT_HANDLE_EXCEPTIONS}
            on E:Exception do begin
               TJScript (JScript) .CreateErrorObject (E) ;
               Ok:=false;
               if TryStack.Card=0 then begin
                  result:=false;
                  Exit;
               end;
               OperRaise;
            end;
{$ENDIF}
         end;
         if Stack.Card=CurrBoundStack then
            with TJScript (JScript) .SymbolTable do
               if Card>CurrBoundTable then EraseTail (CurrBoundTable) ;
         if TJScript (JScript) .ScriptState<>ss_Running then
            if SubRunCount=1 then Break;
      end;
   until OP=OP_HALT;
   Dec (SubRunCount) ;
   result:=Ok;
end;

function TPostfix.EndOfScript:boolean;
begin
   if (N>=1) and (N<=Card) then result:=A[N]=OP_HALT
   else
      if N=0 then result:=true
      else result:=false;
end;

function TPostfix.IsSourceLine:boolean;
begin
   if A[N]=OP_HALT then Result:=false
   Else result:= (A[N]<BOUND_LINES) and (A[N]>BOUND_FILES) and
      (A[N+1]>BOUND_LINES) ;
end;

function TPostfix.NextSourceLine:Integer;
var
   Temp:Integer;
begin
   if N>=Card then result:=-1
   Else Begin
      Temp:=N;
      //713 N:=N+1;
      Inc(N);
      while not IsSourceLine do //713 N:=N+1;
         Inc(N);
      result:=N;
      N:=Temp;
   end;
end;

procedure TPostfix.ResetRun;
begin
   N:=0;
   Stack.Clear;
   BoundStack.Clear;
   CallStack.Clear;
   WithStack.Clear;
   TryStack.Clear;
   BreakpointList.Clear;
end;

end.