dxjs_symbol.pas

Well known and usefull component for delphi 7

   PutVariant (result,ScriptObjectToVariant (SO) ) ;
end;

procedure TSymbolTable.SetName (Const I:Integer;const Name:string) ;

   function IndexOfName(CRC:Integer):Integer;
   var
      MaxLoop:Integer;
   begin
      MaxLoop:=Names.Count-1;
//      for Result:={0 to} MaxLoop downto 0 do
      for Result:=0 to MaxLoop do
         if CRC=Integer(Names.Objects[Result]) then Exit;
      result:=-1;
   end;

var
   Index:Integer;
   CRC32:Integer;

begin
   CRC32:=DXString.CRC32ByString(Name,$FFFF);
   HashArray.AddName (Name,I) ;
   Index:=IndexOfName(CRC32);
   if Index=-1 then Index:=Names.AddObject(Name,TObject(CRC32)); // TObject(DXString.CRC32ByString(Name,$FFFF)));
   A[I].PName:=Index;
   A[I].CRC:=CRC32;
//   ShortCut:=ShortCut+IntegerToString(CRC32)+':'+IntegerToString(I)+',';
end;

function TSymbolTable.GetName (Const I:Integer) :string;
begin
   If A[I].PName>0 then Result:=Names[A[I].PName]
   else result:='';
end;

function TSymbolTable.GetKind (Const I:Integer) :Integer;
begin
   If I<MaxSymbolCard then Begin // 907
      if I>=0 then result:=A[I].Kind
      else result:=kind_is_OPER;
   end
   Else result:=-1; // 907
end;

function TSymbolTable.GetStrKind (I:Integer) :string;
begin
   I:=GetKind (I);
   Case I of
      0..MaxKinds:Result:=kind_String[I].Msg;
      else result:=#32;
   end;
end;

function TSymbolTable.GetStrType (Const I:Integer) :string;
begin
   if (A[I].PType>=1) and (A[I].PType<=Card) then result:=GetName (A[I].PType)
   else result:=' ';
end;

function TSymbolTable.GetStrVal (Const I:Integer) :string;
begin
   if A[I].PType=type_is_VARIANT then result:=ToStr (GetValue (I) )
   else result:='';
end;

function TSymbolTable.IsBaseType (Const TypeID:Integer) :boolean;
begin
   result:=A[TypeID].PType=0;
end;

function TSymbolTable.SetSizeOfSubFrame (Const SubID:Integer) :Integer;
var
   Loop:Integer;

begin
   result:=0;
   for Loop:=SubID+1 to GetEndOfSub (SubID) do
      if (A[Loop].Level=SubID) and (GetKind (Loop) =kind_is_VAR) then
         Inc (result,GetActualSizeOf (Loop) ) ;
   PutVariant (SubID,result) ;
end;

function TSymbolTable.GetSizeOfSubFrame (Const SubID:Integer) :Integer;
begin
   result:=GetVariant (SubID) ;
end;

function TSymbolTable.GetAddrOfSubFrame (Const SubID:Integer) :Pointer;
var
   Loop:Integer;

begin
   result:=nil;
   for Loop:=SubID+1 to GetEndOfSub (SubID) do
      if (A[Loop].Level=SubID) and (GetKind (Loop) =kind_is_VAR) then begin
         result:=A[Loop].Address;
         Exit;
      end;
end;

procedure TSymbolTable.AllocateSub (Const SubID:Integer) ;
var
   PrevAddr,P:Pointer;
   Loop,Size:Integer;

