diff options
Diffstat (limited to 'translate/grt/grt-rtis_utils.adb')
| -rw-r--r-- | translate/grt/grt-rtis_utils.adb | 623 |
1 files changed, 623 insertions, 0 deletions
diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb new file mode 100644 index 000000000..62cd407e8 --- /dev/null +++ b/translate/grt/grt-rtis_utils.adb @@ -0,0 +1,623 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; use System; +with Grt.Rtis; use Grt.Rtis; +with Grt.Types; use Grt.Types; +--with Grt.Disp; use Grt.Disp; +with Grt.Errors; use Grt.Errors; + +package body Grt.Rtis_Utils is + + function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result + is + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result; + + function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + Index : Ghdl_Index_Type; + Child : Ghdl_Rti_Access; + begin + Res := Process (Ctxt, Ctxt.Block); + if Res /= Traverse_Ok then + return Res; + end if; + + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + Index := 0; + while Index < Blk.Nbr_Child loop + Child := Blk.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off, + Block => Child); + Res := Traverse_Blocks_1 (Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + Length : Ghdl_Index_Type; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + for I in 1 .. Length loop + Res := Traverse_Blocks_1 (Nctxt); + exit when Res = Traverse_Stop; + Nctxt.Base := Nctxt.Base + Nblk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, + Block => Child); + if Nctxt.Base /= Null_Address then + Res := Traverse_Blocks_1 (Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + Res := Process (Ctxt, Child); + if Res = Traverse_Ok then + declare + Obj : Ghdl_Rtin_Instance_Acc; + begin + Obj := To_Ghdl_Rtin_Instance_Acc (Child); + + Get_Instance_Context (Obj, Ctxt, Nctxt); + Res := Traverse_Instance (Nctxt); + end; + end if; + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture => + Internal_Error ("traverse_blocks"); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Res := Process (Ctxt, Child); + when others => + null; + end case; + exit when Res = Traverse_Stop; + end loop; + + return Res; + end Traverse_Blocks_1; + + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + -- The entity. + Res := Traverse_Blocks_1 (Nctxt); + if Res /= Traverse_Stop then + -- The architecture. + Res := Traverse_Blocks_1 (Ctxt); + end if; + when Ghdl_Rtik_Package_Body => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Res := Traverse_Blocks_1 (Nctxt); + when others => + Internal_Error ("traverse_blocks"); + end case; + return Res; + end Traverse_Instance; + begin + return Traverse_Instance (Ctxt); + end Traverse_Blocks; + + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask) + = Ghdl_Rti_Type_Complex; + end Rti_Complex_Type; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Get_Enum_Value + (Vstr : in out Vstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Append (Vstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean) + is + -- Current address. + Addr : Address; + + Name : Vstring; + + procedure Handle_Any (Rti : Ghdl_Rti_Access); + + procedure Handle_Scalar (Rti : Ghdl_Rti_Access) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + begin + Process (Addr, Name, Rti); + + if Is_Sig then + Update (Address'Size); + else + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Update (32); + when Ghdl_Rtik_Type_E8 => + Update (8); + when Ghdl_Rtik_Type_B2 => + Update (8); + when Ghdl_Rtik_Type_F64 => + Update (64); + when Ghdl_Rtik_Type_P64 => + Update (64); + when others => + Internal_Error ("handle_scalar"); + end case; + end if; + end Handle_Scalar; + + procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type; + Val : out Value_Union) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + case Rng.I32.Dir is + when Dir_To => + Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos); + when Dir_Downto => + Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos); + end case; + when Ghdl_Rtik_Type_E8 => + case Rng.E8.Dir is + when Dir_To => + Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos); + when Dir_Downto => + Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos); + end case; + when Ghdl_Rtik_Type_B2 => + case Pos is + when 0 => + Val.B2 := Rng.B2.Left; + when 1 => + Val.B2 := Rng.B2.Right; + when others => + Val.B2 := False; + end case; + when others => + Internal_Error ("grt.rtis_utils.range_pos_to_val"); + end case; + end Range_Pos_To_Val; + + procedure Pos_To_Vstring + (Vstr : in out Vstring; + Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type) + is + V : Value_Union; + begin + Range_Pos_To_Val (Rti, Rng, Pos, V); + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, V.I32); + Append (Vstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8)); + when Ghdl_Rtik_Type_B2 => + Get_Enum_Value (Vstr, Rti, Ghdl_B2'Pos (V.B2)); + when others => + Append (Vstr, '?'); + end case; + end Pos_To_Vstring; + + procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type) + is + Len : Ghdl_Index_Type; + P : Natural; + Base_Type : Ghdl_Rti_Access; + begin + P := Length (Name); + if Index = 0 then + Append (Name, '('); + else + Append (Name, ','); + end if; + + Base_Type := Get_Base_Type (Rtis (Index)); + Len := Range_To_Length (Rngs (Index), Base_Type); + + for I in 1 .. Len loop + Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1); + if Index = Rngs'Last then + Append (Name, ')'); + Handle_Any (El_Rti); + else + Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1); + end if; + Truncate (Name, P + 1); + end loop; + Truncate (Name, P); + end Handle_Array_1; + + procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc; + Vals : Ghdl_Uc_Array_Acc) + is + Nbr_Dim : Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Addr := Vals.Base; + Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0); + end Handle_Array; + + procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc) + is + El : Ghdl_Rtin_Element_Acc; + Obj_Addr : Address; + P : Natural; + begin + P := Length (Name); + Obj_Addr := Addr; + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if Is_Sig then + Addr := Obj_Addr + El.Sig_Off; + else + Addr := Obj_Addr + El.Val_Off; + end if; + Append (Name, '.'); + Append (Name, El.Name); + Handle_Any (El.Eltype); + Truncate (Name, P); + end loop; + -- FIXME + --Addr := Obj_Addr + Rti.Xx; + end Handle_Record; + + procedure Handle_Any (Rti : Ghdl_Rti_Access) + is + Save_Addr : Address; + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_B2 => + Handle_Scalar (Rti); + when Ghdl_Rtik_Type_Array => + Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti), + To_Ghdl_Uc_Array_Acc (Addr)); + when Ghdl_Rtik_Subtype_Array => + declare + St : Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + if Rti_Complex_Type (Rti) then + Save_Addr := Addr; + Addr := To_Addr_Acc (Addr).all; + end if; + Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0); + if Rti_Complex_Type (Rti) then + Addr := Save_Addr + (Address'Size / Storage_Unit); + end if; + end; + when Ghdl_Rtik_Subtype_Array_Ptr => + declare + St : Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + Save_Addr := Addr; + Addr := To_Addr_Acc (Addr).all; + Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0); + Addr := Save_Addr + (Address'Size / Storage_Unit); + end; +-- when Ghdl_Rtik_Type_File => +-- declare +-- Vptr : Ghdl_Value_Ptr; +-- begin +-- Vptr := To_Ghdl_Value_Ptr (Obj); +-- Put (Stream, "File#"); +-- Put_I32 (Stream, Vptr.I32); +-- -- FIXME: update OBJ (not very useful since never in a +-- -- composite type). +-- end; + when Ghdl_Rtik_Type_Record => + if Rti_Complex_Type (Rti) then + Save_Addr := Addr; + Addr := To_Addr_Acc (Addr).all; + end if; + Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti)); + if Rti_Complex_Type (Rti) then + Addr := Save_Addr + (Address'Size / Storage_Unit); + end if; + when others => + Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any"); + end case; + end Handle_Any; + begin + Addr := Obj_Addr; + Handle_Any (Obj_Type); + Free (Name); + end Foreach_Scalar; + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_B2 => + Get_Enum_Value + (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B2'Pos (Value.B2))); + when Ghdl_Rtik_Type_F64 => + declare + S : String (1 .. 32); + L : Integer; + -- Warning: this assumes a C99 snprintf (ie, it returns the + -- number of characters). + function snprintf (Cstr : Address; + Size : Natural; + Template : Address; + Arg : Ghdl_F64) + return Integer; + pragma Import (C, snprintf); + + Format : constant String := "%g" & Character'Val (0); + begin + L := snprintf (S'Address, S'Length, Format'Address, Value.F64); + if L < 0 then + -- FIXME. + Append (Str, "?"); + else + Append (Str, S (1 .. L)); + end if; + end; + when Ghdl_Rtik_Type_P32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + Append (Str, + To_Ghdl_Rtin_Unit_Acc (To_Ghdl_Rtin_Type_Physical_Acc + (Type_Rti).Units (0)).Name); + end; + when Ghdl_Rtik_Type_P64 => + declare + S : String (1 .. 21); + F : Natural; + begin + To_String (S, F, Value.I64); + Append (Str, S (F .. S'Last)); + Append (Str, + To_Ghdl_Rtin_Unit_Acc (To_Ghdl_Rtin_Type_Physical_Acc + (Type_Rti).Units (0)).Name); + end; + when others => + Internal_Error ("grt.rtis_utils.get_value"); + end case; + end Get_Value; + + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + Name : Vstring; + begin + Rtis_Utils.Get_Value (Name, Value, Type_Rti); + Put (Stream, Name); + end Disp_Value; + + procedure Get_Enum_Value + (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Prepend (Rstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Get_Value (Rstr : in out Rstring; + Addr : Address; + Type_Rti : Ghdl_Rti_Access) + is + Value : Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr); + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Prepend (Rstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_B2 => + Get_Enum_Value + (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B2'Pos (Value.B2))); + when others => + Internal_Error ("grt.rtis_utils.get_value(rstr)"); + end case; + end Get_Value; + + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True) + is + Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + begin + Ctxt := Last_Ctxt; + loop + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + when Ghdl_Rtik_Entity => + declare + Link : Ghdl_Entity_Link_Acc; + begin + Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base); + Ctxt := (Base => Ctxt.Base, + Block => Link.Rti); + end; + when Ghdl_Rtik_Architecture => + declare + Entity_Ctxt: Rti_Context; + Link : Ghdl_Entity_Link_Acc; + Parent_Inst : Ghdl_Rti_Access; + begin + -- Architecture name. + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, '('); + end if; + + Entity_Ctxt := Get_Parent_Context (Ctxt); + + -- Instance parent. + Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base); + Get_Instance_Link (Link, Ctxt, Parent_Inst); + + -- Add entity name. + if Is_Instance or Parent_Inst = null then + Prepend (Rstr, + To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name); + end if; + + if Parent_Inst = null then + -- Top reached. + Prepend (Rstr, Sep); + return; + else + -- Instantiation statement label. + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, + To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name); + Prepend (Rstr, Sep); + end if; + end; + when Ghdl_Rtik_For_Generate => + declare + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Prepend (Rstr, ')'); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type)); + Prepend (Rstr, '('); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + end; + when others => + Internal_Error ("grt.rtis_utils.get_path_name"); + end case; + end loop; + end Get_Path_Name; + + procedure Put (Stream : FILEs; Ctxt : Rti_Context) + is + Rstr : Rstring; + begin + Get_Path_Name (Rstr, Ctxt, '.'); + Put (Stream, Rstr); + Free (Rstr); + end Put; + +end Grt.Rtis_Utils; |