dxjs_symbol.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: DXJS_SYMBOL
//       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: Symbol Table Manager
// ========================================================================
////////////////////////////////////////////////////////////////////////////

unit DXJS_SYMBOL;
interface
{$I DXJavaScript.def}

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

type
   TNames=TStringList;

   TSymbolRec=packed record
      PName:Integer;
      Kind:byte;
      PType:SmallInt;
      Count:SmallInt;
      Level:SmallInt;
      Next:SmallInt;
      Module:SmallInt;
      Entry:SmallInt;
      Address:Pointer;
      CRC:Integer;
   end;

   TMem=pointer;

   TSymbolTable=class
//713      Debug:Boolean;
      JScript:Pointer;
      A:array[0..MaxSymbolCard] of TSymbolRec;
//      ShortCut:String; //803
      Card:Integer;
      Names:TNames;
      Mem:TMem;
      MemBoundVar,MemBoundConst,EvalMemBoundVar:Integer;
      FIRST_CONST,LAST_CONST:Integer;
      TrueID,FalseID:Integer;
      UndefinedID,NullID,InfinityID,NaNID,ArrayID,RegExpID,FunctionID:Integer;
      CreateCard,ParseCard,EvalCard:Integer;
      HashArray:THashArray;
      constructor Create (ABScript:Pointer) ;
      destructor Destroy;override;
      procedure AllocateEvalSpace;
      procedure SetupStandardDefinitions;
      procedure SetupHostDefinitions;
      function AppNativeRoutine (const Name:string;Address:Pointer;
         Len:Integer;
         KindProc:TKindProc=KindJavaScript) :Integer;
      function AppHostRoutine (const Name:string;Address:Pointer;
         Len:Integer;
         KindProc:TKindProc=KindJavaScript) :Integer;
      procedure SetName (Const I:Integer;const Name:string) ;
      function GetName (Const I:Integer) :string;
      function GetKind (Const I:Integer) :Integer;
      function GetStrKind (I:Integer) :string;
      function GetStrType (Const I:Integer) :string;
      function IsBaseType (Const TypeID:Integer) :boolean;
      function GetStrVal (Const I:Integer) :string;
      function SetSizeOfSubFrame (Const SubID:Integer) :Integer;
      function GetSizeOfSubFrame (Const SubID:Integer) :Integer;
      function GetAddrOfSubFrame (Const SubID:Integer) :Pointer;
      procedure AllocateSub (Const SubID:Integer) ;
      procedure DeallocateSub (Const SubID:Integer) ;
      function SetEndOfSub (Const SubID:Integer) :Integer;
      function GetEndOfSub (Const SubID:Integer) :Integer;
      function GetParamID (Const SubID,N:Integer) :Integer;
      function GetSizeOf (Const I:Integer) :Integer;
      function GetActualSizeOf (Const I:Integer) :Integer;
      function AllocateVar (Const I:Integer) :Pointer;
      function AllocateConst (Const I:Integer) :Pointer;

      function AppLabel:Integer;
      function AppDelphiObject (const Name:string;const Instance:TObject) :Integer;

      function GetVariant (Const ID:Integer) :TVariant;
      procedure ClearVariant (Const ID:Integer) ;
      procedure PutVariant (Const ID:Integer;const Val:TVariant) ;
      function AppVariant (const Val:TVariant) :Integer;
      function AppVariantConst (const Val:TVariant) :Integer;
