diff options
| -rw-r--r-- | src/grt/grt-avhpi.adb | 40 | ||||
| -rw-r--r-- | src/grt/grt-disp_rti.adb | 342 | ||||
| -rw-r--r-- | src/grt/grt-disp_rti.ads | 1 | ||||
| -rw-r--r-- | src/grt/grt-disp_tree.adb | 5 | ||||
| -rw-r--r-- | src/grt/grt-rtis.ads | 46 | ||||
| -rw-r--r-- | src/grt/grt-rtis_addr.adb | 73 | ||||
| -rw-r--r-- | src/grt/grt-rtis_addr.ads | 6 | ||||
| -rw-r--r-- | src/grt/grt-rtis_utils.adb | 42 | ||||
| -rw-r--r-- | src/grt/grt-vcd.adb | 4 | ||||
| -rw-r--r-- | src/grt/grt-waves.adb | 21 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap3.adb | 2 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-rtis.adb | 131 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-rtis.ads | 2 |
13 files changed, 438 insertions, 277 deletions
diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb index a83be7cc6..06ad210a8 100644 --- a/src/grt/grt-avhpi.adb +++ b/src/grt/grt-avhpi.adb @@ -146,9 +146,10 @@ package body Grt.Avhpi is case Res.N_Type.Kind is when Ghdl_Rtik_Subtype_Array => declare - St : constant Ghdl_Rtin_Subtype_Array_Acc := - To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type); - Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + St : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Res.N_Type); + Bt : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); begin Bound_To_Range @@ -203,10 +204,10 @@ package body Grt.Avhpi is when Ghdl_Rtik_Subtype_Array => if Is_Sig then El_Size := Ghdl_Index_Type - (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize); + (To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Sigsize); else El_Size := Ghdl_Index_Type - (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize); + (To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Valsize); end if; when others => Internal_Error ("add_index"); @@ -383,11 +384,11 @@ package body Grt.Avhpi is Obj => To_Ghdl_Rtin_Object_Acc (Rti)); when Ghdl_Rtik_Subtype_Array => declare - Atype : Ghdl_Rtin_Subtype_Array_Acc; - Bt : Ghdl_Rtin_Type_Array_Acc; + Atype : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Atype.Basetype); begin - Atype := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt := Atype.Basetype; if Atype.Name = Bt.Name then Res := (Kind => VhpiArrayTypeDeclK, Ctxt => Ctxt, @@ -933,8 +934,7 @@ package body Grt.Avhpi is case Atype.Kind is when Ghdl_Rtik_Subtype_Array => Rti_To_Handle - (To_Ghdl_Rti_Access (To_Ghdl_Rtin_Subtype_Array_Acc - (Atype).Basetype), + (To_Ghdl_Rtin_Subtype_Composite_Acc (Atype).Basetype, Ref.Ctxt, Res); if Res.Kind /= VhpiUndefined then Error := AvhpiErrorOk; @@ -955,18 +955,19 @@ package body Grt.Avhpi is end; when VhpiElemSubtype => declare - Base_Type : Ghdl_Rtin_Type_Array_Acc; + Base_Type : Ghdl_Rti_Access; begin case Ref.Atype.Kind is when Ghdl_Rtik_Subtype_Array => Base_Type := - To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype).Basetype; + To_Ghdl_Rtin_Subtype_Composite_Acc (Ref.Atype).Basetype; when Ghdl_Rtik_Type_Array => - Base_Type := To_Ghdl_Rtin_Type_Array_Acc (Ref.Atype); + Base_Type := Ref.Atype; when others => return; end case; - Rti_To_Handle (Base_Type.Element, Ref.Ctxt, Res); + Rti_To_Handle (To_Ghdl_Rtin_Type_Array_Acc (Base_Type).Element, + Ref.Ctxt, Res); if Res.Kind /= VhpiUndefined then Error := AvhpiErrorOk; end if; @@ -981,8 +982,7 @@ package body Grt.Avhpi is Ref : VhpiHandleT; Index : Natural; Res : out VhpiHandleT; - Error : out AvhpiErrorT) - is + Error : out AvhpiErrorT) is begin -- Default error. Error := AvhpiErrorNotImplemented; @@ -993,10 +993,10 @@ package body Grt.Avhpi is when VhpiSubtypeIndicK => if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then declare - Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc := - To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype); + Arr_Subtype : constant Ghdl_Rtin_Subtype_Composite_Acc + := To_Ghdl_Rtin_Subtype_Composite_Acc (Ref.Atype); Basetype : constant Ghdl_Rtin_Type_Array_Acc := - Arr_Subtype.Basetype; + To_Ghdl_Rtin_Type_Array_Acc (Arr_Subtype.Basetype); Idx : constant Ghdl_Index_Type := Ghdl_Index_Type (Index); Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1); diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb index 2a49281a7..bf77e56dc 100644 --- a/src/grt/grt-disp_rti.adb +++ b/src/grt/grt-disp_rti.adb @@ -192,19 +192,25 @@ package body Grt.Disp_Rti is -- end Get_Scalar_Type_Kind; procedure Disp_Array_Value_1 (Stream : FILEs; - El_Rti : Ghdl_Rti_Access; + Arr_Rti : Ghdl_Rtin_Type_Array_Acc; Ctxt : Rti_Context; - Rngs : Ghdl_Range_Array; - Rtis : Ghdl_Rti_Arr_Acc; Index : Ghdl_Index_Type; Obj : in out Address; + Bounds : in out Address; Is_Sig : Boolean) is + El_Rti : constant Ghdl_Rti_Access := Arr_Rti.Element; + Idx_Rti : constant Ghdl_Rti_Access := + Get_Base_Type (Arr_Rti.Indexes (Index)); + Last_Idx : constant Ghdl_Index_Type := Arr_Rti.Nbr_Dim - 1; + Rng : Ghdl_Range_Ptr; Length : Ghdl_Index_Type; + Bounds2 : Address; begin - Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index))); + Extract_Range (Bounds, Idx_Rti, Rng); + Length := Range_To_Length (Rng, Idx_Rti); - if Index = Rngs'Last + if Index = Last_Idx and then (El_Rti.Kind = Ghdl_Rtik_Type_B1 or else El_Rti.Kind = Ghdl_Rtik_Type_E8) then @@ -214,40 +220,32 @@ package body Grt.Disp_Rti is end if; Put (Stream, "("); - for I in 1 .. Length loop - if I /= 1 then - Put (Stream, ", "); - end if; - if Index = Rngs'Last then - Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig); - else - Disp_Array_Value_1 - (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig); - end if; - end loop; + if Length = 0 then + Put (Stream, "<>"); + -- FIXME: need to update bounds. + else + for I in 1 .. Length loop + Bounds2 := Bounds; + if I /= 1 then + Put (Stream, ", "); + end if; + if Index = Last_Idx then + Disp_Value (Stream, El_Rti, Ctxt, Obj, Bounds2, Is_Sig); + else + Disp_Array_Value_1 + (Stream, Arr_Rti, Ctxt, Index + 1, Obj, Bounds2, Is_Sig); + end if; + end loop; + Bounds := Bounds2; + end if; Put (Stream, ")"); end Disp_Array_Value_1; - procedure Disp_Array_Value (Stream : FILEs; - Rti : Ghdl_Rtin_Type_Array_Acc; - Ctxt : Rti_Context; - Vals : Ghdl_Uc_Array_Acc; - Is_Sig : Boolean) - is - Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; - Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); - Obj : Address; - begin - Bound_To_Range (Vals.Bounds, Rti, Rngs); - Obj := Vals.Base; - Disp_Array_Value_1 - (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig); - end Disp_Array_Value; - procedure Disp_Record_Value (Stream : FILEs; Rti : Ghdl_Rtin_Type_Record_Acc; Ctxt : Rti_Context; Obj : Address; + Bounds : in out Address; Is_Sig : Boolean) is El : Ghdl_Rtin_Element_Acc; @@ -266,21 +264,33 @@ package body Grt.Disp_Rti is else El_Addr := Obj + El.Val_Off; end if; - if Rti_Complex_Type (El.Eltype) then - El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; - end if; - Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig); + case El.Eltype.Kind is + when Ghdl_Rtik_Subtype_Array + | Ghdl_Rtik_Type_Record => + -- Element is an offset. + if Rti_Complex_Type (El.Eltype) then + El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; + end if; + when Ghdl_Rtik_Type_Array + | Ghdl_Rtik_Type_Unbounded_Record + | Ghdl_Rtik_Subtype_Unbounded_Record => + -- Element is an offset. + El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; + when others => + null; + end case; + Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Bounds, Is_Sig); end loop; Put (")"); -- FIXME: update ADDR. end Disp_Record_Value; - procedure Disp_Value - (Stream : FILEs; - Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Obj : in out Address; - Is_Sig : Boolean) + procedure Disp_Value (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Bounds : in out Address; + Is_Sig : Boolean) is begin case Rti.Kind is @@ -294,19 +304,19 @@ package body Grt.Disp_Rti is | Ghdl_Rtik_Type_B1 => Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig); when Ghdl_Rtik_Type_Array => - Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, - To_Ghdl_Uc_Array_Acc (Obj), Is_Sig); + Disp_Array_Value_1 + (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, 0, + Obj, Bounds, Is_Sig); when Ghdl_Rtik_Subtype_Array => declare - St : constant Ghdl_Rtin_Subtype_Array_Acc := - To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; - Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + St : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); + Bounds : Address; begin - Bound_To_Range - (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); - Disp_Array_Value_1 - (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, Obj, Is_Sig); + Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt); + Disp_Array_Value_1 (Stream, Bt, Ctxt, 0, Obj, Bounds, Is_Sig); end; when Ghdl_Rtik_Type_File => declare @@ -320,7 +330,19 @@ package body Grt.Disp_Rti is end; when Ghdl_Rtik_Type_Record => Disp_Record_Value - (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig); + (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, + Obj, Bounds, Is_Sig); + when Ghdl_Rtik_Subtype_Record => + declare + St : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Record_Acc := + To_Ghdl_Rtin_Type_Record_Acc (St.Basetype); + Bounds : Address; + begin + Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt); + Disp_Record_Value (Stream, Bt, Ctxt, Obj, Bounds, Is_Sig); + end; when Ghdl_Rtik_Type_Protected => Put (Stream, "Unhandled protected type"); when others => @@ -405,8 +427,15 @@ package body Grt.Disp_Rti is Put ("ghdl_rtik_type_array"); when Ghdl_Rtik_Subtype_Array => Put ("ghdl_rtik_subtype_array"); + when Ghdl_Rtik_Type_Record => Put ("ghdl_rtik_type_record"); + when Ghdl_Rtik_Type_Unbounded_Record => + Put ("ghdl_rtik_type_unbounded_record"); + when Ghdl_Rtik_Subtype_Unbounded_Record => + Put ("ghdl_rtik_subtype_unbounded_record"); + when Ghdl_Rtik_Subtype_Record => + Put ("ghdl_rtik_subtype_record"); when Ghdl_Rtik_Type_Access => Put ("ghdl_rtik_type_access"); @@ -433,6 +462,7 @@ package body Grt.Disp_Rti is Put ("ghdl_rtik_psl_endpoint"); when others => + -- Should never happen, except when not synchronized. Put ("ghdl_rtik_#"); Put_I32 (stdout, Ghdl_Rtik'Pos (Kind)); end case; @@ -523,71 +553,90 @@ package body Grt.Disp_Rti is end case; end Disp_Scalar_Type_Name; + procedure Disp_Type_Array_Bounds (Def : Ghdl_Rtin_Type_Array_Acc; + Bounds : in out Address) + is + Rng : Ghdl_Range_Ptr; + Idx_Base : Ghdl_Rti_Access; + begin + Put (" ("); + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + if Boolean'(False) then + Disp_Scalar_Type_Name (Def.Indexes (I)); + Put (" range "); + end if; + Idx_Base := Get_Base_Type (Def.Indexes (I)); + Extract_Range (Bounds, Idx_Base, Rng); + Disp_Range (stdout, Idx_Base, Rng); + end loop; + Put (")"); + end Disp_Type_Array_Bounds; + + procedure Disp_Type_Record_Bounds (Def : Ghdl_Rtin_Type_Record_Acc; + Bounds : in out Address) + is + El : Ghdl_Rtin_Element_Acc; + First : Boolean; + begin + Put (" ("); + First := True; + for I in 1 .. Def.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); + case El.Eltype.Kind is + when Ghdl_Rtik_Type_Array + | Ghdl_Rtik_Type_Unbounded_Record => + if First then + First := False; + else + Put (", "); + end if; + Put (El.Name); + case El.Eltype.Kind is + when Ghdl_Rtik_Type_Array => + Disp_Type_Array_Bounds + (To_Ghdl_Rtin_Type_Array_Acc (El.Eltype), Bounds); + when Ghdl_Rtik_Type_Unbounded_Record => + Disp_Type_Record_Bounds + (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype), Bounds); + when others => + raise Program_Error; + end case; + when others => + null; + end case; + end loop; + Put (")"); + end Disp_Type_Record_Bounds; + procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc; Bounds_Ptr : Address) is Bounds : Address; - - procedure Align (A : Ghdl_Index_Type) is - begin - Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); - end Align; - - procedure Update (S : Ghdl_Index_Type) is - begin - Bounds := Bounds + (S / Storage_Unit); - end Update; - - procedure Disp_Bounds (Def : Ghdl_Rti_Access) - is - Ndef : Ghdl_Rti_Access; - begin - if Bounds = Null_Address then - Put ("?"); - else - if Def.Kind = Ghdl_Rtik_Subtype_Scalar then - Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype; - else - Ndef := Def; - end if; - case Ndef.Kind is - when Ghdl_Rtik_Type_I32 => - Align (Ghdl_Range_I32'Alignment); - Disp_Range (stdout, Ndef, To_Ghdl_Range_Ptr (Bounds)); - Update (Ghdl_Range_I32'Size); - when Ghdl_Rtik_Type_B1 => - Align (Ghdl_Range_B1'Alignment); - Disp_Range (stdout, Ndef, To_Ghdl_Range_Ptr (Bounds)); - Update (Ghdl_Range_B1'Size); - when Ghdl_Rtik_Type_E8 => - Align (Ghdl_Range_E8'Alignment); - Disp_Range (stdout, Ndef, To_Ghdl_Range_Ptr (Bounds)); - Update (Ghdl_Range_E8'Size); - when others => - Disp_Kind (Ndef.Kind); - -- Bounds are not known anymore. - Bounds := Null_Address; - end case; - end if; - end Disp_Bounds; begin Disp_Name (Def.Name); if Bounds_Ptr = Null_Address then return; end if; - Put (" ("); Bounds := Bounds_Ptr; - for I in 0 .. Def.Nbr_Dim - 1 loop - if I /= 0 then - Put (", "); - end if; - Disp_Scalar_Type_Name (Def.Indexes (I)); - Put (" range "); - Disp_Bounds (Def.Indexes (I)); - end loop; - Put (")"); + Disp_Type_Array_Bounds (Def, Bounds); end Disp_Type_Array_Name; + procedure Disp_Type_Record_Name (Def : Ghdl_Rtin_Type_Record_Acc; + Bounds_Ptr : Address) + is + Bounds : Address; + begin + Disp_Name (Def.Name); + if Bounds_Ptr = Null_Address then + return; + end if; + Bounds := Bounds_Ptr; + Disp_Type_Record_Bounds (Def, Bounds); + end Disp_Type_Record_Name; + procedure Disp_Subtype_Scalar_Range (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context) is @@ -633,6 +682,19 @@ package body Grt.Disp_Rti is Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name); when Ghdl_Rtik_Type_Record => Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name); + when Ghdl_Rtik_Subtype_Record => + declare + Sdef : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Def); + begin + if Sdef.Name /= null then + Disp_Name (Sdef.Name); + else + Disp_Type_Record_Name + (To_Ghdl_Rtin_Type_Record_Acc (Sdef.Basetype), + Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); + end if; + end; when Ghdl_Rtik_Type_Array => declare Bounds : Address; @@ -647,14 +709,14 @@ package body Grt.Disp_Rti is end; when Ghdl_Rtik_Subtype_Array => declare - Sdef : Ghdl_Rtin_Subtype_Array_Acc; + Sdef : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Def); begin - Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def); if Sdef.Name /= null then Disp_Name (Sdef.Name); else Disp_Type_Array_Name - (Sdef.Basetype, + (To_Ghdl_Rtin_Type_Array_Acc (Sdef.Basetype), Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); end if; end; @@ -796,7 +858,7 @@ package body Grt.Disp_Rti is Ctxt : Rti_Context; Indent : Natural) is - Addr : Address; + Addr, Bounds : Address; Obj_Type : Ghdl_Rti_Access; begin Disp_Obj_Header (Obj, Indent); @@ -807,13 +869,25 @@ package body Grt.Disp_Rti is Put (" := "); -- FIXME: put this into a function. - if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array - or Obj_Type.Kind = Ghdl_Rtik_Type_Record) - and then Rti_Complex_Type (Obj_Type) - then - Addr := To_Addr_Acc (Addr).all; - end if; - Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig); + Bounds := Null_Address; + case Obj_Type.Kind is + when Ghdl_Rtik_Subtype_Array + | Ghdl_Rtik_Type_Record + | Ghdl_Rtik_Subtype_Record => + -- Object is a pointer. + if Rti_Complex_Type (Obj_Type) then + Addr := To_Addr_Acc (Addr).all; + end if; + when Ghdl_Rtik_Type_Array + | Ghdl_Rtik_Type_Unbounded_Record + | Ghdl_Rtik_Subtype_Unbounded_Record => + -- Object is a fat pointer. + Bounds := To_Ghdl_Uc_Array_Acc (Addr).Bounds; + Addr := To_Ghdl_Uc_Array_Acc (Addr).Base; + when others => + null; + end case; + Disp_Value (stdout, Obj_Type, Ctxt, Addr, Bounds, Is_Sig); New_Line; end Disp_Object; @@ -1057,11 +1131,12 @@ package body Grt.Disp_Rti is New_Line; end Disp_Type_Array_Decl; - procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc; + procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Composite_Acc; Ctxt : Rti_Context; Indent : Natural) is - Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype; + Basetype : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Def.Basetype); begin Disp_Indent (Indent); Disp_Kind (Def.Common.Kind); @@ -1123,6 +1198,27 @@ package body Grt.Disp_Rti is end loop; end Disp_Type_Record; + procedure Disp_Subtype_Record_Decl (Def : Ghdl_Rtin_Subtype_Composite_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Basetype : constant Ghdl_Rtin_Type_Record_Acc := + To_Ghdl_Rtin_Type_Record_Acc (Def.Basetype); + Bounds : Address; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Disp_Name (Basetype.Name); + if Def.Common.Kind = Ghdl_Rtik_Subtype_Record then + Bounds := Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt); + Disp_Type_Record_Bounds (Basetype, Bounds); + end if; + New_Line; + end Disp_Subtype_Record_Decl; + procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc; Ctxt : Rti_Context; Indent : Natural) @@ -1192,14 +1288,18 @@ package body Grt.Disp_Rti is (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); when Ghdl_Rtik_Subtype_Array => Disp_Subtype_Array_Decl - (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent); + (To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent); when Ghdl_Rtik_Type_Access | Ghdl_Rtik_Type_File => Disp_Type_File_Or_Access (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Type_Record => + when Ghdl_Rtik_Type_Record + | Ghdl_Rtik_Type_Unbounded_Record => Disp_Type_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Subtype_Record => + Disp_Subtype_Record_Decl + (To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent); when Ghdl_Rtik_Type_Protected => Disp_Type_Protected (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent); diff --git a/src/grt/grt-disp_rti.ads b/src/grt/grt-disp_rti.ads index 6033d2011..e1c63db88 100644 --- a/src/grt/grt-disp_rti.ads +++ b/src/grt/grt-disp_rti.ads @@ -37,6 +37,7 @@ package Grt.Disp_Rti is Rti : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : in out Address; + Bounds : in out Address; Is_Sig : Boolean); procedure Register; diff --git a/src/grt/grt-disp_tree.adb b/src/grt/grt-disp_tree.adb index ce2144445..0be17c9e3 100644 --- a/src/grt/grt-disp_tree.adb +++ b/src/grt/grt-disp_tree.adb @@ -120,12 +120,13 @@ package body Grt.Disp_Tree is To_Ghdl_Rtin_Block_Acc (Gen.Child); Iter : constant Ghdl_Rtin_Object_Acc := To_Ghdl_Rtin_Object_Acc (Bod.Children (0)); - Addr : Address; + Addr, Bounds : Address; begin Disp_Name (Gen.Name); Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Bounds := Null_Address; Put ('('); - Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, Bounds, False); Put (')'); end; when Ghdl_Rtik_Signal diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads index 4d5571147..685df3eae 100644 --- a/src/grt/grt-rtis.ads +++ b/src/grt/grt-rtis.ads @@ -29,7 +29,9 @@ with Ada.Unchecked_Conversion; package Grt.Rtis is pragma Preelaborate (Grt.Rtis); - -- Must be synchronized with trans-rtis.ads + -- To keep in sync with: + -- * trans-rtis.ads + -- * grt.disp_rti.Disp_Kind type Ghdl_Rtik is (Ghdl_Rtik_Top, Ghdl_Rtik_Library, -- use scalar @@ -73,24 +75,26 @@ package Grt.Rtis is Ghdl_Rtik_Type_Array, Ghdl_Rtik_Type_Record, + Ghdl_Rtik_Type_Unbounded_Record, Ghdl_Rtik_Type_File, Ghdl_Rtik_Subtype_Scalar, Ghdl_Rtik_Subtype_Array, Ghdl_Rtik_Subtype_Unconstrained_Array, - Ghdl_Rtik_Subtype_Record, - Ghdl_Rtik_Subtype_Access, -- 40 + Ghdl_Rtik_Subtype_Record, -- 40 + Ghdl_Rtik_Subtype_Unbounded_Record, + Ghdl_Rtik_Subtype_Access, Ghdl_Rtik_Type_Protected, Ghdl_Rtik_Element, + Ghdl_Rtik_Unit64, Ghdl_Rtik_Unitptr, - Ghdl_Rtik_Attribute_Transaction, Ghdl_Rtik_Attribute_Quiet, Ghdl_Rtik_Attribute_Stable, + Ghdl_Rtik_Psl_Assert, Ghdl_Rtik_Psl_Cover, - Ghdl_Rtik_Psl_Endpoint, Ghdl_Rtik_Error); @@ -128,6 +132,7 @@ package Grt.Rtis is -- 0 Max_Depth : Ghdl_Rti_Depth; end record; + pragma Convention (C, Ghdl_Rti_Common); type Ghdl_Rti_Access is access all Ghdl_Rti_Common; @@ -150,6 +155,7 @@ package Grt.Rtis is Nbr_Child : Ghdl_Index_Type; Children : Ghdl_Rti_Arr_Acc; end record; + pragma Convention (C, Ghdl_Rtin_Block); type Ghdl_Rtin_Block_Acc is access Ghdl_Rtin_Block; function To_Ghdl_Rtin_Block_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Acc); @@ -166,6 +172,7 @@ package Grt.Rtis is Size : Ghdl_Index_Type; Child : Ghdl_Rti_Access; end record; + pragma Convention (C, Ghdl_Rtin_Generate); type Ghdl_Rtin_Generate_Acc is access Ghdl_Rtin_Generate; function To_Ghdl_Rtin_Generate_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Generate_Acc); @@ -176,6 +183,7 @@ package Grt.Rtis is Block : Ghdl_Rtin_Block; Filename : Ghdl_C_String; end record; + pragma Convention (C, Ghdl_Rtin_Block_Filename); type Ghdl_Rtin_Block_Filename_Acc is access Ghdl_Rtin_Block_Filename; function To_Ghdl_Rtin_Block_Filename_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Filename_Acc); @@ -194,6 +202,7 @@ package Grt.Rtis is -- Line and column of the declaration. Linecol : Ghdl_Index_Type; end record; + pragma Convention (C, Ghdl_Rtin_Object); type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object; function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Object_Acc); @@ -208,6 +217,7 @@ package Grt.Rtis is Parent : Ghdl_Rti_Access; Instance : Ghdl_Rti_Access; -- Component or entity. end record; + pragma Convention (C, Ghdl_Rtin_Instance); type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance; function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Instance_Acc); @@ -235,6 +245,7 @@ package Grt.Rtis is Nbr_Child : Ghdl_Index_Type; Children : Ghdl_Rti_Arr_Acc; end record; + pragma Convention (C, Ghdl_Rtin_Component); type Ghdl_Rtin_Component_Acc is access Ghdl_Rtin_Component; function To_Ghdl_Rtin_Component_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Component_Acc); @@ -247,6 +258,7 @@ package Grt.Rtis is -- extended identifiers are represented as is too. Names : Ghdl_C_String_Array_Ptr; end record; + pragma Convention (C, Ghdl_Rtin_Type_Enum); type Ghdl_Rtin_Type_Enum_Acc is access Ghdl_Rtin_Type_Enum; function To_Ghdl_Rtin_Type_Enum_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Enum_Acc); @@ -255,6 +267,7 @@ package Grt.Rtis is Common : Ghdl_Rti_Common; Name : Ghdl_C_String; end record; + pragma Convention (C, Ghdl_Rtin_Type_Scalar); type Ghdl_Rtin_Type_Scalar_Acc is access Ghdl_Rtin_Type_Scalar; function To_Ghdl_Rtin_Type_Scalar_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Scalar_Acc); @@ -265,6 +278,7 @@ package Grt.Rtis is Basetype : Ghdl_Rti_Access; Range_Loc : Ghdl_Rti_Loc; end record; + pragma Convention (C, Ghdl_Rtin_Subtype_Scalar); type Ghdl_Rtin_Subtype_Scalar_Acc is access Ghdl_Rtin_Subtype_Scalar; function To_Ghdl_Rtin_Subtype_Scalar_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Scalar_Acc); @@ -286,31 +300,34 @@ package Grt.Rtis is Nbr_Dim : Ghdl_Index_Type; Indexes : Ghdl_Rti_Arr_Acc; end record; + pragma Convention (C, Ghdl_Rtin_Type_Array); type Ghdl_Rtin_Type_Array_Acc is access Ghdl_Rtin_Type_Array; function To_Ghdl_Rtin_Type_Array_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Array_Acc); function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion (Source => Ghdl_Rtin_Type_Array_Acc, Target => Ghdl_Rti_Access); - type Ghdl_Rtin_Subtype_Array is record + type Ghdl_Rtin_Subtype_Composite is record Common : Ghdl_Rti_Common; Name : Ghdl_C_String; - Basetype : Ghdl_Rtin_Type_Array_Acc; + Basetype : Ghdl_Rti_Access; Bounds : Ghdl_Rti_Loc; Valsize : Ghdl_Rti_Loc; Sigsize : Ghdl_Rti_Loc; end record; - type Ghdl_Rtin_Subtype_Array_Acc is access Ghdl_Rtin_Subtype_Array; - function To_Ghdl_Rtin_Subtype_Array_Acc is new Ada.Unchecked_Conversion - (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Array_Acc); + pragma Convention (C, Ghdl_Rtin_Subtype_Composite); + type Ghdl_Rtin_Subtype_Composite_Acc is access Ghdl_Rtin_Subtype_Composite; + function To_Ghdl_Rtin_Subtype_Composite_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Composite_Acc); function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion - (Source => Ghdl_Rtin_Subtype_Array_Acc, Target => Ghdl_Rti_Access); + (Source => Ghdl_Rtin_Subtype_Composite_Acc, Target => Ghdl_Rti_Access); type Ghdl_Rtin_Type_Fileacc is record Common : Ghdl_Rti_Common; Name : Ghdl_C_String; Base : Ghdl_Rti_Access; end record; + pragma Convention (C, Ghdl_Rtin_Type_Fileacc); type Ghdl_Rtin_Type_Fileacc_Acc is access Ghdl_Rtin_Type_Fileacc; function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc); @@ -322,6 +339,7 @@ package Grt.Rtis is Val_Off : Ghdl_Index_Type; Sig_Off : Ghdl_Index_Type; end record; + pragma Convention (C, Ghdl_Rtin_Element); type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element; function To_Ghdl_Rtin_Element_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Element_Acc); @@ -332,6 +350,7 @@ package Grt.Rtis is Nbrel : Ghdl_Index_Type; Elements : Ghdl_Rti_Arr_Acc; end record; + pragma Convention (C, Ghdl_Rtin_Type_Record); type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record; function To_Ghdl_Rtin_Type_Record_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Record_Acc); @@ -341,6 +360,7 @@ package Grt.Rtis is Name : Ghdl_C_String; Value : Ghdl_I64; end record; + pragma Convention (C, Ghdl_Rtin_Unit64); type Ghdl_Rtin_Unit64_Acc is access Ghdl_Rtin_Unit64; function To_Ghdl_Rtin_Unit64_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unit64_Acc); @@ -350,6 +370,7 @@ package Grt.Rtis is Name : Ghdl_C_String; Addr : Ghdl_Value_Ptr; end record; + pragma Convention (C, Ghdl_Rtin_Unitptr); type Ghdl_Rtin_Unitptr_Acc is access Ghdl_Rtin_Unitptr; function To_Ghdl_Rtin_Unitptr_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unitptr_Acc); @@ -362,6 +383,7 @@ package Grt.Rtis is Nbr : Ghdl_Index_Type; Units : Ghdl_Rti_Arr_Acc; end record; + pragma Convention (C, Ghdl_Rtin_Type_Physical); type Ghdl_Rtin_Type_Physical_Acc is access Ghdl_Rtin_Type_Physical; function To_Ghdl_Rtin_Type_Physical_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Physical_Acc); @@ -382,6 +404,7 @@ package Grt.Rtis is Rti : Ghdl_Rti_Access; Parent : Ghdl_Component_Link_Acc; end record; + pragma Convention (C, Ghdl_Entity_Link_Type); type Ghdl_Entity_Link_Acc is access Ghdl_Entity_Link_Type; @@ -392,6 +415,7 @@ package Grt.Rtis is Instance : Ghdl_Entity_Link_Acc; Stmt : Ghdl_Rti_Access; end record; + pragma Convention (C, Ghdl_Component_Link_Type); function To_Ghdl_Component_Link_Acc is new Ada.Unchecked_Conversion (Source => Address, Target => Ghdl_Component_Link_Acc); diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb index 8be2a2e75..7be70eb02 100644 --- a/src/grt/grt-rtis_addr.adb +++ b/src/grt/grt-rtis_addr.adb @@ -239,12 +239,10 @@ package body Grt.Rtis_Addr is end if; end Get_Instance_Context; - procedure Bound_To_Range (Bounds_Addr : Address; - Def : Ghdl_Rtin_Type_Array_Acc; - Res : out Ghdl_Range_Array) + procedure Extract_Range (Bounds : in out Address; + Def : Ghdl_Rti_Access; + Rng : out Ghdl_Range_Ptr) is - Bounds : Address; - procedure Align (A : Ghdl_Index_Type) is begin Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); @@ -254,7 +252,37 @@ package body Grt.Rtis_Addr is begin Bounds := Bounds + (S / Storage_Unit); end Update; + begin + if Bounds = Null_Address then + -- Propagate failure. + Rng := null; + return; + end if; + case Def.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Rng := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_I32'Size); + when Ghdl_Rtik_Type_B1 => + Align (Ghdl_Range_B1'Alignment); + Rng := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_B1'Size); + when Ghdl_Rtik_Type_E8 => + Align (Ghdl_Range_E8'Alignment); + Rng := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E8'Size); + when others => + -- Bounds are not known anymore. + Rng := null; + end case; + end Extract_Range; + + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array) + is + Bounds : Address; Idx_Def : Ghdl_Rti_Access; begin if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then @@ -265,45 +293,18 @@ package body Grt.Rtis_Addr is for I in 0 .. Def.Nbr_Dim - 1 loop Idx_Def := Def.Indexes (I); - - if Bounds = Null_Address then - Res (I) := null; - else - Idx_Def := Get_Base_Type (Idx_Def); - case Idx_Def.Kind is - when Ghdl_Rtik_Type_I32 => - Align (Ghdl_Range_I32'Alignment); - Res (I) := To_Ghdl_Range_Ptr (Bounds); - Update (Ghdl_Range_I32'Size); - when Ghdl_Rtik_Type_B1 => - Align (Ghdl_Range_B1'Alignment); - Res (I) := To_Ghdl_Range_Ptr (Bounds); - Update (Ghdl_Range_B1'Size); - when Ghdl_Rtik_Type_E8 => - Align (Ghdl_Range_E8'Alignment); - Res (I) := To_Ghdl_Range_Ptr (Bounds); - Update (Ghdl_Range_E8'Size); - when Ghdl_Rtik_Type_E32 => - Align (Ghdl_Range_E32'Alignment); - Res (I) := To_Ghdl_Range_Ptr (Bounds); - Update (Ghdl_Range_E32'Size); - when others => - -- Bounds are not known anymore. - Bounds := Null_Address; - end case; - end if; + Idx_Def := Get_Base_Type (Idx_Def); + Extract_Range (Bounds, Idx_Def, Res (I)); end loop; end Bound_To_Range; - function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access - is + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access is begin case Atype.Kind is when Ghdl_Rtik_Subtype_Scalar => return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype; when Ghdl_Rtik_Subtype_Array => - return To_Ghdl_Rti_Access - (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype); + return To_Ghdl_Rtin_Subtype_Composite_Acc (Atype).Basetype; when Ghdl_Rtik_Type_E8 | Ghdl_Rtik_Type_E32 | Ghdl_Rtik_Type_B1 => diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads index 574f5cba5..550576733 100644 --- a/src/grt/grt-rtis_addr.ads +++ b/src/grt/grt-rtis_addr.ads @@ -85,6 +85,12 @@ package Grt.Rtis_Addr is Ctxt : Rti_Context; Sub_Ctxt : out Rti_Context); + -- Extract range RNG of type DEF from BOUNDS. BOUNDS is updated to the + -- next range. DEF must be a base type. + procedure Extract_Range (Bounds : in out Address; + Def : Ghdl_Rti_Access; + Rng : out Ghdl_Range_Ptr); + -- Extract range of every dimension from bounds. procedure Bound_To_Range (Bounds_Addr : Address; Def : Ghdl_Rtin_Type_Array_Acc; diff --git a/src/grt/grt-rtis_utils.adb b/src/grt/grt-rtis_utils.adb index a43a20066..e520e5435 100644 --- a/src/grt/grt-rtis_utils.adb +++ b/src/grt/grt-rtis_utils.adb @@ -267,14 +267,17 @@ package body Grt.Rtis_Utils is end case; end Pos_To_Vstring; - procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access; - Rngs : Ghdl_Range_Array; - Rtis : Ghdl_Rti_Arr_Acc; + procedure Handle_Array_1 (Arr_Rti : Ghdl_Rtin_Type_Array_Acc; + Bounds : in out Address; Index : Ghdl_Index_Type) is + Idx_Rti : constant Ghdl_Rti_Access := Arr_Rti.Indexes (Index); + Base_Type : constant Ghdl_Rti_Access := Get_Base_Type (Idx_Rti); + El_Rti : constant Ghdl_Rti_Access := Arr_Rti.Element; + Last_Index : constant Ghdl_Index_Type := Arr_Rti.Nbr_Dim - 1; + Rng : Ghdl_Range_Ptr; Len : Ghdl_Index_Type; P : Natural; - Base_Type : Ghdl_Rti_Access; begin P := Length (Name); if Index = 0 then @@ -283,16 +286,16 @@ package body Grt.Rtis_Utils is Append (Name, ','); end if; - Base_Type := Get_Base_Type (Rtis (Index)); - Len := Range_To_Length (Rngs (Index), Base_Type); + Extract_Range (Bounds, Base_Type, Rng); + Len := Range_To_Length (Rng, Base_Type); for I in 1 .. Len loop - Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1); - if Index = Rngs'Last then + Pos_To_Vstring (Name, Base_Type, Rng, I - 1); + if Index = Last_Index then Append (Name, ')'); Handle_Any (El_Rti); else - Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1); + Handle_Array_1 (Arr_Rti, Bounds, Index + 1); end if; Truncate (Name, P + 1); end loop; @@ -302,12 +305,11 @@ package body Grt.Rtis_Utils is procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc; Vals : Ghdl_Uc_Array_Acc) is - Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; - Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + Bounds : Address; begin - Bound_To_Range (Vals.Bounds, Rti, Rngs); Addr := Vals.Base; - Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0); + Bounds := Vals.Bounds; + Handle_Array_1 (Rti, Bounds, 0); end Handle_Array; procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc) @@ -356,14 +358,14 @@ package body Grt.Rtis_Utils is To_Ghdl_Uc_Array_Acc (Addr)); when Ghdl_Rtik_Subtype_Array => declare - St : constant Ghdl_Rtin_Subtype_Array_Acc := - To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; - Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + St : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); + Bounds : Address; begin - Bound_To_Range - (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); - Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0); + Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt); + Handle_Array_1 (Bt, Bounds, 0); end; -- when Ghdl_Rtik_Type_File => -- declare diff --git a/src/grt/grt-vcd.adb b/src/grt/grt-vcd.adb index eab5fa89a..ca0d7c6e5 100644 --- a/src/grt/grt-vcd.adb +++ b/src/grt/grt-vcd.adb @@ -352,9 +352,9 @@ package body Grt.Vcd is Kind := Rti_To_Vcd_Kind (Rti); when Ghdl_Rtik_Subtype_Array => declare - St : Ghdl_Rtin_Subtype_Array_Acc; + St : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); begin - St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); Kind := Rti_To_Vcd_Kind (St.Basetype); Irange := To_Ghdl_Range_Ptr (Loc_To_Addr (St.Common.Depth, St.Bounds, diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb index 33edffdf2..43ae4ec73 100644 --- a/src/grt/grt-waves.adb +++ b/src/grt/grt-waves.adb @@ -623,17 +623,17 @@ package body Grt.Waves is end; when Ghdl_Rtik_Subtype_Array => declare - Arr : Ghdl_Rtin_Subtype_Array_Acc; + Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); B_Ctxt : Rti_Context; begin - Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); Create_String_Id (Arr.Name); if Rti_Complex_Type (Rti) then B_Ctxt := Ctxt; else B_Ctxt := N_Ctxt; end if; - Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt); + Create_Type (Arr.Basetype, B_Ctxt); end; when Ghdl_Rtik_Type_Array => declare @@ -1313,20 +1313,21 @@ package body Grt.Waves is end; when Ghdl_Rtik_Subtype_Array => declare - Arr : Ghdl_Rtin_Subtype_Array_Acc; + Arr : constant Ghdl_Rtin_Subtype_Composite_Acc := + To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); begin - Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); Write_String_Id (Arr.Name); - Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt); + Write_Type_Id (Arr.Basetype, Ctxt); declare - Rngs : Ghdl_Range_Array - (0 .. Arr.Basetype.Nbr_Dim - 1); + Bt : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Arr.Basetype); + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); begin Bound_To_Range (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt), - Arr.Basetype, Rngs); + Bt, Rngs); for I in Rngs'Range loop - Write_Range (Arr.Basetype.Indexes (I), Rngs (I)); + Write_Range (Bt.Indexes (I), Rngs (I)); end loop; end; end; diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index 8f6ae4c12..969be57ad 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -1225,6 +1225,8 @@ package body Trans.Chap3 is -- By default, use the same representation as the type mark. Info.all := Type_Mark_Info.all; Info.S := Ortho_Info_Subtype_Record_Init; + -- However, it is a different subtype which has its own rti. + Info.Type_Rti := O_Dnode_Null; if Get_Constraint_State (Def) /= Fully_Constrained or else not Has_New_Constraints diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index 96abfc206..dd60c817a 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -105,14 +105,14 @@ package body Trans.Rtis is Ghdl_Rtin_Type_Array_Nbrdim : O_Fnode; Ghdl_Rtin_Type_Array_Indexes : O_Fnode; - -- Node for an array subtype. - Ghdl_Rtin_Subtype_Array : O_Tnode; - Ghdl_Rtin_Subtype_Array_Common : O_Fnode; - Ghdl_Rtin_Subtype_Array_Name : O_Fnode; - Ghdl_Rtin_Subtype_Array_Basetype : O_Fnode; - Ghdl_Rtin_Subtype_Array_Bounds : O_Fnode; - Ghdl_Rtin_Subtype_Array_Valsize : O_Fnode; - Ghdl_Rtin_Subtype_Array_Sigsize : O_Fnode; + -- Node for a composite subtype. + Ghdl_Rtin_Subtype_Composite : O_Tnode; + Ghdl_Rtin_Subtype_Composite_Common : O_Fnode; + Ghdl_Rtin_Subtype_Composite_Name : O_Fnode; + Ghdl_Rtin_Subtype_Composite_Basetype : O_Fnode; + Ghdl_Rtin_Subtype_Composite_Bounds : O_Fnode; + Ghdl_Rtin_Subtype_Composite_Valsize : O_Fnode; + Ghdl_Rtin_Subtype_Composite_Sigsize : O_Fnode; -- Node for a record element. Ghdl_Rtin_Element : O_Tnode; @@ -271,6 +271,9 @@ package body Trans.Rtis is (Constr, Get_Identifier ("__ghdl_rtik_type_record"), Ghdl_Rtik_Type_Record); New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_unbounded_record"), + Ghdl_Rtik_Type_Unbounded_Record); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_type_file"), Ghdl_Rtik_Type_File); New_Enum_Literal @@ -287,6 +290,9 @@ package body Trans.Rtis is (Constr, Get_Identifier ("__ghdl_rtik_subtype_record"), Ghdl_Rtik_Subtype_Record); New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_unbounded_record"), + Ghdl_Rtik_Subtype_Unbounded_Record); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_subtype_access"), Ghdl_Rtik_Subtype_Access); New_Enum_Literal @@ -596,26 +602,26 @@ package body Trans.Rtis is Ghdl_Rtin_Type_Array); end; - -- subtype_Array. + -- subtype_composite. declare Constr : O_Element_List; begin Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Common, + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Common, Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Name, + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Name, Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Basetype, + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Basetype, Get_Identifier ("basetype"), Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Bounds, + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Bounds, Get_Identifier ("bounds"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Valsize, + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Valsize, Get_Identifier ("val_size"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Sigsize, + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Sigsize, Get_Identifier ("sig_size"), Ghdl_Ptr_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Array); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_array"), - Ghdl_Rtin_Subtype_Array); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Composite); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_composite"), + Ghdl_Rtin_Subtype_Composite); end; -- type record. @@ -1365,10 +1371,6 @@ package body Trans.Rtis is Base_Type := Get_Type (Get_File_Type_Mark (Atype)); Base := Generate_Type_Definition (Base_Type); Kind := Ghdl_Rtik_Type_File; - when Iir_Kind_Record_Subtype_Definition => - Base_Type := Get_Base_Type (Atype); - Base := Get_Info (Base_Type).Type_Rti; - Kind := Ghdl_Rtik_Subtype_Record; when Iir_Kind_Access_Subtype_Definition => Base_Type := Get_Base_Type (Atype); Base := Get_Info (Base_Type).Type_Rti; @@ -1508,12 +1510,11 @@ package body Trans.Rtis is Finish_Init_Value (Info.Type_Rti, Val); end Generate_Array_Type_Definition; - procedure Generate_Array_Subtype_Definition - (Atype : Iir_Array_Subtype_Definition) + procedure Generate_Composite_Subtype_Definition (Atype : Iir) is - Base_Type : Iir; - Base_Info : Type_Info_Acc; - Info : Type_Info_Acc; + Info : constant Type_Info_Acc := Get_Info (Atype); + Base_Type : constant Iir := Get_Base_Type (Atype); + Base_Info : constant Type_Info_Acc := Get_Info (Base_Type); Aggr : O_Record_Aggr_List; Val : O_Cnode; Base_Rti : O_Dnode; @@ -1521,31 +1522,15 @@ package body Trans.Rtis is Bounds : Var_Type; Name : O_Dnode; Kind : O_Cnode; - Mark : Id_Mark_Type; Depth : Rti_Depth_Type; begin - -- FIXME: temporary work-around - if Get_Constraint_State (Atype) /= Fully_Constrained then - return; - end if; - - Info := Get_Info (Atype); - - Base_Type := Get_Base_Type (Atype); - Base_Info := Get_Info (Base_Type); - if Base_Info.Type_Rti = O_Dnode_Null then - Push_Identifier_Prefix (Mark, "BT"); - Base_Rti := Generate_Type_Definition (Base_Type); - Pop_Identifier_Prefix (Mark); - end if; - Bounds := Info.S.Composite_Bounds; Depth := Get_Depth_From_Var (Bounds); Info.B.Rti_Max_Depth := Rti_Depth_Type'Max (Depth, Base_Info.B.Rti_Max_Depth); -- Generate node. - Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Array); + Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Composite); if Global_Storage = O_Storage_External then return; @@ -1554,14 +1539,18 @@ package body Trans.Rtis is Name := Generate_Type_Name (Atype); Start_Init_Value (Info.Type_Rti); - Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Array); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Composite); case Info.Type_Mode is when Type_Mode_Array => Kind := Ghdl_Rtik_Subtype_Array; - when Type_Mode_Fat_Array => + when Type_Mode_Unbounded_Array => Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; + when Type_Mode_Record => + Kind := Ghdl_Rtik_Subtype_Record; + when Type_Mode_Unbounded_Record => + Kind := Ghdl_Rtik_Subtype_Unbounded_Record; when others => - Error_Kind ("generate_array_subtype_definition", Atype); + Error_Kind ("generate_composite_subtype_definition", Atype); end case; New_Record_Aggr_El (Aggr, @@ -1577,7 +1566,8 @@ package body Trans.Rtis is New_Record_Aggr_El (Aggr, Val); for I in Mode_Value .. Mode_Signal loop case Info.Type_Mode is - when Type_Mode_Array => + when Type_Mode_Array + | Type_Mode_Record => Val := Get_Null_Loc; if Info.Ortho_Type (I) /= O_Tnode_Null then if Is_Complex_Type (Info) then @@ -1589,16 +1579,41 @@ package body Trans.Rtis is Ghdl_Ptr_Type); end if; end if; - when Type_Mode_Fat_Array => + when Type_Mode_Unbounded_Array + | Type_Mode_Unbounded_Record => Val := Get_Null_Loc; when others => - Error_Kind ("generate_array_subtype_definition", Atype); + Error_Kind ("generate_composite_subtype_definition", Atype); end case; New_Record_Aggr_El (Aggr, Val); end loop; Finish_Record_Aggr (Aggr, Val); Finish_Init_Value (Info.Type_Rti, Val); + end Generate_Composite_Subtype_Definition; + + procedure Generate_Array_Subtype_Definition + (Atype : Iir_Array_Subtype_Definition) + is + Base_Type : constant Iir := Get_Base_Type (Atype); + Base_Info : constant Type_Info_Acc := Get_Info (Base_Type); + Base_Rti : O_Dnode; + pragma Unreferenced (Base_Rti); + Mark : Id_Mark_Type; + begin + -- FIXME: temporary work-around + if Get_Constraint_State (Atype) /= Fully_Constrained then + return; + end if; + + -- Generate base type (when anonymous). + if Base_Info.Type_Rti = O_Dnode_Null then + Push_Identifier_Prefix (Mark, "BT"); + Base_Rti := Generate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + end if; + + Generate_Composite_Subtype_Definition (Atype); end Generate_Array_Subtype_Definition; procedure Generate_Record_Type_Definition (Atype : Iir) @@ -1675,15 +1690,20 @@ package body Trans.Rtis is declare Aggr : O_Record_Aggr_List; Name : O_Dnode; + Rtik : O_Cnode; begin Name := Generate_Type_Name (Atype); Start_Init_Value (Info.Type_Rti); Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record); + if Get_Constraint_State (Atype) = Fully_Constrained then + Rtik := Ghdl_Rtik_Type_Record; + else + Rtik := Ghdl_Rtik_Type_Unbounded_Record; + end if; New_Record_Aggr_El (Aggr, - Generate_Common_Type (Ghdl_Rtik_Type_Record, 0, Max_Depth, - Type_To_Mode (Atype))); + Generate_Common_Type (Rtik, 0, Max_Depth, Type_To_Mode (Atype))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Unsigned_Literal @@ -1750,8 +1770,9 @@ package body Trans.Rtis is when Iir_Kind_Access_Type_Definition | Iir_Kind_File_Type_Definition => Generate_Fileacc_Type_Definition (Atype); - when Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Access_Subtype_Definition => + when Iir_Kind_Record_Subtype_Definition => + Generate_Composite_Subtype_Definition (Atype); + when Iir_Kind_Access_Subtype_Definition => -- FIXME: No separate infos (yet). Info.Type_Rti := Get_Info (Get_Base_Type (Atype)).Type_Rti; when Iir_Kind_Record_Type_Definition => @@ -1787,7 +1808,7 @@ package body Trans.Rtis is when Iir_Kind_Array_Type_Definition => Rti_Type := Ghdl_Rtin_Type_Array; when Iir_Kind_Array_Subtype_Definition => - Rti_Type := Ghdl_Rtin_Subtype_Array; + Rti_Type := Ghdl_Rtin_Subtype_Composite; when Iir_Kind_Access_Type_Definition | Iir_Kind_File_Type_Definition => Rti_Type := Ghdl_Rtin_Type_Fileacc; diff --git a/src/vhdl/translate/trans-rtis.ads b/src/vhdl/translate/trans-rtis.ads index 8f51957f3..73bc514e0 100644 --- a/src/vhdl/translate/trans-rtis.ads +++ b/src/vhdl/translate/trans-rtis.ads @@ -54,11 +54,13 @@ package Trans.Rtis is Ghdl_Rtik_Type_Access : O_Cnode; Ghdl_Rtik_Type_Array : O_Cnode; Ghdl_Rtik_Type_Record : O_Cnode; + Ghdl_Rtik_Type_Unbounded_Record : O_Cnode; Ghdl_Rtik_Type_File : O_Cnode; Ghdl_Rtik_Subtype_Scalar : O_Cnode; Ghdl_Rtik_Subtype_Array : O_Cnode; Ghdl_Rtik_Subtype_Unconstrained_Array : O_Cnode; Ghdl_Rtik_Subtype_Record : O_Cnode; + Ghdl_Rtik_Subtype_Unbounded_Record : O_Cnode; Ghdl_Rtik_Subtype_Access : O_Cnode; Ghdl_Rtik_Type_Protected : O_Cnode; Ghdl_Rtik_Element : O_Cnode; |