dxjs_share.pas

Well known and usefull component for delphi 7

   if OP=0 then result:='UNKNOWN'
   else result:=strOpers[ABS(OP)+BOUND_OPER ];
end;

function VariantToString (const Value:Variant) :string;
Const
   TrueFalse:Array[false..true] of String=('false','true');

var
   Date:TDateTime;

begin
   case VarType (Value) of
      varEmpty:result:='undefined';
      varNull:result:='null';
      varError:result:='Error:'+IntegerToString (TVarData (Value) .VError) ;
      varDispatch:result:='Dispatch:'+Format ('%p', [TVarData (Value) .VDispatch]) ;
      varDate:begin
            Date:=ToNumber (Value) ;
            Result:=FormatDateTime ('ddd mmm d h:nn:ss @ yyyy',Date) ;
            Result:=StringReplace (Result,'@',DXString.ShortTimeZone, []) ;
         end;
      varBoolean:begin
            Result:=TrueFalse[Boolean(Value)];
         end;
   else
      Result := Value;
   end;
end;

function Norm (const S:string;L:Integer) :string;
begin
   result:=Copy (S,1,L) ;
   while Length (result) <L do result:=result+' ';
end;

function ShiftPointer (P:Pointer;D:Integer) :Pointer;
begin
   result:=Pointer (Integer (P) +D) ;
end;

function GetStrTokenClass (Token:TToken) :string;
var
   I:Integer;
begin
   I:=Ord (Token.AClass) ;
   result:=StrTokenClass[I];
end;

procedure ErrMessageBox (const S:string) ;
begin
{$IFDEF WIN32}
   MessageBox (GetActiveWindow () ,PChar (S) ,PChar ('DXJavaScript') ,MB_ICONEXCLAMATION or MB_OK) ;
{$ENDIF}
{$IFDEF LINUX}
   DXString.ShowMessageWindow(PChar (S) ,'DXJavaScript');
{$ENDIF}
end;

constructor TScriptFailure.Create (InitCode:Cardinal) ;
begin
   Code:=InitCode;
end;

function TParseErrors.App (const Msg:string;Match:Integer) :Integer;
var
   ParseError:TParseError;

begin
   ParseError:=TParseError.Create;
   ParseError.Msg:=Msg;
   ParseError.Match:=Match;
   result:=Add (Pointer (ParseError) ) ;
end;

function TParseErrors.GetCode (Match:Integer) :Integer;
var
   I:Integer;

begin
   result:=-1;
   for I:=0 to Count-1 do
      if TParseError (Items[I]) .Match=Match then begin
         result:=I;
         Exit;
      end;
end;

function TParseErrors.GetMessage (Code:Integer) :string;
begin
   result:='Unknown error';
   if (Code>=0) and (Code<Count) then result:=TParseError (Items[Code]) .Msg;
end;

constructor TBaseTypes.Create;
begin
   Card:=0;
end;

function TBaseTypes.App (const Name:string;Size:Integer) :Integer;
begin
   Inc (Card) ;
   A[Card].Name:=Name;
   A[Card].Size:=Size;
   result:=Card;
end;

function TBaseTypes.GetSize (AType:Integer) :Integer;
begin
   result:=-1;
   if (AType>=1) and (AType<=Card) then result:=A[AType].Size;
end;

function IsStandardClass (ClassID:Integer) :Boolean;
begin
   result:= (ClassID>=0) and (ClassID<StandardClasses.Count) ;
end;

type
   TBits=class
   private
      FSize:Integer;
      FBits:Pointer;
      procedure Error;
      procedure SetSize (Value:Integer) ;
      procedure SetBit (Index:Integer;Value:Boolean) ;
      function GetBit (Index:Integer) :Boolean;
   public
      destructor Destroy;override;
      function OpenBit:Integer;
      property Bits[Index:Integer]:Boolean read GetBit write SetBit;default;
      property Size:Integer read FSize write SetSize;
   end;

{ TBits }

const
   BitsPerInt=SizeOf (Integer) *8;

type
   TBitEnum=0..BitsPerInt-1;
   TBitSet=set of TBitEnum;
   PBitArray=^TBitArray;
   TBitArray=array[0..4096] of TBitSet;

destructor TBits.Destroy;
begin
   SetSize (0) ;
   inherited Destroy;
end;

procedure TBits.Error;
begin
end;

procedure TBits.SetSize (Value:Integer) ;
var
   NewMem:Pointer;
   NewMemSize:Integer;
   OldMemSize:Integer;

   function Min (X,Y:Integer) :Integer;
   begin
      Result:=X;
      if X>Y then Result:=Y;
   end;

