diff options
Diffstat (limited to 'src/grt/grt-waves.adb')
-rw-r--r-- | src/grt/grt-waves.adb | 345 |
1 files changed, 167 insertions, 178 deletions
diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb index b03d7e0ec..f97f55ac7 100644 --- a/src/grt/grt-waves.adb +++ b/src/grt/grt-waves.adb @@ -622,39 +622,6 @@ package body Grt.Waves is Create_String_Id (Enum.Names (I - 1)); end loop; end; - when Ghdl_Rtik_Subtype_Array => - declare - Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := - To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); - B_Ctxt : Rti_Context; - begin - Create_String_Id (Arr.Name); - if Rti_Complex_Type (Rti) then - B_Ctxt := Ctxt; - else - B_Ctxt := N_Ctxt; - end if; - Create_Type (Arr.Basetype, B_Ctxt); - end; - when Ghdl_Rtik_Type_Array => - declare - Arr : constant Ghdl_Rtin_Type_Array_Acc := - To_Ghdl_Rtin_Type_Array_Acc (Rti); - begin - Create_String_Id (Arr.Name); - Create_Type (Arr.Element, N_Ctxt); - for I in 1 .. Arr.Nbr_Dim loop - Create_Type (Arr.Indexes (I - 1), N_Ctxt); - end loop; - end; - when Ghdl_Rtik_Subtype_Scalar => - declare - Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc := - To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); - begin - Create_String_Id (Sub.Name); - Create_Type (Sub.Basetype, N_Ctxt); - end; when Ghdl_Rtik_Type_I32 | Ghdl_Rtik_Type_I64 | Ghdl_Rtik_Type_F64 => @@ -678,6 +645,25 @@ package body Grt.Waves is Create_String_Id (Unit_Name); end loop; end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc := + To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + begin + Create_String_Id (Sub.Name); + Create_Type (Sub.Basetype, N_Ctxt); + end; + when Ghdl_Rtik_Type_Array => + declare + Arr : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Rti); + begin + Create_String_Id (Arr.Name); + Create_Type (Arr.Element, N_Ctxt); + for I in 1 .. Arr.Nbr_Dim loop + Create_Type (Arr.Indexes (I - 1), N_Ctxt); + end loop; + end; when Ghdl_Rtik_Type_Record | Ghdl_Rtik_Type_Unbounded_Record => declare @@ -692,30 +678,22 @@ package body Grt.Waves is Create_Type (El.Eltype, N_Ctxt); end loop; end; - when Ghdl_Rtik_Subtype_Record => - declare - Rec : constant Ghdl_Rtin_Subtype_Composite_Acc := - To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); - begin - Create_String_Id (Rec.Name); - Create_Type (Rec.Basetype, N_Ctxt); - end; - when Ghdl_Rtik_Subtype_Unbounded_Record + when Ghdl_Rtik_Subtype_Array + | Ghdl_Rtik_Subtype_Record + | Ghdl_Rtik_Subtype_Unbounded_Record | Ghdl_Rtik_Subtype_Unbounded_Array => - -- Only the base type. declare - St : constant Ghdl_Rtin_Subtype_Composite_Acc := + Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); B_Ctxt : Rti_Context; begin + Create_String_Id (Arr.Name); if Rti_Complex_Type (Rti) then B_Ctxt := Ctxt; else B_Ctxt := N_Ctxt; end if; - Create_Type (St.Basetype, B_Ctxt); - --- return; + Create_Type (Arr.Basetype, B_Ctxt); end; when others => Internal_Error ("wave.create_type"); @@ -1235,11 +1213,15 @@ package body Grt.Waves is return Ghw_Rtik_Subtype_Array; when Ghdl_Rtik_Type_Array => return Ghw_Rtik_Type_Array; + when Ghdl_Rtik_Subtype_Unbounded_Array => + return Ghw_Rtik_Subtype_Unbounded_Array; when Ghdl_Rtik_Type_Record | Ghdl_Rtik_Type_Unbounded_Record => return Ghw_Rtik_Type_Record; when Ghdl_Rtik_Subtype_Record => return Ghw_Rtik_Subtype_Record; + when Ghdl_Rtik_Subtype_Unbounded_Record => + return Ghw_Rtik_Subtype_Unbounded_Record; when Ghdl_Rtik_Subtype_Scalar => return Ghw_Rtik_Subtype_Scalar; when Ghdl_Rtik_Type_I32 => @@ -1253,7 +1235,7 @@ package body Grt.Waves is when Ghdl_Rtik_Type_P64 => return Ghw_Rtik_Type_P64; when others => - return Ghw_Rtik_Error; + Internal_Error ("waves.ghdl_rtik_to_ghw_rtik: unhandled kind"); end case; end Ghdl_Rtik_To_Ghw_Rtik; @@ -1297,45 +1279,64 @@ package body Grt.Waves is end case; end Write_Range; - procedure Write_Array_Bounds (Arr : Ghdl_Rtin_Type_Array_Acc; - Bounds : Address) - is - Rng : Ghdl_Range_Ptr; - Index_Type : Ghdl_Rti_Access; - Bounds1 : Address; - begin - Bounds1 := Bounds; - for I in 0 .. Arr.Nbr_Dim - 1 loop - Index_Type := Get_Base_Type (Arr.Indexes (I)); - Extract_Range (Bounds1, Index_Type, Rng); - Write_Range (Index_Type, Rng); - end loop; - end Write_Array_Bounds; - - procedure Write_Record_Bounds (Rec : Ghdl_Rtin_Type_Record_Acc; - Layout : Address) + procedure Write_Composite_Bounds (Rti : Ghdl_Rti_Access; Bounds : Address) is - El : Ghdl_Rtin_Element_Acc; begin - for I in 1 .. Rec.Nbrel loop - El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); - case El.Eltype.Kind is - when Ghdl_Rtik_Type_Array => - Write_Array_Bounds - (To_Ghdl_Rtin_Type_Array_Acc (El.Eltype), - Array_Layout_To_Bounds (Layout + El.Layout_Off)); - when Ghdl_Rtik_Type_Unbounded_Record => - Write_Record_Bounds - (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype), - Layout + El.Layout_Off); - when others => - null; - end case; - end loop; - end Write_Record_Bounds; + case Rti.Kind is + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_F64 => + return; + when Ghdl_Rtik_Type_Array => + declare + Arr : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Rti); + Rng : Ghdl_Range_Ptr; + Index_Type : Ghdl_Rti_Access; + Bounds1 : Address; + begin + Bounds1 := Bounds; + for I in 0 .. Arr.Nbr_Dim - 1 loop + Index_Type := Get_Base_Type (Arr.Indexes (I)); + Extract_Range (Bounds1, Index_Type, Rng); + Write_Range (Index_Type, Rng); + end loop; + Bounds1 := Array_Layout_To_Element (Bounds1, Arr.Element); + Write_Composite_Bounds (Get_Base_Type (Arr.Element), Bounds1); + end; + when Ghdl_Rtik_Type_Record => + return; + when Ghdl_Rtik_Type_Unbounded_Record => + declare + Rec : constant Ghdl_Rtin_Type_Record_Acc := + To_Ghdl_Rtin_Type_Record_Acc (Rti); + El : Ghdl_Rtin_Element_Acc; + Eltype : Ghdl_Rti_Access; + Bounds1 : Address; + begin + for I in 1 .. Rec.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); + Eltype := Get_Base_Type (El.Eltype); + Bounds1 := Array_Layout_To_Element + (Bounds + El.Layout_Off, Eltype); + Write_Composite_Bounds (Eltype, Bounds1); + end loop; + end; + when others => + Internal_Error ("waves.write_composite_bounds"); + end case; + end Write_Composite_Bounds; procedure Write_Types is + subtype Ghw_Rtik_Types is Ghw_Rtik + range Ghw_Rtik_Type_B2 .. Ghw_Rtik_Subtype_Unbounded_Record; + Kind : Ghw_Rtik_Types; Rti : Ghdl_Rti_Access; Ctxt : Rti_Context; begin @@ -1360,57 +1361,48 @@ package body Grt.Waves is case Obj_Rti.Obj_Type.Kind is when Ghdl_Rtik_Type_Array => declare - Arr : constant Ghdl_Rtin_Type_Array_Acc := - To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type); + Typ : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type; Addr : Ghdl_Uc_Array_Acc; - Bounds : Address; begin Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array)); Write_String_Id (null); - Write_Type_Id (Obj_Rti.Obj_Type, Ctxt); + Write_Type_Id (Typ, Ctxt); Addr := To_Ghdl_Uc_Array_Acc (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); - Bounds := Addr.Bounds; - Write_Array_Bounds (Arr, Bounds); + Write_Composite_Bounds (Typ, Addr.Bounds); end; when Ghdl_Rtik_Subtype_Unbounded_Array => declare St : constant Ghdl_Rtin_Subtype_Composite_Acc := To_Ghdl_Rtin_Subtype_Composite_Acc (Obj_Rti.Obj_Type); - Arr : constant Ghdl_Rtin_Type_Array_Acc := - To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); Addr : Ghdl_Uc_Array_Acc; - Bounds : Address; begin Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array)); Write_String_Id (null); Write_Type_Id (St.Basetype, Ctxt); Addr := To_Ghdl_Uc_Array_Acc (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); - Bounds := Addr.Bounds; - Write_Array_Bounds (Arr, Bounds); + Write_Composite_Bounds (Get_Base_Type (St.Basetype), + Addr.Bounds); end; when Ghdl_Rtik_Type_Unbounded_Record => declare - Rec : constant Ghdl_Rtin_Type_Record_Acc := - To_Ghdl_Rtin_Type_Record_Acc (Obj_Rti.Obj_Type); + Typ : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type; Addr : Ghdl_Uc_Array_Acc; begin Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record)); Write_String_Id (null); - Write_Type_Id (Obj_Rti.Obj_Type, Ctxt); + Write_Type_Id (Typ, Ctxt); Addr := To_Ghdl_Uc_Array_Acc (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); - Write_Record_Bounds (Rec, Addr.Bounds); + Write_Composite_Bounds (Typ, Addr.Bounds); end; when Ghdl_Rtik_Subtype_Unbounded_Record => declare St : constant Ghdl_Rtin_Subtype_Composite_Acc := To_Ghdl_Rtin_Subtype_Composite_Acc (Obj_Rti.Obj_Type); - Rec : constant Ghdl_Rtin_Type_Record_Acc := - To_Ghdl_Rtin_Type_Record_Acc (St.Basetype); Addr : Ghdl_Uc_Array_Acc; begin Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record)); @@ -1418,7 +1410,8 @@ package body Grt.Waves is Write_Type_Id (St.Basetype, Ctxt); Addr := To_Ghdl_Uc_Array_Acc (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); - Write_Record_Bounds (Rec, Addr.Bounds); + Write_Composite_Bounds (Get_Base_Type (St.Basetype), + Addr.Bounds); end; when others => Internal_Error ("waves.write_types: unhandled obj kind"); @@ -1426,7 +1419,8 @@ package body Grt.Waves is end; else -- Kind. - Wave_Put_Byte (Ghw_Rtik'Pos (Ghdl_Rtik_To_Ghw_Rtik (Rti.Kind))); + Kind := Ghdl_Rtik_To_Ghw_Rtik (Rti.Kind); + Wave_Put_Byte (Ghw_Rtik_Types'Pos (Kind)); case Rti.Kind is when Ghdl_Rtik_Type_B1 @@ -1441,22 +1435,64 @@ package body Grt.Waves is Write_String_Id (Enum.Names (I - 1)); end loop; end; - when Ghdl_Rtik_Subtype_Array => + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_F64 => declare - Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := - To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); + Base : constant Ghdl_Rtin_Type_Scalar_Acc := + To_Ghdl_Rtin_Type_Scalar_Acc (Rti); begin - Write_String_Id (Arr.Name); - Write_Type_Id (Arr.Basetype, Ctxt); - declare - Bt : constant Ghdl_Rtin_Type_Array_Acc := - To_Ghdl_Rtin_Type_Array_Acc (Arr.Basetype); - Layout : Address; - begin - Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt); - Write_Array_Bounds - (Bt, Array_Layout_To_Bounds (Layout)); - end; + Write_String_Id (Base.Name); + end; + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + declare + Base : constant Ghdl_Rtin_Type_Physical_Acc := + To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit : Ghdl_Rti_Access; + begin + Write_String_Id (Base.Name); + Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr)); + for I in 1 .. Base.Nbr loop + Unit := Base.Units (I - 1); + Write_String_Id + (Rtis_Utils.Get_Physical_Unit_Name (Unit)); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Rti.Kind is + when Ghdl_Rtik_Type_P64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I64); + when Ghdl_Rtik_Type_P32 => + Wave_Put_SLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I32); + when others => + Internal_Error + ("wave.write_types(P32/P64-1)"); + end case; + when others => + Internal_Error + ("wave.write_types(P32/P64-2)"); + end case; + end loop; + end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc := + To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + begin + Write_String_Id (Sub.Name); + Write_Type_Id (Sub.Basetype, Ctxt); + Write_Range + (Sub.Basetype, + To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth, + Sub.Range_Loc, + Ctxt))); end; when Ghdl_Rtik_Type_Array => declare @@ -1470,6 +1506,18 @@ package body Grt.Waves is Write_Type_Id (Arr.Indexes (I - 1), Ctxt); end loop; end; + when Ghdl_Rtik_Subtype_Array => + declare + Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); + Layout : Address; + begin + Write_String_Id (Arr.Name); + Write_Type_Id (Arr.Basetype, Ctxt); + Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt); + Write_Composite_Bounds (Get_Base_Type (Arr.Basetype), + Array_Layout_To_Bounds (Layout)); + end; when Ghdl_Rtik_Type_Record | Ghdl_Rtik_Type_Unbounded_Record => declare @@ -1489,16 +1537,16 @@ package body Grt.Waves is declare Rec : constant Ghdl_Rtin_Subtype_Composite_Acc := To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); - Base : constant Ghdl_Rtin_Type_Record_Acc := - To_Ghdl_Rtin_Type_Record_Acc (Rec.Basetype); + Base : Ghdl_Rti_Access; Layout : Address; begin Write_String_Id (Rec.Name); Write_Type_Id (Rec.Basetype, Ctxt); - if Base.Common.Kind = Ghdl_Rtik_Type_Unbounded_Record then + Base := Get_Base_Type (Rec.Basetype); + if Base.Kind = Ghdl_Rtik_Type_Unbounded_Record then Layout := Loc_To_Addr (Rec.Common.Depth, Rec.Layout, Ctxt); - Write_Record_Bounds (Base, Layout); + Write_Composite_Bounds (Base, Layout); end if; end; when Ghdl_Rtik_Subtype_Unbounded_Record @@ -1510,65 +1558,6 @@ package body Grt.Waves is Write_String_Id (Rec.Name); Write_Type_Id (Rec.Basetype, Ctxt); end; - when Ghdl_Rtik_Subtype_Scalar => - declare - Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc := - To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); - begin - Write_String_Id (Sub.Name); - Write_Type_Id (Sub.Basetype, Ctxt); - Write_Range - (Sub.Basetype, - To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth, - Sub.Range_Loc, - Ctxt))); - end; - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_I64 - | Ghdl_Rtik_Type_F64 => - declare - Base : constant Ghdl_Rtin_Type_Scalar_Acc := - To_Ghdl_Rtin_Type_Scalar_Acc (Rti); - begin - Write_String_Id (Base.Name); - end; - when Ghdl_Rtik_Type_P32 - | Ghdl_Rtik_Type_P64 => - declare - Base : constant Ghdl_Rtin_Type_Physical_Acc := - To_Ghdl_Rtin_Type_Physical_Acc (Rti); - Unit : Ghdl_Rti_Access; - begin - Write_String_Id (Base.Name); - Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr)); - for I in 1 .. Base.Nbr loop - Unit := Base.Units (I - 1); - Write_String_Id - (Rtis_Utils.Get_Physical_Unit_Name (Unit)); - case Unit.Kind is - when Ghdl_Rtik_Unit64 => - Wave_Put_LSLEB128 - (To_Ghdl_Rtin_Unit64_Acc (Unit).Value); - when Ghdl_Rtik_Unitptr => - case Rti.Kind is - when Ghdl_Rtik_Type_P64 => - Wave_Put_LSLEB128 - (To_Ghdl_Rtin_Unitptr_Acc (Unit). - Addr.I64); - when Ghdl_Rtik_Type_P32 => - Wave_Put_SLEB128 - (To_Ghdl_Rtin_Unitptr_Acc (Unit). - Addr.I32); - when others => - Internal_Error - ("wave.write_types(P32/P64-1)"); - end case; - when others => - Internal_Error - ("wave.write_types(P32/P64-2)"); - end case; - end loop; - end; when others => Internal_Error ("wave.write_types"); -- Internal_Error ("wave.write_types: does not handle " & |