begin
   PrevAddr:=GetAddrOfSubFrame (SubID) ;
   if PrevAddr=nil then Exit;
   P:=ShiftPointer (Mem,MemBoundVar) ;
   Pointer (P^) :=PrevAddr;
   Size:=SizeOf (Pointer) ;
   P:=ShiftPointer (P,Size) ;
   Inc (MemBoundVar,Size) ;
   for Loop:=SubID+1 to GetEndOfSub (SubID) do
      if (A[Loop].Level=SubID) and (GetKind (Loop) =kind_is_VAR) then begin
         A[Loop].Address:=P;
         Size:=GetActualSizeOf (Loop) ;
         FillChar2 (P^,Size,#0) ;
         P:=ShiftPointer (P,Size) ;
         Inc (MemBoundVar,Size) ;
      end;
end;

procedure TSymbolTable.DeallocateSub (Const SubID:Integer) ;
var
   P:Pointer;
   Loop:Integer;

begin
   P:=GetAddrOfSubFrame (SubID) ;
   if P<>nil then Begin
      P:=ShiftPointer (P,-SizeOf (Pointer) ) ;
      P:=Pointer (P^) ;
      for Loop:=SubID+1 to GetEndOfSub (SubID) do
         if (A[Loop].Level=SubID) and (GetKind (Loop) =kind_is_VAR) then begin
            Erase (Loop) ;
            A[Loop].Address:=P;
            P:=ShiftPointer (P,GetActualSizeOf (Loop) ) ;
         end;
   End;
end;

function TSymbolTable.SetEndOfSub (Const SubID:Integer) :Integer;
begin
   Inc (Card) ;
   result:=Card;
   SetName (Card,'%'+GetName (SubID) ) ;
   A[SubID].Next:=Result;
end;

function TSymbolTable.GetEndOfSub (Const SubID:Integer) :Integer;
begin
   result:=A[SubID].Next;
end;

function TSymbolTable.GetSizeOf (Const I:Integer) :Integer;
begin
   if not IsBaseType (I) then result:=BaseTypes.GetSize (A[I].PType)
   else result:=BaseTypes.GetSize (I);
end;

function TSymbolTable.GetActualSizeOf (Const I:Integer) :Integer;
begin
   result:=GetSizeOf (I) ;
end;

function TSymbolTable.AllocateConst (Const I:Integer) :Pointer;
begin
   if MemBoundConst>StartMemBoundVar then
      ErrMessageBox ('Overflow in the consttant allocation !') ;
   result:=ShiftPointer (Mem,MemBoundConst) ;
   A[I].Address:=result;
   Inc (MemBoundConst,GetActualSizeOf (I) ) ;
end;

function TSymbolTable.AppLabel:Integer;
begin
   Inc (Card) ;
   result:=Card;
   A[Card].Kind:=Kind_is_LABEL;
end;

function TSymbolTable.GetVariant (Const ID:Integer) :TVariant;
begin
   VarCopy (result,Variant (A[ID].Address^) ) ;
end;

procedure TSymbolTable.ClearVariant (Const ID:Integer) ;
begin
   VarClear (Variant (A[ID].Address^) ) ;
end;

procedure TSymbolTable.PutVariant (Const ID:Integer;const Val:TVariant) ;
begin
   VarCopy (Variant (A[ID].Address^) ,Val) ;
end;

function TSymbolTable.AppVariant (const Val:TVariant) :Integer;
begin
   Inc (Card) ;
   with A[Card] do begin
      PName:=0;
      PType:=type_is_VARIANT;
      Kind:=kind_is_VAR;
      Address:=Pointer (Integer (Mem) +MemBoundVar) ;
      Inc (MemBoundVar,SizeOf (TVariant) ) ;
      FillChar2 (Address^,SizeOf (TVariant) ,#0) ;
      TVariant (Address^) :=Val;
   end;
   result:=Card;
end;

function TSymbolTable.AppVariantConst (const Val:TVariant) :Integer;
begin
{   result:=LookupConstID (Val) ;
   if result>0 then
      Exit;} // Sept 2003
   result:=FIRST_CONST;
   Inc (FIRST_CONST) ;
   A[Result].PType:=type_is_VARIANT;
   A[result].Kind:=kind_is_CONST;
   AllocateConst (result) ;
   PutVariant (result,Val) ;
   SetName (result,ToString (Val) ) ;
end;

function TSymbolTable.AppReference (const Base:TVariant;
   const PropertyName:string) :Integer;
begin
   result:=AppVariant (Base) ;
   A[result].Kind:=kind_is_REF;
   SetName (result,PropertyName) ;
end;

procedure TSymbolTable.SetReference (Const ID:Integer;const Base:TVariant;
   const PropertyName:string) ;

begin
   A[ID].Kind:=kind_is_REF;
   SetName (ID,PropertyName) ;
   PutVariant (ID,Base) ;
end;

function TSymbolTable.GetBase (Const RefID:Integer) :TVariant;
begin
   result:=GetVariant (RefID) ;
end;

function TSymbolTable.GetPropertyName (Const RefID:Integer) :string;
begin
   result:=GetName (RefID) ;
end;

function TSymbolTable.GetValue (Const ID:Integer) :TVariant;
var
   Base:TVariant;
   PropertyName:string;
   SO:TScriptObject;

begin
   If (ID<0) or (ID>MaxSymbolCard) then Result:='' // 907
   else if GetKind (ID) <>kind_is_REF then begin
      result:=GetVariant (ID) ;
      if VarIsEmpty (result) then
         if TJScript (JScript) .ScriptState=ss_Running then
            if Assigned (TJScript (JScript) .fOnUndefinedVariable) then
               TJScript (JScript) .fOnUndefinedVariable (TJScript (JScript) .Owner,GetName (ID) ,result) ;
   end
   Else Begin
      Base:=GetBase (ID) ;
      PropertyName:=GetPropertyName (ID) ;
      if (TVarData(Base).VType = varNull) or VarIsEmpty (Base) then
         raise TScriptFailure.Create (reReferenceError) ;
      SO:=VariantToScriptObject (Base) ;
      result:=SO.GetProperty (PropertyName) ;
   End;
end;

procedure TSymbolTable.PutValue (Const ID:Integer;const Val:TVariant) ;
var
   Base:TVariant;
   PropertyName:string;

begin
   if GetKind (ID) <>kind_is_REF then PutVariant (ID,Val)
   Else Begin
      Base:=GetBase (ID) ;
      PropertyName:=GetPropertyName (ID) ;
      if (TVarData(Base).VType = varNull) or VarIsEmpty (Base) then
         raise TScriptFailure.Create (reReferenceError) ;
      VariantToScriptObject (Base).PutProperty (PropertyName,Val) ;
   End;
end;

function TSymbolTable.Delete (Const ID:Integer) :boolean;
var
   Base:TVariant;
   PropertyName:string;

begin
   result:=true;
   if GetKind (ID) =kind_is_REF then Begin
      Base:=GetBase (ID) ;
      PropertyName:=GetPropertyName (ID) ;
      if (TVarData(Base).VType = varNull) or VarIsEmpty (Base) then Exit;
      VariantToScriptObject (Base).Delete (PropertyName) ;
   End;
end;

function TSymbolTable.AllocateVar (Const I:Integer) :Pointer;
var
   MemCnt:Integer;

begin
   result:=ShiftPointer (Mem,MemBoundVar) ;
   A[I].Address:=result;
   MemCnt:=GetActualSizeOf (I) ;
   Inc (MemBoundVar,MemCnt) ;
   FillChar2 (result^,MemCnt,#0) ;
end;

function TSymbolTable.CodeNumberConst (const StrVal:string) :Integer;
var
   I,J,K:Integer;
   Val,TempVal:TVariant;
   S:string;
   D:Double;
   ch:Char;
begin
   I:=Length (StrVal) ;
   ch:=StrVal[I];
   If uppercase(Copy(StrVal,1,2))='0X' then Ch:=#0; // 12-21-2004 (for 0x?B values)
   case ch of
      'B':begin
            J:=0;
            K:=1;
            Dec (I) ;
            repeat
               ch:=StrVal[I];
               if not (ch in ['0'..'1']) then
                  raise TScriptFailure.Create (peSyntaxError) ;
               if ch='1' then Inc (J,K) ;
               K:=K*2;
               Dec (I) ;
            until I=0;
            D:=J;
            Val:=D;
         end;
      'D':begin
            D:=SysUtils.StrToInt (Copy (StrVal,1,I-1) ) ;
            Val:=D;
         end;
      'H':begin
            S:='$'+Copy (StrVal,1,I-1) ;
            D:=StrToInt (S) ;
            Val:=D;
         end;
   else
   begin
         S:=Copy (StrVal,1,2) ;
         if (S='0x') or (S='0X') then begin
            S:='$'+Copy (StrVal,3,Length (StrVal) -2) ;
            D:=StrToInt (S) ;
            Val:=D;
         end
         else if (S='0b') or (S='0B') then begin
            S:=Copy (StrVal,3,Length (StrVal) -2) ;
            I:=Length (S) ;
            J:=0;
            K:=1;
            repeat
               ch:=S[I];
               if not (ch in ['0'..'1']) then
                  raise TScriptFailure.Create (peSyntaxError) ;
               if ch='1' then Inc (J,K) ;
               K:=K*2;
               Dec (I) ;
            until I=0;
            D:=J;
            Val:=D;
         end
         else Val:=SysUtils.StrToFloat (StrVal) ;
      end;
   end;
   for I:=BaseTypes.Card+1 to FIRST_CONST-1 do
      if A[I].PType=type_is_VARIANT then begin
         TempVal:=GetVariant (I) ;
         if VarType (Val) =VarType (TempVal) then
            if Val=TempVal then begin
               result:=I;
               Exit;
            end;
      end;
   result:=AppVariantConst (Val) ;
   SetName (result,GetStrVal (result) ) ;
end;

function TSymbolTable.CodeStringConst (const StrVal:string) :Integer;
var
   Loop:Integer;
   Val,TempVal:TVariant;