dxjs_symbol.pas

Well known and usefull component for delphi 7

begin
   Val:=StrVal;
   for Loop:=BaseTypes.Card+1 to FIRST_CONST-1 do
      if A[Loop].PType=type_is_VARIANT then begin
         TempVal:=GetVariant (Loop) ;
         if VarType (Val) =VarType (TempVal) then
            if Val=TempVal then begin
               result:=Loop;
               Exit;
            end;
      end;
   result:=AppVariantConst (Val) ;
   SetName (result,GetStrVal (result) ) ;
end;

procedure TSymbolTable.Erase (Const I:Integer) ;
begin
   Case GetKind(I) of
      Kind_is_Var,
      Kind_is_Const,
      0:if A[I].PType=type_is_VARIANT then ClearVariant (I) ;
   End;
end;

procedure TSymbolTable.EraseTail (Const Bound:Integer) ;
var
   Loop:Integer;

begin
   for Loop:=Card downto (Bound+1) do begin
{713      With A[Loop] do Begin
         if Address<>nil then begin
            Erase (Loop) ;
            if IsInternalAddress (Address) then MemBoundVar:=Integer(Address)-Integer(Mem) ;
         end;
         PName:=0;
         Kind:=0;
         PType:=0;
         Count:=0;
         Level:=0;
         Next:=0;
         Module:=0;
         Entry:=0;
         Address:=Nil;
         CRC:=0;
}
         if A[Loop].Address<>nil then begin
            Erase (Loop) ;
            if IsInternalAddress (A[Loop].Address) then MemBoundVar:=Integer(A[Loop].Address)-Integer(Mem) ;
         end;
         // remove from shortcut list here! 803 TODO
         FillChar2(A[Loop],Sizeof(A[Loop]),#0);
//713      End;
   end;
   Card:=Bound;
end;

function TSymbolTable.LookUpID (const Name:string;aLevel:Integer) :Integer;
var
   Loop,K:Integer;
   CRC:Integer;
//   Ws,Ts,Ca:String;

begin
   CRC:=DXString.CRC32ByString(Name,$FFFF);
   result:=0;
// 803
   for Loop:=Card downto 1 do
      if (A[Loop].PName<>0) and (A[Loop].CRC=CRC) then begin
         K:=GetKind (Loop) ;
         if (K=Kind_is_SUB) or (K=Kind_is_VAR) or (K=Kind_is_CONST) then
            if A[Loop].Level=aLevel then begin
               result:=Loop;
               Exit;
            end;
      end;
{ // 803:
   Ts:=ShortCut;
   Ws:=','+IntegerToString(CRC)+':';
   Loop:=QuickPos(Ws,Ts);
   While Loop>0 do Begin
      System.Delete(Ts,1,(Loop+Length(Ws))-1);
      Ca:=DXString.FetchByChar(Ts,',',false);
      Ts:=','+Ts;
      Loop:=StrToInt(Ca);
      if (A[Loop].PName<>0) and (A[Loop].CRC=CRC) then begin
         K:=GetKind (Loop) ;
         if (K=Kind_is_SUB) or (K=Kind_is_VAR) or (K=Kind_is_CONST) then
            if A[Loop].Level=aLevel then begin
               result:=Loop;
               Exit;
            end;
      end;
      Loop:=QuickPos(Ws,Ts);
   End;}
end;

function TSymbolTable.FastLookUpID (const Name:string;aLevel:Integer) :Integer;
var
   I,J,K,HashIndex:Integer;

begin
   Result:=0;// OZZ
   HashIndex:=HashNumber (Name) ;
   if HashIndex>-1 then Begin
      K:=HashArray.A[HashIndex].Count;
      for J:=K-1 downto 0 do begin
         I:=Integer (HashArray.A[HashIndex].Items[J]) ;
         if (I<=Card) and (I>0) and (Name=GetName (I)) then begin
            K:=GetKind (I) ;
            if (K=Kind_is_VAR) or (K=Kind_is_SUB) then
               if A[I].Level=aLevel then begin
                  result:=I;
                  Exit;
               end;
         end;
      end;
   End;
end;

function TSymbolTable.LookupConstID (const Value:Variant) :Integer;
var
   Loop:Integer;

begin
   result:=0;
   for Loop:=1 to Card do
      if GetKind (Loop) =Kind_is_CONST then
         if VarType (GetVariant (Loop) ) =VarType (Value) then
            if GetVariant (Loop) =Value then begin
               result:=Loop;
               Exit;
            end;
end;

function TSymbolTable.IsOutsideMemAddress (A:Pointer) :boolean;
begin
   result:= (Integer(A)>=Integer(Mem)+MemBoundVar) and (Integer(A)<=Integer(Mem)+MaxMem) ;
end;

function TSymbolTable.IsInsideMemAddress (A:Pointer) :boolean;
begin
   result:= (Integer(A)>=Integer(Mem)) and (Integer(A)<Integer(Mem)+MemBoundVar) ;
end;

function TSymbolTable.IsExternalAddress (A:Pointer) :boolean;
begin
   result:= (Integer(A)<Integer(Mem)) and (Integer(A)>Integer(Mem)+MaxMem) ;
end;

function TSymbolTable.IsInternalAddress (A:Pointer) :boolean;
begin
   result:= (Integer(A)>=Integer(Mem)) and (Integer(A)<=Integer(Mem)+MaxMem) ;
end;

function TSymbolTable.AppThisID (Const SubID:Integer) :Integer;
begin
   result:=AppVariant (Undefined) ;
   SetName (result,'this') ;
   A[Result].Level:=SubID;
end;

function TSymbolTable.GetThisID (Const SubID:Integer) :Integer;
begin
   result:=SubID+1;
   if A[Result].Level<>SubID then result:=0;
end;

function TSymbolTable.GetParamID (Const SubID,N:Integer) :Integer;
var
   Loop,K:Integer;

begin
   K:=0;
   result:=0;
   for Loop:=SubID+1 to Card do
      if A[Loop].Level=SubID then
         if GetKind (Loop) =kind_is_VAR then begin
            Inc (K) ;
            if K=N then begin
               result:=Loop;
               Exit;
            end;
         end;
end;

function TSymbolTable.AppDelphiObject (const Name:string;const Instance:TObject) :Integer;
var
   V:Variant;

begin
   V:=ScriptObjectToVariant (TDelphiObject.Create (Instance,JScript)) ;
   result:=LookUpID (Name,0) ;
   if result=0 then begin
      result:=AppVariant (V) ;
      SetName (result,Name) ;
   end
   else PutVariant (result,V) ;
end;

procedure TSymbolTable.ResetRun;
begin
   EraseTail (ParseCard) ;
end;

procedure TSymbolTable.Print (const FileName:string) ;
   function CharNotVisible (NotVisible:boolean) :Char;
   begin
      if NotVisible then result:='N'
      else result:=' ';
   end;

const
   V='|';

var
   T:Text;

   procedure WriteLine (I:Integer) ;

      function StrAddr:string;
      begin
         if A[I].Address=nil then result:='nil'
         else
            result:=IntegerToString (Integer (A[I].Address) -Integer (Mem) ) ;
      end;

   begin
      writeln (T,'') ;
      if I>Card then begin
         write (T,I:6) ;
         Exit;
      end;

      with A[I] do begin
         write (T,I:4,V,
            Norm (GetName (I) ,12) ,V,
            Norm (GetStrKind (I) ,3) ,V,
            Norm (GetStrType (I) ,10) ,V,
            Count:4,V,
            Next:4,V,
            Level:4,V,
            Module:2,V,
            Entry:5,V,
            Norm (StrAddr,8) ,V,
            GetStrVal (I) ) ;
      end;
   end;

var
   I,J:Integer;
   AStack:TScriptStack;
   CallStack:TCallStack;
begin
   AssignFile (T,FileName) ;
   Rewrite (T) ;

   try
      writeln (T,'   #',V,
         'Name        ',V,
         'Knd',V,
         'Type      ',V,
         'Cnt ',V,
         'Next',V,
         'Levl',V,
         'Md',V,
         'Entry',V,
         'Addr    ',V,
         'Value') ;

      for I:=1 to Card do
         WriteLine (I) ;

      writeln (T,'') ;
      writeln (T,'') ;
      write (T,'CreateCard ',CreateCard) ;
      writeln (T,'') ;
      write (T,'ParseCard ',ParseCard) ;
      writeln (T,'') ;
      write (T,'EvalCard ',EvalCard) ;
      writeln (T,'') ;
      write (T,'MemBoundVar ',MemBoundVar) ;
      writeln (T,'') ;
      write (T,'EvalMemBoundVar ',EvalMemBoundVar) ;

      if not Assigned (TJScript (JScript) .Postfix) then Exit;

      writeln (T,'') ;
      write (T,'CurrBoundStack ',TJScript (JScript) .Postfix.CurrBoundStack) ;
      writeln (T,'') ;
      write (T,'CurrBoundTable ',TJScript (JScript) .Postfix.CurrBoundTable) ;

      AStack:=TJScript (JScript) .Postfix.Stack;
      writeln (T,'') ;
      writeln (T,'Stack ********************') ;
      writeln (T,'Card = ',AStack.Card) ;

      for J:=1 to AStack.Card do begin
         I:=AStack.A[J];
         WriteLine (I) ;
      end;

      CallStack:=TJScript (JScript) .Postfix.CallStack;
      writeln (T,'') ;
      writeln (T,'Call Stack ***************') ;
      writeln (T,'Card = ',CallStack.Count) ;
      writeln (T,'') ;

      for J:=0 to CallStack.Count-1 do begin
         I:=TCallObject (CallStack[J]) .SubID;
         writeln (T,'N = ',TCallObject (CallStack[J]) .N) ;
         WriteLine (I) ;
      end;

   finally
      CloseFile (T) ;
   end;
end;

procedure TSymbolTable.Enum (Variables,Functions,Constants:TStringList) ;
var
   Loop,Loop2:Integer;
   S,S1:string;
   Exists:boolean;

begin
   Variables.Sorted:=true;
   Variables.Duplicates:=dupIgnore;
   Functions.Sorted:=true;
   Functions.Duplicates:=dupIgnore;
   Constants.Sorted:=true;
   Constants.Duplicates:=dupIgnore;
   for Loop:=1 to Card do
      if A[Loop].Level=0 then Begin
         if GetKind (Loop) =Kind_is_Sub then begin
            S:=GetName (Loop) ;
            if DXString.QuickPos ('__',S) <>1 then begin
               Functions.Add (VariantToScriptObject (GetVariant (Loop) ).DefaultValue) ;
            end;
         end;
      end;
   for Loop:=1 to Card do
      if A[Loop].Level=0 then Begin
         if GetKind (Loop) =Kind_is_Var then begin
            S:=GetName (Loop) ;
            Exists:=false;
            for Loop2:=0 to Functions.Count-1 do begin
               S1:=Copy (Functions[Loop2],10,Length (S) ) ;
               if S=S1 then Exists:=true;
            end;
            if not Exists then Variables.Add ('var '+S) ;
         end;
         if GetKind (Loop) =Kind_is_TYPE then begin
            S:=GetName (Loop) ;
            Exists:=false;
            for Loop2:=0 to Functions.Count-1 do begin
               S1:=Copy (Functions[Loop2],10,Length (S) ) ;
               if S=S1 then Exists:=true;
            end;
            if not Exists then Variables.Add ('type '+S) ;
         end;
         if GetKind (Loop) =Kind_is_CONST then begin
            S:=GetName (Loop) ;
            Exists:=false;
            for Loop2:=0 to Functions.Count-1 do begin
               S1:=Copy (Functions[Loop2],10,Length (S) ) ;
               if S=S1 then Exists:=true;
            end;
            if not Exists then Constants.Add ('const '+S) ;
         end;
         if GetKind (Loop) =Kind_is_REF then begin
            S:=GetName (Loop) ;
            Exists:=false;
            for Loop2:=0 to Functions.Count-1 do begin
               S1:=Copy (Functions[Loop2],10,Length (S) ) ;
               if S=S1 then Exists:=true;
            end;
            if not Exists then Variables.Add ('ref '+S) ;
         end;
         if GetKind (Loop) =Kind_is_LABEL then begin
            S:=GetName (Loop) ;
            Exists:=false;
            for Loop2:=0 to Functions.Count-1 do begin
               S1:=Copy (Functions[Loop2],10,Length (S) ) ;
               if S=S1 then Exists:=true;
            end;
            if not Exists then Variables.Add ('label '+S) ;
         end;
         if GetKind (Loop) =Kind_is_OPER then begin
            S:=GetName (Loop) ;
            Exists:=false;
            for Loop2:=0 to Functions.Count-1 do begin
               S1:=Copy (Functions[Loop2],10,Length (S) ) ;
               if S=S1 then Exists:=true;
            end;
            if not Exists then Variables.Add ('oper '+S) ;
         end;
      end;
end;

end.