begin
   if Value<>Size then begin
      if Value<0 then Error;
      NewMemSize:= ((Value+BitsPerInt-1) div BitsPerInt) *SizeOf (Integer) ;
      OldMemSize:= ((Size+BitsPerInt-1) div BitsPerInt) *SizeOf (Integer) ;
      if NewMemSize<>OldMemSize then begin
         NewMem:=nil;
         if NewMemSize<>0 then begin
            GetMem (NewMem,NewMemSize) ;
            FillChar2 (NewMem^,NewMemSize,#0) ;
         end;
         if OldMemSize<>0 then begin
            if NewMem<>nil then
               FastMove (FBits^,NewMem^,Min (OldMemSize,NewMemSize) ) ;
            FreeMem (FBits,OldMemSize) ;
         end;
         FBits:=NewMem;
      end;
      FSize:=Value;
   end;
end;

procedure TBits.SetBit (Index:Integer;Value:Boolean) ;assembler;
asm
        CMP     Index,[EAX].FSize
        JAE     @@Size

@@1:    MOV     EAX,[EAX].FBits
        OR      Value,Value
        JZ      @@2
        BTS     [EAX],Index
        RET

@@2:    BTR     [EAX],Index
        RET

@@Size: CMP     Index,0
        JL      TBits.Error
        PUSH    Self
        PUSH    Index
        PUSH    ECX {Value}
        INC     Index
        CALL    TBits.SetSize
        POP     ECX {Value}
        POP     Index
        POP     Self
        JMP     @@1
end;

function TBits.GetBit (Index:Integer) :Boolean;assembler;
asm
        CMP     Index,[EAX].FSize
        JAE     TBits.Error
        MOV     EAX,[EAX].FBits
        BT      [EAX],Index
        SBB     EAX,EAX
        AND     EAX,1
end;

function TBits.OpenBit:Integer;
var
   I:Integer;
   B:TBitSet;
   J:TBitEnum;
   E:Integer;
begin
   E:= (Size+BitsPerInt-1) div BitsPerInt-1;
   for I:=0 to E do
      if PBitArray (FBits) ^[I]<> [0..BitsPerInt-1] then begin
         B:=PBitArray (FBits) ^[I];
         for J:=Low (J) to High (J) do begin
            if not (J in B) then begin
               Result:=I*BitsPerInt+J;
               if Result>=Size then Result:=Size;
               Exit;
            end;
         end;
      end;
   Result:=Size;
end;

function _Shr (X,Y:Integer) :Variant;
var
   Bits:TBits;
   I:Integer;
begin
   result:=X shr Y;
   if X>=0 then Exit;
   if Y<0 then result:=NaN
   else Begin
      Bits:=TBits.Create;
      Bits.Size:=32;
      Integer (Bits.FBits^) :=result;
      for I:=31 downto 32-Y do Bits[I]:=true;
      result:=Integer (Bits.FBits^) ;
      Bits.Free; // Sept 12 2003
   End;
end;

function HashNumber (const S:string) :Integer;
var
   I,J:Integer;
begin
   if Length (S) =0 then result:=-1
   Else Begin
      I:=0;
      for J:=1 to Length (S) do begin
         I:=I shl 1;
         I:=I xor ord (S[J]) ;
      end;
      if I<0 then I:=-I;
      result:=I mod MaxHash;
   End;
end;

function IncDate(D: Double; I: Integer): TDateTime;
var
  T: TTimeStamp;
begin
  T := DateTimeToTimeStamp(D);
  Inc(T.Time, I);
  result := TimeStampToDateTime(T);
end;


procedure Initialization_Share;
begin
   StandardClasses:=TStandardClasses.Create;
   with StandardClasses do begin
      String_ID:=Add ('String') ;
      Number_ID:=Add ('Number') ;
      Boolean_ID:=Add ('Boolean') ;
      Date_ID:=Add ('Date') ;
      Array_ID:=Add ('Array') ;
      Math_ID:=Add ('Math') ;
      RegExp_ID:=Add ('RegExp') ;
      Function_ID:=Add ('Function') ;
      Error_ID:=Add ('Error') ;
      DelphiObject_ID:=Add ('DelphiObject') ;
      ActiveXObject_ID:=Add ('ActiveXObject') ;
      EnumeratorObject_ID:=Add ('Enumerator') ;
   end;

{   Keywords:=TKeywords.Create;
   WD_BREAK:=BOUND_KEYWORD-Keywords.Add ('break') ;
   WD_CASE:=BOUND_KEYWORD-Keywords.Add ('case') ;
   WD_CATCH:=BOUND_KEYWORD-Keywords.Add ('catch') ;
   WD_CONTINUE:=BOUND_KEYWORD-Keywords.Add ('continue') ;
   WD_DEBUGGER:=BOUND_KEYWORD-Keywords.Add ('debugger') ;
   WD_DEFAULT:=BOUND_KEYWORD-Keywords.Add ('default') ;
   WD_DELETE:=BOUND_KEYWORD-Keywords.Add ('delete') ;
   WD_DO:=BOUND_KEYWORD-Keywords.Add ('do') ;
   WD_ELSE:=BOUND_KEYWORD-Keywords.Add ('else') ;
   WD_FINALLY:=BOUND_KEYWORD-Keywords.Add ('finally') ;
   WD_FOR:=BOUND_KEYWORD-Keywords.Add ('for') ;
   WD_FUNCTION:=BOUND_KEYWORD-Keywords.Add ('function') ;
   WD_IF:=BOUND_KEYWORD-Keywords.Add ('if') ;
   WD_IN:=BOUND_KEYWORD-Keywords.Add ('in') ;
   WD_INSTANCEOF:=BOUND_KEYWORD-Keywords.Add ('instanceof') ;
   WD_NEW:=BOUND_KEYWORD-Keywords.Add ('new') ;
   WD_PRINT:=BOUND_KEYWORD-Keywords.Add ('print') ;
   WD_PAUSE:=BOUND_KEYWORD-Keywords.Add ('pause') ;
   WD_RETURN:=BOUND_KEYWORD-Keywords.Add ('return') ;
   WD_SWITCH:=BOUND_KEYWORD-Keywords.Add ('switch') ;
   WD_THROW:=BOUND_KEYWORD-Keywords.Add ('throw') ;
   WD_TRY:=BOUND_KEYWORD-Keywords.Add ('try') ;
   WD_TYPEOF:=BOUND_KEYWORD-Keywords.Add ('typeof') ;
   WD_VAR:=BOUND_KEYWORD-Keywords.Add ('var') ;
   WD_VOID:=BOUND_KEYWORD-Keywords.Add ('void') ;
   WD_WHILE:=BOUND_KEYWORD-Keywords.Add ('while') ;
   WD_WITH:=BOUND_KEYWORD-Keywords.Add ('with') ;
}
   BaseTypes:=TBaseTypes.Create;
   type_is_VARIANT:=BaseTypes.App ('VARIANT',SizeOf (TVariant) ) ;

   AssignmentOperators:=TAssignmentOperators.Create;
   AssignmentOperators.Add (Pointer (OP_ASSIGN) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_PLUS) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_MINUS) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_MULT) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_DIV) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_MOD) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_BITWISE_AND) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_BITWISE_OR) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_BITWISE_LEFT_SHIFT) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_BITWISE_RIGHT_SHIFT) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_BITWISE_UNSIGNED_RIGHT_SHIFT) ) ;
   AssignmentOperators.Add (Pointer (OP_ASSIGN_BITWISE_XOR) ) ;

   ParseErrors:=TParseErrors.Create;
   peSyntaxError:=ParseErrors.App (SpeSyntaxError,0) ;
   peIdentifierExpected:=ParseErrors.App (SpeIdentifierExpected,0) ;
   peIdentifierRedeclared:=ParseErrors.App (SpeIdentifierRedeclared,0) ;
   peInvalidCompilerDirective:=ParseErrors.App (SpeInvalidCompilerDirective,0) ;
   peMissingENDIFdirective:=ParseErrors.App (SpeMissingENDIFdirective,0) ;
   peOutsideOfLoop:=ParseErrors.App (SpeOutsideOfLoop,0) ;
   peLabelNotFound:=ParseErrors.App (SpeLabelNotFound,0) ;
   peCannotAssign:=ParseErrors.App (SpeCannotAssign,0) ;

   ParseErrors.App (SpeSemicolonexpected,SP_SEMICOLON) ;
   ParseErrors.App (SpeEqualsSignexpected,OP_ASSIGN) ;
   ParseErrors.App (SpeRoundBracketLeftexpected,SP_ROUND_BRACKET_L) ;
   ParseErrors.App (SpeRoundBracketRightexpected,SP_ROUND_BRACKET_R) ;
   ParseErrors.App (SpeBracketLeftexpected,SP_BRACKET_L) ;
   ParseErrors.App (SpeBracketRightexpected,SP_BRACKET_R) ;
   ParseErrors.App (SpeBraceLeftExpected,SP_BRACE_L) ;
   ParseErrors.App (SpeBraceRightExpected,SP_BRACE_R) ;
   ParseErrors.App (SpeColonExpected,SP_COLON) ;
   ParseErrors.App (SpeWHILEexpected,WD_WHILE) ;
   ParseErrors.App (SpeCATCHexpected,WD_CATCH) ;

   RunErrors:=TRunErrors.Create;
   reVarNotArray:=RunErrors.Add (SreVarNotArray) ;
   reVarArrayBounds:=RunErrors.Add (SreVarArrayBounds) ;
   reIncompatibleTypes:=RunErrors.Add (SpeIncompatibleTypes) ;
   reFunctionNotFound:=RunErrors.Add (SreFunctionNotFound) ;
   reReferenceError:=RunErrors.Add (SreReferenceError) ;
   reRecompileRequested:=RunErrors.Add (SreRecompileRequested) ;
   Undefined:=Unassigned;
end;

procedure Finalization_Share;
begin
   StandardClasses.Free;
   AssignmentOperators.Free;
   ParseErrors.Free;
   RunErrors.Free;
   BaseTypes.Free;
end;

end.