From 86bfd8ac497f4e4a753ddbd9d382b377d876dcbc Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Mon, 13 Jan 2014 02:40:01 +0100 Subject: Fix bug20312: rewrite of complex types. Fix crashes in sem_expr when string literals are used in range exprs. --- translate/grt/grt-avhpi.adb | 4 +-- translate/grt/grt-disp_rti.adb | 45 ++++++++++------------------- translate/grt/grt-disp_signals.adb | 2 +- translate/grt/grt-rtis.ads | 28 ++++++++++++++++-- translate/grt/grt-rtis_addr.adb | 22 ++++++++++++++ translate/grt/grt-rtis_addr.ads | 15 ++++++++++ translate/grt/grt-rtis_utils.adb | 56 ++++++++++-------------------------- translate/grt/grt-vcd.adb | 11 ------- translate/grt/grt-waves.adb | 59 +++++++++++++++++--------------------- 9 files changed, 122 insertions(+), 120 deletions(-) (limited to 'translate/grt') diff --git a/translate/grt/grt-avhpi.adb b/translate/grt/grt-avhpi.adb index a6565cf..58b9870 100644 --- a/translate/grt/grt-avhpi.adb +++ b/translate/grt/grt-avhpi.adb @@ -341,8 +341,7 @@ package body Grt.Avhpi is Res := (Kind => VhpiGenericDeclK, Ctxt => Ctxt, Obj => To_Ghdl_Rtin_Object_Acc (Rti)); - when Ghdl_Rtik_Subtype_Array - | Ghdl_Rtik_Subtype_Array_Ptr => + when Ghdl_Rtik_Subtype_Array => declare Atype : Ghdl_Rtin_Subtype_Array_Acc; Bt : Ghdl_Rtin_Type_Array_Acc; @@ -429,7 +428,6 @@ package body Grt.Avhpi is | Ghdl_Rtik_Signal | Ghdl_Rtik_Type_Array | Ghdl_Rtik_Subtype_Array - | Ghdl_Rtik_Subtype_Array_Ptr | Ghdl_Rtik_Type_E8 | Ghdl_Rtik_Type_E32 | Ghdl_Rtik_Type_B2 diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb index 8a5405f..942a595 100644 --- a/translate/grt/grt-disp_rti.adb +++ b/translate/grt/grt-disp_rti.adb @@ -225,20 +225,6 @@ package body Grt.Disp_Rti is Disp_Array_Value_1 (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig); end; - when Ghdl_Rtik_Subtype_Array_Ptr => - 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); - B : Address; - begin - Bound_To_Range - (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); - B := To_Addr_Acc (Obj).all; - Disp_Array_Value_1 - (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig); - end; when Ghdl_Rtik_Type_File => declare Vptr : Ghdl_Value_Ptr; @@ -328,8 +314,6 @@ package body Grt.Disp_Rti is Put ("ghdl_rtik_type_array"); when Ghdl_Rtik_Subtype_Array => Put ("ghdl_rtik_subtype_array"); - when Ghdl_Rtik_Subtype_Array_Ptr => - Put ("ghdl_rtik_subtype_array_ptr"); when Ghdl_Rtik_Type_Record => Put ("ghdl_rtik_type_record"); @@ -534,8 +518,7 @@ package body Grt.Disp_Rti is Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def), Bounds); end; - when Ghdl_Rtik_Subtype_Array - | Ghdl_Rtik_Subtype_Array_Ptr => + when Ghdl_Rtik_Subtype_Array => declare Sdef : Ghdl_Rtin_Subtype_Array_Acc; begin @@ -649,7 +632,7 @@ package body Grt.Disp_Rti is -- FIXME: put this into a function. if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array or Obj_Type.Kind = Ghdl_Rtik_Type_Record) - and then Obj_Type.Mode = 1 + and then Rti_Complex_Type (Obj_Type) then Addr := To_Addr_Acc (Addr).all; end if; @@ -811,16 +794,16 @@ package body Grt.Disp_Rti is Put (" = "); case Bt.Kind is when Ghdl_Rtik_Type_P64 => - if Bt.Mode = 0 then - Put_I64 (stdout, Unit.Value.Unit_64); - else + if Rti_Non_Static_Physical_Type (Bt) then Put_I64 (stdout, Unit.Value.Unit_Addr.I64); + else + Put_I64 (stdout, Unit.Value.Unit_64); end if; when Ghdl_Rtik_Type_P32 => - if Bt.Mode = 0 then - Put_I32 (stdout, Unit.Value.Unit_32); - else + if Rti_Non_Static_Physical_Type (Bt) then Put_I32 (stdout, Unit.Value.Unit_Addr.I32); + else + Put_I32 (stdout, Unit.Value.Unit_32); end if; when others => null; @@ -861,6 +844,7 @@ package body Grt.Disp_Rti is Ctxt : Rti_Context; Indent : Natural) is + Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype; begin Disp_Indent (Indent); Disp_Kind (Def.Common.Kind); @@ -868,9 +852,11 @@ package body Grt.Disp_Rti is Disp_Name (Def.Name); Put (" is "); Disp_Type_Array_Name - (Def.Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); - -- FIXME: If the subtype array contains a type array, then the - -- definition is not complete: display the element type. + (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); + if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then + Put (" of "); + Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); + end if; New_Line; end Disp_Subtype_Array_Decl; @@ -970,8 +956,7 @@ package body Grt.Disp_Rti is when Ghdl_Rtik_Type_Array => Disp_Type_Array_Decl (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Subtype_Array - | Ghdl_Rtik_Subtype_Array_Ptr => + when Ghdl_Rtik_Subtype_Array => Disp_Subtype_Array_Decl (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent); when Ghdl_Rtik_Type_Access diff --git a/translate/grt/grt-disp_signals.adb b/translate/grt/grt-disp_signals.adb index 47f67c2..8a754c9 100644 --- a/translate/grt/grt-disp_signals.adb +++ b/translate/grt/grt-disp_signals.adb @@ -245,7 +245,7 @@ package body Grt.Disp_Signals is when Ghdl_Rtik_Attribute_Transaction => Put (stdout, Ctxt); Put ("."); - Put (Stream, " 'quiet"); + Put (Stream, " 'transaction"); when others => null; end case; diff --git a/translate/grt/grt-rtis.ads b/translate/grt/grt-rtis.ads index 2276adf..c190711 100644 --- a/translate/grt/grt-rtis.ads +++ b/translate/grt/grt-rtis.ads @@ -59,7 +59,6 @@ package Grt.Rtis is Ghdl_Rtik_Type_File, Ghdl_Rtik_Subtype_Scalar, Ghdl_Rtik_Subtype_Array, - Ghdl_Rtik_Subtype_Array_Ptr, Ghdl_Rtik_Subtype_Unconstrained_Array, Ghdl_Rtik_Subtype_Record, Ghdl_Rtik_Subtype_Access, @@ -78,10 +77,27 @@ package Grt.Rtis is type Ghdl_Rti_U8 is mod 2 ** 8; for Ghdl_Rti_U8'Size use 8; + -- This structure is common to all RTI nodes. type Ghdl_Rti_Common is record + -- Kind of the RTI, list is above. Kind : Ghdl_Rtik; + Depth : Ghdl_Rti_Depth; + + -- * array types and subtypes, record types, protected types: + -- bit 0: set for complex type + -- bit 1: set for anonymous type definition + -- bit 2: set only for physical type with non-static units (time) + -- * signals: + -- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in) + -- bit 4-5: kind (0 : none, 1 : register, 2 : bus) + -- bit 6: set if has 'active attributes Mode : Ghdl_Rti_U8; + + -- * Types and subtypes definition: + -- maximum depth of all RTIs referenced. + -- * Others: + -- 0 Max_Depth : Ghdl_Rti_Depth; end record; @@ -202,6 +218,14 @@ package Grt.Rtis is Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1; Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1; + -- True if the type is anonymous + Ghdl_Rti_Type_Anonymous_Mask : constant Ghdl_Rti_U8 := 2; + Ghdl_Rti_Type_Anonymous : constant Ghdl_Rti_U8 := 2; + + -- True if the physical type is not static + Ghdl_Rti_Type_Non_Static_Mask : constant Ghdl_Rti_U8 := 4; + Ghdl_Rti_Type_Non_Static : constant Ghdl_Rti_U8 := 4; + type Ghdl_Rtin_Type_Array is record Common : Ghdl_Rti_Common; Name : Ghdl_C_String; @@ -282,7 +306,7 @@ package Grt.Rtis is function To_Ghdl_Rtin_Unit_Acc is new Ada.Unchecked_Conversion (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unit_Acc); - -- Mode field is set to 1 if units value is per address. Otherwise, + -- Mode field is set to 4 if units value is per address. Otherwise, -- mode is 0. type Ghdl_Rtin_Type_Physical is record Common : Ghdl_Rti_Common; diff --git a/translate/grt/grt-rtis_addr.adb b/translate/grt/grt-rtis_addr.adb index 784698d..f846f38 100644 --- a/translate/grt/grt-rtis_addr.adb +++ b/translate/grt/grt-rtis_addr.adb @@ -260,6 +260,28 @@ package body Grt.Rtis_Addr is end case; end Get_Base_Type; + 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; + + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask) + = Ghdl_Rti_Type_Anonymous; + end Rti_Anonymous_Type; + + function Rti_Non_Static_Physical_Type (Atype : Ghdl_Rti_Access) + return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Non_Static_Mask) + = Ghdl_Rti_Type_Non_Static; + end Rti_Non_Static_Physical_Type; + function Get_Top_Context return Rti_Context is Ctxt : Rti_Context; diff --git a/translate/grt/grt-rtis_addr.ads b/translate/grt/grt-rtis_addr.ads index 15a05a4..33efc0b 100644 --- a/translate/grt/grt-rtis_addr.ads +++ b/translate/grt/grt-rtis_addr.ads @@ -83,6 +83,21 @@ package Grt.Rtis_Addr is -- Get the base type of ATYPE. function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access; + -- Return true iff ATYPE is anonymous. + -- Valid only on type and subtype definitions. + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Anonymous_Type); + + -- Return true iff ATYPE is complex. + -- Valid only on type and subtype definitions. + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Complex_Type); + + -- Return true iff physical type ATYPE is non-static (std.standard.time) + function Rti_Non_Static_Physical_Type (Atype : Ghdl_Rti_Access) + return Boolean; + pragma Inline (Rti_Non_Static_Physical_Type); + -- Get the top context. function Get_Top_Context return Rti_Context; diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb index dbc70c2..52b8600 100644 --- a/translate/grt/grt-rtis_utils.adb +++ b/translate/grt/grt-rtis_utils.adb @@ -148,13 +148,6 @@ package body Grt.Rtis_Utils is 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) @@ -328,10 +321,12 @@ package body Grt.Rtis_Utils is is El : Ghdl_Rtin_Element_Acc; Obj_Addr : Address; + Last_Addr : Address; P : Natural; begin P := Length (Name); Obj_Addr := Addr; + Last_Addr := Addr; for I in 1 .. Rti.Nbrel loop El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); if Is_Sig then @@ -339,18 +334,21 @@ package body Grt.Rtis_Utils is else Addr := Obj_Addr + El.Val_Off; end if; + if Rti_Complex_Type (El.Eltype) then + Addr := To_Addr_Acc (Addr).all; + end if; Append (Name, '.'); Append (Name, El.Name); Handle_Any (El.Eltype); + if Addr > Last_Addr then + Last_Addr := Addr; + end if; Truncate (Name, P); end loop; - -- FIXME - --Addr := Obj_Addr + Rti.Xx; + Addr := Last_Addr; end Handle_Record; - procedure Handle_Any (Rti : Ghdl_Rti_Access) - is - Save_Addr : Address; + procedure Handle_Any (Rti : Ghdl_Rti_Access) is begin case Rti.Kind is when Ghdl_Rtik_Subtype_Scalar => @@ -372,28 +370,7 @@ package body Grt.Rtis_Utils is 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 : 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); - 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 @@ -406,20 +383,17 @@ package body Grt.Rtis_Utils is -- -- 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; + if Rti_Complex_Type (Obj_Type) then + Addr := To_Addr_Acc (Obj_Addr).all; + else + Addr := Obj_Addr; + end if; Handle_Any (Obj_Type); Free (Name); end Foreach_Scalar; diff --git a/translate/grt/grt-vcd.adb b/translate/grt/grt-vcd.adb index aa7f352..b78b417 100644 --- a/translate/grt/grt-vcd.adb +++ b/translate/grt/grt-vcd.adb @@ -325,17 +325,6 @@ package body Grt.Vcd is (Loc_To_Addr (St.Common.Depth, St.Bounds, Avhpi_Get_Context (Sig))); end; - when Ghdl_Rtik_Subtype_Array_Ptr => - declare - St : Ghdl_Rtin_Subtype_Array_Acc; - begin - St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Info.Kind := Rti_To_Vcd_Kind (St.Basetype); - Info.Addr := To_Addr_Acc (Sig_Addr).all; - Info.Irange := To_Ghdl_Range_Ptr - (Loc_To_Addr (St.Common.Depth, St.Bounds, - Avhpi_Get_Context (Sig))); - end; when Ghdl_Rtik_Type_Array => declare Uc : Ghdl_Uc_Array_Acc; diff --git a/translate/grt/grt-waves.adb b/translate/grt/grt-waves.adb index 7bcb0df..fb43fd1 100644 --- a/translate/grt/grt-waves.adb +++ b/translate/grt/grt-waves.adb @@ -629,15 +629,14 @@ package body Grt.Waves is Create_String_Id (Enum.Names (I - 1)); end loop; end; - when Ghdl_Rtik_Subtype_Array - | Ghdl_Rtik_Subtype_Array_Ptr => + when Ghdl_Rtik_Subtype_Array => declare Arr : Ghdl_Rtin_Subtype_Array_Acc; B_Ctxt : Rti_Context; begin Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); Create_String_Id (Arr.Name); - if Rti.Mode = Ghdl_Rti_Type_Complex then + if Rti_Complex_Type (Rti) then B_Ctxt := Ctxt; else B_Ctxt := N_Ctxt; @@ -1271,8 +1270,7 @@ package body Grt.Waves is Write_String_Id (Enum.Names (I - 1)); end loop; end; - when Ghdl_Rtik_Subtype_Array - | Ghdl_Rtik_Subtype_Array_Ptr => + when Ghdl_Rtik_Subtype_Array => declare Arr : Ghdl_Rtin_Subtype_Array_Acc; begin @@ -1351,33 +1349,30 @@ package body Grt.Waves is for I in 1 .. Base.Nbr loop Unit := To_Ghdl_Rtin_Unit_Acc (Base.Units (I - 1)); Write_String_Id (Unit.Name); - case Base.Common.Mode is - when 0 => - -- Value is locally static. - case Base.Common.Kind is - when Ghdl_Rtik_Type_P32 => - Wave_Put_SLEB128 (Unit.Value.Unit_32); - when Ghdl_Rtik_Type_P64 => - Wave_Put_LSLEB128 (Unit.Value.Unit_64); - when others => - Internal_Error - ("wave.write_types(P32/P64-0)"); - end case; - when 1 => - case Rti.Kind is - when Ghdl_Rtik_Type_P32 => - Wave_Put_SLEB128 - (Unit.Value.Unit_Addr.I32); - when Ghdl_Rtik_Type_P64 => - Wave_Put_LSLEB128 - (Unit.Value.Unit_Addr.I64); - when others => - Internal_Error - ("wave.write_types(P32/P64-1)"); - end case; - when others => - Internal_Error ("wave.write_types(P32/P64)"); - end case; + if Rti_Non_Static_Physical_Type (Rti) then + case Rti.Kind is + when Ghdl_Rtik_Type_P32 => + Wave_Put_SLEB128 + (Unit.Value.Unit_Addr.I32); + when Ghdl_Rtik_Type_P64 => + Wave_Put_LSLEB128 + (Unit.Value.Unit_Addr.I64); + when others => + Internal_Error + ("wave.write_types(P32/P64-1)"); + end case; + else + -- Value is locally static. + case Base.Common.Kind is + when Ghdl_Rtik_Type_P32 => + Wave_Put_SLEB128 (Unit.Value.Unit_32); + when Ghdl_Rtik_Type_P64 => + Wave_Put_LSLEB128 (Unit.Value.Unit_64); + when others => + Internal_Error + ("wave.write_types(P32/P64-0)"); + end case; + end if; end loop; end; when others => -- cgit