//reference
      function AppReference (const Base:TVariant;
         const PropertyName:string) :Integer;
      procedure SetReference (Const ID:Integer;const Base:TVariant;
         const PropertyName:string) ;
      function GetBase (Const RefID:Integer) :TVariant;
      function GetPropertyName (Const RefID:Integer) :string;
      function GetValue (Const ID:Integer) :TVariant;
      procedure PutValue (Const ID:Integer;const Val:TVariant) ;
      function Delete (Const ID:Integer) :boolean;

      function CodeNumberConst (const StrVal:string) :Integer;
      function CodeStringConst (const StrVal:string) :Integer;

      function LookUpID (const Name:string;aLevel:Integer) :Integer;
      function FastLookUpID (const Name:string;aLevel:Integer) :Integer;
      function LookupConstID (const Value:Variant) :Integer;

      procedure Erase (Const I:Integer) ;
      procedure EraseTail (Const Bound:Integer) ;

      procedure Print (const FileName:string) ;
      function IsOutsideMemAddress (A:Pointer) :boolean;
      function IsInsideMemAddress (A:Pointer) :boolean;
      function IsExternalAddress (A:Pointer) :boolean;
      function IsInternalAddress (A:Pointer) :boolean;

      function AppThisID (Const SubID:Integer) :Integer;
      function GetThisID (Const SubID:Integer) :Integer;

      procedure SaveToStream (S:TStream) ;
      procedure LoadFromStream (S:TStream) ;
      procedure SaveRec (Const I:Integer;S:TStream) ;
      procedure LoadRec (Const I:Integer;S:TStream) ;
      procedure ResetRun;
      procedure Enum (Variables,Functions,Constants:TStringList) ;
   end;

implementation

uses
   SysUtils,// IntToStr, StrToInt, StrToFloat
   DXString,
   DXJS_MAIN,
   DXJS_EXTERN,
   DXJS_OBJECT,
   DXJS_CONV;

constructor TSymbolTable.Create (ABScript:Pointer) ;
var
   Loop:Integer;

begin
//   Debug:=False;
   Names:=TNames.Create;
   Names.AddObject('***',TObject(DXString.CRC32ByString('***',$FFFF)));
   HashArray:=THashArray.Create;
   JScript:=ABScript;
   GetMem (Mem,MaxMem) ;
   FillChar2 (Mem^,MaxMem,#0) ;
   MemBoundConst:=StartMemBoundConst;// 100
   MemBoundVar:=StartMemBoundVar;// 40000
//   ShortCut:=',';

   FillChar2 (A,SizeOf (A) ,#0) ;
   for Loop:=1 to BaseTypes.Card do begin
      SetName (Loop,BaseTypes.A[Loop].Name) ;
      A[Loop].Kind:=kind_is_TYPE;
   end;
   FIRST_CONST:=BaseTypes.Card+1;
   LAST_CONST:=FIRST_CONST+MaxConst;
   Card:=LAST_CONST+1;
   TrueID:=AppVariantConst (true) ;
   SetName (TrueID,     'true') ;
   FalseID:=AppVariantConst (false) ;
   SetName (FalseID,    'false') ;
   UndefinedID:=AppVariantConst (Undefined) ;
   SetName (UndefinedID,'undefined') ;
   NullID:=AppVariantConst (Null) ;
   SetName (NullID,     'null') ;
   InfinityID:=AppVariantConst (Infinity) ;
   SetName (InfinityID, 'infinity') ;
   NaNID:=AppVariantConst (NaN) ;
   SetName (NaNID,      'NaN') ;
   ArrayID:=0;
   RegExpID:=0;
   SetupStandardDefinitions;
   CreateCard:=Card;
   ParseCard:=CreateCard;
   EvalCard:=ParseCard;
   EvalMemBoundVar:=MemBoundVar;
//   Debug:=True;
end;

destructor TSymbolTable.Destroy;
var
   Loop:Integer;
begin
   for Loop:=Card downto 1 do Erase (Loop) ;
   Names.Free;
   FreeMem (Mem,MaxMem) ;
   HashArray.Free;
   inherited;
end;

procedure TSymbolTable.SaveRec (Const I:Integer;S:TStream) ;
begin
   S.WriteBuffer (A[I],SizeOf (TSymbolRec) ) ;
   if A[I].PName>0 then SaveString (Names[A[I].PName] ,S) ;
   if A[I].Address<>nil then SaveValue (GetVariant (I) ,S) ;
end;

procedure TSymbolTable.LoadRec (Const I:Integer;S:TStream) ;
var
   Name:string;
   V:Variant;
begin
   S.ReadBuffer (A[I],SizeOf (TSymbolRec) ) ;
   if A[I].PName>0 then begin
      Name:=LoadString (S) ;
      SetName (I,Name) ;
   end;
   if A[I].Address<>nil then begin
      if A[I].Kind=Kind_is_Const then AllocateConst (I)
      else AllocateVar (I) ;
      V:=LoadValue (S,JScript) ;
      PutVariant (I,V) ;
   end;
end;

procedure TSymbolTable.SaveToStream (S:TStream) ;
var
   Loop:Integer;

begin
   SaveInteger (FIRST_CONST,S) ;
   SaveInteger (CreateCard,S) ;
   SaveInteger (ParseCard,S) ;
   for Loop:=BaseTypes.Card+1 to FIRST_CONST-1 do SaveRec (Loop,S) ;
   for Loop:=CreateCard+1 to ParseCard do SaveRec (Loop,S) ;
end;

procedure TSymbolTable.LoadFromStream (S:TStream) ;
var
   Loop:Integer;

begin
   FIRST_CONST:=LoadInteger (S) ;
   CreateCard:=LoadInteger (S) ;
   ParseCard:=LoadInteger (S) ;
   Card:=ParseCard;
   for Loop:=BaseTypes.Card+1 to FIRST_CONST-1 do LoadRec (Loop,S) ;
   for Loop:=CreateCard+1 to ParseCard do LoadRec (Loop,S) ;
   AllocateEvalSpace;
end;

procedure TSymbolTable.AllocateEvalSpace;
begin
   EvalCard:=ParseCard;
   EvalMemBoundVar:=MemBoundVar;
   Inc (Card,MaxEval) ;
   Inc (MemBoundVar,MaxEval*SizeOf (TVariant) ) ;
end;

procedure TSymbolTable.SetupStandardDefinitions;

   procedure AddStandardObject (ClassID:Integer;SO:TScriptObject) ;
   var
      ID:Integer;
      D:TDefinition;
      Loop:Integer;
      Name:string;

   begin
      ID:=AppVariant (ScriptObjectToVariant (SO) ) ;
      SetName (ID,StandardClasses[ClassID]) ;
      if SO.Prototype=nil then Exit;
      with TJScript (JScript) do begin
         ID:=LookUpID ('__'+StandardClasses[ClassID],0) ;
         if ID>0 then begin
            SO.Prototype.PutProperty ('constructor',GetVariant (ID) ) ;
            for Loop:=0 to StdDefinitionList.Count-1 do begin
               D:=TDefinition (StdDefinitionList.Objects[Loop]) ;
               if D.ClassID=ClassID then begin
                  Name:='__'+StandardClasses[ClassID]+'_'+StdDefinitionList[Loop];
                  ID:=LookUpID (Name,0) ;
                  SO.Prototype.PutProperty (StdDefinitionList[Loop],GetVariant (ID) ) ;
               end;
            end;
         end;
      end;
   end;

var
   Loop,SubID:Integer;
   D:TDefinition;
   S,Ws:string;
begin
   for Loop:=0 to TJScript (JScript) .StdDefinitionList.Count-1 do begin
      D:=TDefinition (TJScript (JScript) .StdDefinitionList.Objects[Loop]) ;
      SubID:=AppNativeRoutine (TJScript (JScript) .
         StdDefinitionList[Loop],D.Address,D.Len,D.KindProc) ;
      Ws:=GetName(subID);
      if IsStandardClass (D.ClassID) then begin
         S:='__'+StandardClasses[D.ClassID]+'_'+Ws ;
         SetName (SubID,S) ;
      end
      // dynamically assign the ID for the first instance of each:
      Else if Ws='__Array' then ArrayID:=SubID
      Else If Ws='__RegExp' then RegExpID:=SubID
      Else If Ws='__Function' then FunctionID:=SubID;
   end;
   AddStandardObject (Math_ID,TMathObject.Create (JScript) ) ;
   AddStandardObject (Date_ID,TJScript (JScript) .GlobalObject.DateObject) ;
   AddStandardObject (Boolean_ID,TBooleanObject.Create (false,JScript) ) ;
   AddStandardObject (Number_ID,TNumberObject.Create (Integer (0) ,JScript) ) ;
   AddStandardObject (String_ID,TStringObject.Create ('',JScript) ) ;
   AddStandardObject (Array_ID,TArrayObject.Create (JScript) ) ;
   AddStandardObject (RegExp_ID,TJScript (JScript) .GlobalObject.RegExpObject) ;
   AddStandardObject (Function_ID,TFunctionObject.Create ('',FunctionID,@__Function,0,JScript) ) ;
   AddStandardObject (Error_ID,TErrorObject.Create (JScript) ) ;
   AddStandardObject (DelphiObject_ID,TDelphiObject.Create (nil,JScript) ) ;
   AddStandardObject (ActiveXObject_ID,TActiveXObject.Create (Undefined,JScript) ) ;
   AddStandardObject (EnumeratorObject_ID,TEnumeratorObject.Create (Undefined,JScript) ) ;
end;

procedure TSymbolTable.SetupHostDefinitions;
var
   Loop,ID:Integer;
   P:Pointer;
   D:TDefinition;

begin
   with TJScript (JScript) do begin
      for Loop:=0 to HostDefinitionList.Count-1 do begin
         D:=TDefinition (HostDefinitionList.Objects[Loop]) ;
         AppHostRoutine (HostDefinitionList[Loop],D.Address,D.Len,D.KindProc) ;
      end;
      for Loop:=0 to HostVariableList.Count-1 do begin
         P:=Pointer (HostVariableList.Objects[Loop]) ;
         ID:=AppVariant (Variant (Variant (P^) ) ) ;
         SetName (ID,HostVariableList[Loop]) ;
      end;
      for Loop:=0 to ConstantList.Count-1 do begin
         P:=Pointer (ConstantList.Objects[Loop]) ;
         ID:=AppVariantConst (Variant (Variant (P^) ) ) ;
         SetName (ID,ConstantList[Loop]) ;
      end;
      for Loop:=0 to HostObjectList.Count-1 do
         AppDelphiObject (HostObjectList[Loop],HostObjectList.Objects[Loop]) ;
   end;
end;

function TSymbolTable.AppNativeRoutine (const Name:string;Address:Pointer;
   Len:Integer;KindProc:TKindProc=KindJavaScript) :Integer;

var
   SubDef:string;
   SO:TScriptObject;

begin
   result:=AppVariant (Undefined) ;
   SetName (result,Name) ;
   A[result].Kind:=kind_is_SUB;
   AppThisID (result) ;
   SetEndOfSub (result) ;
   SetSizeOfSubFrame (result) ;
   SubDef:='function '+GetName (result) +'(){ [ native routine code ] }';
   SO:=TFunctionObject.Create (SubDef,result,Address,Len,JScript) ;
   SO.KindProc:=KindProc;
   PutVariant (result,ScriptObjectToVariant (SO) ) ;
end;

function TSymbolTable.AppHostRoutine (const Name:string;Address:Pointer;
   Len:Integer;KindProc:TKindProc=KindJavaScript) :Integer;

var
   SubDef:string;
   SO:TScriptObject;

begin
   result:=LookUpID (Name,0) ;
   if result=0 then begin
      result:=AppVariant (Undefined) ;
      SetName (result,Name) ;
      A[result].Kind:=kind_is_SUB;
      AppThisID (result) ;
      SetEndOfSub (result) ;
      SetSizeOfSubFrame (result) ;
   end;
   A[result].Kind:=kind_is_SUB;
   SubDef:='function '+GetName (result) +'(){ [ native host code ] }';
   SO:=TFunctionObject.Create (SubDef,result,Address,Len,JScript) ;
   SO.KindProc:=KindProc;