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. --- sem_expr.adb | 42 +- testsuite/gna/bug20312/arr.vhdl | 15 + testsuite/gna/bug20312/repro.vhdl | 73 +++ testsuite/gna/bug20312/testsuite.sh | 13 + 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 +-- translate/translation.adb | 960 ++++++++++++++---------------------- 14 files changed, 635 insertions(+), 710 deletions(-) create mode 100644 testsuite/gna/bug20312/arr.vhdl create mode 100644 testsuite/gna/bug20312/repro.vhdl create mode 100755 testsuite/gna/bug20312/testsuite.sh diff --git a/sem_expr.adb b/sem_expr.adb index ebe7679b1..aec8a83bc 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -505,6 +505,7 @@ package body Sem_Expr is is Base_Type: Iir; Left, Right: Iir; + Left_Type, Right_Type : Iir; Expr_Type : Iir; begin Expr_Type := Get_Type (Expr); @@ -540,7 +541,22 @@ package body Sem_Expr is return Null_Iir; end if; - if Is_Overloaded (Left) or else Is_Overloaded (Right) then + Left_Type := Get_Type (Left); + Right_Type := Get_Type (Right); + -- Check for string or aggregate literals + -- FIXME: improve error message + if Left_Type = Null_Iir then + Error_Msg_Sem ("bad expression for a scalar", Left); + return Null_Iir; + end if; + if Right_Type = Null_Iir then + Error_Msg_Sem ("bad expression for a scalar", Right); + return Null_Iir; + end if; + + if Is_Overload_List (Left_Type) + or else Is_Overload_List (Right_Type) + then if Base_Type /= Null_Iir then -- Cannot happen, since sem_expression_ov should resolved -- ambiguties if a type is given. @@ -548,21 +564,20 @@ package body Sem_Expr is end if; -- Try to find a common type. - Base_Type := Search_Compatible_Type - (Get_Type (Left), Get_Type (Right)); + Base_Type := Search_Compatible_Type (Left_Type, Right_Type); if Base_Type = Null_Iir then - if Compatibility_Types1 - (Universal_Integer_Type_Definition, Get_Type (Left)) + if Compatibility_Types1 (Universal_Integer_Type_Definition, + Left_Type) and then - Compatibility_Types1 - (Universal_Integer_Type_Definition, Get_Type (Right)) + Compatibility_Types1 (Universal_Integer_Type_Definition, + Right_Type) then Base_Type := Universal_Integer_Type_Definition; - elsif Compatibility_Types1 - (Universal_Real_Type_Definition, Get_Type (Left)) + elsif Compatibility_Types1 (Universal_Real_Type_Definition, + Left_Type) and then - Compatibility_Types1 - (Universal_Real_Type_Definition, Get_Type (Right)) + Compatibility_Types1 (Universal_Real_Type_Definition, + Right_Type) then Base_Type := Universal_Real_Type_Definition; else @@ -3997,6 +4012,11 @@ package body Sem_Expr is return Null_Iir; end if; Expr_Type := Get_Type (Expr1); + if Expr_Type = Null_Iir then + -- FIXME: improve message + Error_Msg_Sem ("bad expression for a scalar", Expr); + return Null_Iir; + end if; if not Is_Overload_List (Expr_Type) then return Expr1; end if; diff --git a/testsuite/gna/bug20312/arr.vhdl b/testsuite/gna/bug20312/arr.vhdl new file mode 100644 index 000000000..cad470e17 --- /dev/null +++ b/testsuite/gna/bug20312/arr.vhdl @@ -0,0 +1,15 @@ +entity arr is + generic (width : natural := 4); +end arr; + +architecture behav of arr is + subtype line is bit_vector (1 to width); + type memory is array (0 to 7) of line; +begin + process is + variable l : line; + variable mem : memory; + begin + wait; + end process; +end behav; diff --git a/testsuite/gna/bug20312/repro.vhdl b/testsuite/gna/bug20312/repro.vhdl new file mode 100644 index 000000000..8a606ee3d --- /dev/null +++ b/testsuite/gna/bug20312/repro.vhdl @@ -0,0 +1,73 @@ +entity pipeline is + generic (width : natural; depth : natural); + port (i : bit_vector (1 to width); + o : out bit_vector (1 to width); + clk : bit); +end pipeline; + +architecture behav of pipeline is + type pipe is array (1 to depth) of bit_vector (1 to width); +begin + process (clk) is + variable tmp : pipe; + begin + if clk = '1' then + o <= tmp (1); + tmp (1 to depth - 1) := tmp (2 to depth); + tmp (depth) := i; + end if; + end process; +end behav; + +entity tb is +end tb; + +architecture behav of tb is + constant width : natural := 4; + signal i : bit_vector (1 to width); + signal o : bit_vector (1 to width); + signal clk : bit; +begin + p : entity work.pipeline + generic map (width => width, depth => 3) + port map (i => i, o => o, clk => clk); + process is + begin + i <= "1011"; + + clk <= '0'; + wait for 0 ns; + clk <= '1'; + wait for 0 ns; + + i <= "1010"; + + clk <= '0'; + wait for 0 ns; + clk <= '1'; + wait for 0 ns; + + i <= "1001"; + + clk <= '0'; + wait for 0 ns; + clk <= '1'; + wait for 0 ns; + + i <= "1000"; + + clk <= '0'; + wait for 0 ns; + clk <= '1'; + wait for 0 ns; + + i <= "1011"; + + clk <= '0'; + wait for 0 ns; + clk <= '1'; + wait for 0 ns; + + wait; + end process; +end behav; diff --git a/testsuite/gna/bug20312/testsuite.sh b/testsuite/gna/bug20312/testsuite.sh new file mode 100755 index 000000000..d73c6cd77 --- /dev/null +++ b/testsuite/gna/bug20312/testsuite.sh @@ -0,0 +1,13 @@ +#! /bin/sh + +. ../../testenv.sh + +analyze repro.vhdl +elab_simulate tb + +analyze arr.vhdl +elab_simulate arr + +clean + +echo "Test successful" diff --git a/translate/grt/grt-avhpi.adb b/translate/grt/grt-avhpi.adb index a6565cf5d..58b9870e4 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 8a5405f95..942a59588 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 47f67c264..8a754c9a3 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 2276adf47..c1907110d 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 784698d35..f846f382a 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 15a05a48c..33efc0b28 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 dbc70c2c6..52b86001d 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 aa7f352ea..b78b417e5 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 7bcb0df6f..fb43fd17a 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 => diff --git a/translate/translation.adb b/translate/translation.adb index 0859804ad..d00c88222 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -661,7 +661,6 @@ package body Translation is Ghdl_Rtik_Type_File : O_Cnode; Ghdl_Rtik_Subtype_Scalar : O_Cnode; Ghdl_Rtik_Subtype_Array : O_Cnode; - Ghdl_Rtik_Subtype_Array_Ptr : O_Cnode; Ghdl_Rtik_Subtype_Unconstrained_Array : O_Cnode; Ghdl_Rtik_Subtype_Record : O_Cnode; Ghdl_Rtik_Subtype_Access : O_Cnode; @@ -946,9 +945,6 @@ package body Translation is Type_Mode_Protected, -- Constrained array type (length is known at compile-time). Type_Mode_Array, - -- Array pointer type (used for constrained array whose length is - -- known at run-time). - Type_Mode_Ptr_Array, -- Fat array type (used for unconstrained array). Type_Mode_Fat_Array); @@ -1166,6 +1162,11 @@ package body Translation is -- If true, the type is (still) incomplete. Type_Incomplete : Boolean := False; + -- For array only. True if the type is constrained with locally + -- static bounds. May have non locally-static bounds in some + -- of its sub-element (ie being a complex type). + Type_Locally_Constrained : Boolean := False; + -- Chain of temporary types to be destroyed at end of scope. Type_Transient_Chain : Iir := Null_Iir; @@ -1562,6 +1563,15 @@ package body Translation is return Info.Type_Mode in Type_Mode_Fat; end Is_Composite; + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean; + pragma Inline (Is_Complex_Type); + + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is + begin + return Tinfo.C /= null; + end Is_Complex_Type; + + -- Convert an o_lnode to an o_enode, either by taking value or address. function L2e_Node (L : O_Lnode; Type_Info : Type_Info_Acc; @@ -1573,7 +1583,6 @@ package body Translation is raise Internal_Error; when Type_Mode_Scalar | Type_Mode_Acc - | Type_Mode_Ptr_Array | Type_Mode_File => return New_Value (L); when Type_Mode_Fat_Array @@ -1586,35 +1595,6 @@ package body Translation is end case; end L2e_Node; --- -- Get Lnode from a variable pointer. --- function Ptr2l_Node (Var_Ptr : O_Lnode; Info : Type_Info_Acc) return O_Lnode --- is --- begin --- case Info.Type_Mode is --- when Type_Mode_Fat_Array --- | Type_Mode_Array --- | Type_Mode_Record --- | Type_Mode_Fat_Acc => --- return New_Access_Element (New_Value (Var_Ptr)); --- when Type_Mode_Ptr_Array => --- return Var_Ptr; --- when others => --- raise Internal_Error; --- end case; --- end Ptr2l_Node; - --- function Get_Bounds_Ptr (Info : Type_Info_Acc) return O_Enode is --- begin --- case Info.Type_Mode is --- when Type_Mode_Array --- | Type_Mode_Ptr_Array => --- return New_Address (Get_Var (Info.T.Array_Bounds), --- Info.T.Bounds_Ptr_Type); --- when others => --- raise Internal_Error; --- end case; --- end Get_Bounds_Ptr; - -- In order to simplify the handling of Enode/Lnode, let's introduce -- Mnode (yes, another node). -- An Mnode is a typed union, containing either an Lnode or a Enode. @@ -1845,9 +1825,16 @@ package body Translation is function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) return Mnode; + -- Same for for slicing. + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode; + -- Get the length of the array. function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode; + function Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) + return O_Enode; + function Get_Array_Type_Length (Atype : Iir) return O_Enode; -- Get the base of array ARR. @@ -1881,10 +1868,6 @@ package body Translation is -- Get array bounds for type ATYPE. function Get_Array_Type_Bounds (Atype : Iir) return Mnode; - -- PTR must be a variable pointing to a bounds of type ATYPE. - function Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) - return O_Enode; - -- Return the a pointer to the array base from variable PTR -- containing a pointer to array. function Get_Array_Ptr_Base_Ptr @@ -2989,7 +2972,7 @@ package body Translation is return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype); end Varv2M; - -- Convert a Lnode for a sub object) to an MNODE. + -- Convert a Lnode for a sub object to an MNODE. function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) return Mnode is begin @@ -3000,8 +2983,7 @@ package body Translation is | Type_Mode_Fat_Array | Type_Mode_Fat_Acc => return Lv2M (L, Vtype, Mode); - when Type_Mode_Ptr_Array - | Type_Mode_Array + when Type_Mode_Array | Type_Mode_Record | Type_Mode_Protected => if Vtype.C = null then @@ -3024,8 +3006,7 @@ package body Translation is | Type_Mode_Fat_Array | Type_Mode_Fat_Acc => return Dv2M (D, Vtype, Mode); - when Type_Mode_Ptr_Array - | Type_Mode_Array + when Type_Mode_Array | Type_Mode_Record | Type_Mode_Protected => if Vtype.C = null then @@ -3064,8 +3045,7 @@ package body Translation is else return Lv2M (L, Vtype, Mode); end if; - when Type_Mode_Ptr_Array - | Type_Mode_Array + when Type_Mode_Array | Type_Mode_Record | Type_Mode_Protected => if Vtype.C = null then @@ -3721,46 +3701,8 @@ package body Translation is case Type_Info.Type_Mode is when Type_Mode_Scalar => Do_Non_Composite (Targ, Targ_Type, Data); - when Type_Mode_Array => - declare - Var_I : O_Dnode; - Var_Array : Mnode; - Label : O_Snode; - Composite_Data : Composite_Data_Type; - Sub_Data : Data_Type; - begin - Open_Temp; - Var_Array := Stabilize (Targ); - if True then - Var_I := Create_Temp (Ghdl_Index_Type); - else - New_Var_Decl - (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - end if; - Init_Var (Var_I); - Composite_Data := - Prepare_Data_Array (Var_Array, Targ_Type, Data); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op (ON_Ge, - New_Value (New_Obj (Var_I)), - Chap3.Get_Array_Type_Length (Targ_Type), - Ghdl_Bool_Type)); - Sub_Data := Update_Data_Array - (Composite_Data, Targ_Type, Var_I); - Foreach_Non_Composite - (Chap3.Index_Base (Var_Array, Targ_Type, - New_Value (New_Obj (Var_I))), - Get_Element_Subtype (Targ_Type), - Sub_Data); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Data_Array (Composite_Data); - Close_Temp; - end; when Type_Mode_Fat_Array - | Type_Mode_Ptr_Array => + | Type_Mode_Array => declare Var_Array : Mnode; Var_Base : Mnode; @@ -3935,7 +3877,6 @@ package body Translation is Res := E2M (Val, Type_Info, Mode_Value); case Type_Info.Type_Mode is when Type_Mode_Array - | Type_Mode_Ptr_Array | Type_Mode_Fat_Array => Res := Chap3.Get_Array_Base (Res); when Type_Mode_Record => @@ -5835,6 +5776,7 @@ package body Translation is when Mode_Signal => Ident := Create_Identifier (Name, "_SIGBUILDER"); end case; + -- FIXME: return the same type as its first parameter ??? Start_Function_Decl (Interface_List, Ident, Global_Storage, Char_Ptr_Type); Chap2.Add_Subprg_Instance_Interfaces @@ -5878,9 +5820,6 @@ package body Translation is when Type_Mode_Record | Type_Mode_Array => New_Association (Assoc, New_Obj_Value (Var_Ptr)); - when Type_Mode_Ptr_Array => - --New_Association (Assoc, New_Value (New_Acc_Value (Var_Ptr))); - New_Association (Assoc, New_Obj_Value (Var_Ptr)); when Type_Mode_Fat_Array => -- Note: a fat array can only be at the top of a complex type; -- the bounds must have been set. @@ -5891,8 +5830,7 @@ package body Translation is raise Internal_Error; end case; case Tinfo.Type_Mode is - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => New_Association (Assoc, Get_Array_Bounds_Ptr (O_Lnode_Null, Var_Type, Kind)); @@ -5946,6 +5884,8 @@ package body Translation is New_Assign_Stmt (Get_Field_Lnode, New_Obj_Value (Var_Ptr)); -- Build second/third-order complex type. + -- FIXME: use Size_Var here too, and merge both branches of + -- the above 'if'. New_Assign_Stmt (New_Obj (Mem), Gen_Call_Type_Builder (Var_Ptr, Field_Type, Kind)); @@ -5953,6 +5893,7 @@ package body Translation is Finish_Declare_Stmt; else -- Allocate memory. + -- FIXME: alignment ??? New_Assign_Stmt (Get_Field_Lnode, New_Convert_Ov (New_Obj_Value (Mem), Tinfo.Ortho_Ptr_Type (Kind))); @@ -6406,34 +6347,45 @@ package body Translation is El_Type := Get_Element_Subtype (Def); Translate_Type_Definition (El_Type, True); El_Tinfo := Get_Info (El_Type); - for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - case Kind is - when Mode_Value => - -- For the values. - Id := Create_Identifier ("BASE"); - if not Complete then - Idptr := Create_Identifier ("BASEP"); - else - Idptr := O_Ident_Nul; - end if; - when Mode_Signal => - -- For the signals - Id := Create_Identifier ("SIGBASE"); - Idptr := Create_Identifier ("SIGBASEP"); - end case; - Info.T.Base_Type (Kind) := - New_Array_Type (Chap4.Get_Element_Type (El_Tinfo, Kind), - Ghdl_Index_Type); - New_Type_Decl (Id, Info.T.Base_Type (Kind)); - if Is_Equal (Idptr, O_Ident_Nul) then - Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), - Info.T.Base_Type (Kind)); + + if Is_Complex_Type (El_Tinfo) then + if El_Tinfo.Type_Mode = Type_Mode_Array then + Info.T.Base_Type := El_Tinfo.T.Base_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.T.Base_Ptr_Type; else - Info.T.Base_Ptr_Type (Kind) := - New_Access_Type (Info.T.Base_Type (Kind)); - New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); + Info.T.Base_Type := El_Tinfo.Ortho_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type; end if; - end loop; + else + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + case Kind is + when Mode_Value => + -- For the values. + Id := Create_Identifier ("BASE"); + if not Complete then + Idptr := Create_Identifier ("BASEP"); + else + Idptr := O_Ident_Nul; + end if; + when Mode_Signal => + -- For the signals + Id := Create_Identifier ("SIGBASE"); + Idptr := Create_Identifier ("SIGBASEP"); + end case; + Info.T.Base_Type (Kind) := + New_Array_Type (El_Tinfo.Ortho_Type (Kind), + Ghdl_Index_Type); + New_Type_Decl (Id, Info.T.Base_Type (Kind)); + if Is_Equal (Idptr, O_Ident_Nul) then + Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), + Info.T.Base_Type (Kind)); + else + Info.T.Base_Ptr_Type (Kind) := + New_Access_Type (Info.T.Base_Type (Kind)); + New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); + end if; + end loop; + end if; end Translate_Array_Type_Base; -- For unidimensional arrays: create a constant bounds whose length @@ -6519,14 +6471,15 @@ package body Translation is Translate_Static_Unidimensional_Array_Length_One (Def); El_Tinfo := Get_Info (Get_Element_Subtype (Def)); - if El_Tinfo.C /= null then + if Is_Complex_Type (El_Tinfo) then -- This is a complex type. Info.C := new Complex_Type_Arr_Info; -- No size variable for unconstrained array type. - Info.C (Mode_Value).Size_Var := null; - Info.C (Mode_Signal).Size_Var := null; - Info.C (Mode_Value).Builder_Need_Func := True; - Info.C (Mode_Signal).Builder_Need_Func := True; + for Mode in Object_Kind_Type loop + Info.C (Mode).Size_Var := null; + Info.C (Mode).Builder_Need_Func := + El_Tinfo.C (Mode).Builder_Need_Func; + end loop; end if; Info.Type_Incomplete := False; end Translate_Array_Type; @@ -6555,7 +6508,6 @@ package body Translation is return Len; end Get_Array_Subtype_Length; - procedure Translate_Array_Subtype (Def : Iir_Array_Subtype_Definition) is Info : Type_Info_Acc; @@ -6563,7 +6515,6 @@ package body Translation is Len : Iir_Int64; - Ptr : O_Tnode; Id : O_Ident; begin Info := Get_Info (Def); @@ -6572,15 +6523,27 @@ package body Translation is -- Note: info of indexes subtype are not created! Len := Get_Array_Subtype_Length (Def); - if Len < 0 then - -- Length of the array is not known at compile time. - Info.Type_Mode := Type_Mode_Ptr_Array; + Info.Type_Mode := Type_Mode_Array; + Info.Type_Locally_Constrained := (Len >= 0); + if Is_Complex_Type (Binfo) + or else not Info.Type_Locally_Constrained + then + -- This is a complex type as the size is not known at compile + --- time. Info.Ortho_Type := Binfo.T.Base_Ptr_Type; Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + + Create_Size_Var (Def); + + for Mode in Object_Kind_Type loop + Info.C (Mode).Builder_Need_Func := + Is_Complex_Type (Binfo) + and then Binfo.C (Mode).Builder_Need_Func; + end loop; else -- Length is known. Create a constrained array. - Info.Type_Mode := Type_Mode_Array; Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop case I is when Mode_Value => @@ -6592,26 +6555,8 @@ package body Translation is (Binfo.T.Base_Type (I), New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); New_Type_Decl (Id, Info.Ortho_Type (I)); - --Ptr := New_Access_Type (Info.Ortho_Type); - --New_Type_Decl (Create_Identifier (Name, "_ARGT"), Ptr); - Ptr := Binfo.T.Base_Ptr_Type (I); - Info.Ortho_Ptr_Type (I) := Ptr; end loop; end if; - - -- Create a size variable if the length is not known or if - -- the element size is not known at compile-time. - if Binfo.C /= null then - -- The base type is a complex type, so is the type. - Create_Size_Var (Def); - Info.C (Mode_Value).Builder_Need_Func := True; - Info.C (Mode_Signal).Builder_Need_Func := True; - elsif Len < 0 then - -- This may creates complex types. - Create_Size_Var (Def); - Info.C (Mode_Value).Builder_Need_Func := False; - Info.C (Mode_Signal).Builder_Need_Func := False; - end if; end Translate_Array_Subtype; function Create_Static_Array_Subtype_Bounds @@ -6739,54 +6684,49 @@ package body Translation is (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type) is Base : O_Dnode; + Bound : O_Dnode; Var_I : O_Dnode; - function Get_Field_Lnode return O_Lnode is - begin - return New_Indexed_Element (New_Acc_Value (New_Obj (Base)), - New_Obj_Value (Var_I)); - end Get_Field_Lnode; - - procedure Update_Field is new Builder_Update_Field (Get_Field_Lnode); - - Mem : O_Dnode; - Info : Type_Info_Acc; + Var_Mem : O_Dnode; + Var_Step : O_Dnode; + Info : constant Type_Info_Acc := Get_Info (Def); + El_Type : Iir; El_Info : Type_Info_Acc; Var_Length : O_Dnode; Label : O_Snode; begin - Info := Get_Info (Def); Start_Subprogram_Body (Info.C (Kind).Builder_Func); Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); -- Aliased Base := Info.C (Kind).Builder_Base_Param; + Bound := Info.C (Kind).Builder_Bound_Param; -- Compute length of the array. New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Mem, Get_Identifier ("mem"), O_Storage_Local, - Char_Ptr_Type); + New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local, + Info.T.Base_Ptr_Type (Kind)); + New_Var_Decl (Var_Step, Get_Identifier ("step"), O_Storage_Local, + Ghdl_Index_Type); + New_Assign_Stmt (New_Obj (Var_Mem), New_Obj_Value (Base)); + + El_Type := Get_Element_Subtype (Def); + El_Info := Get_Info (El_Type); + New_Assign_Stmt (New_Obj (Var_Length), - Chap3.Get_Bounds_Ptr_Length (Info.C (Kind).Builder_Bound_Param, - Def)); + New_Dyadic_Op (ON_Mul_Ov, + New_Value (Get_Var (El_Info.C (Kind).Size_Var)), + Get_Bounds_Ptr_Length (Bound, Def))); - -- Reserve the size of the array vector. - El_Info := Get_Info (Get_Element_Subtype (Def)); + while El_Info.Type_Mode = Type_Mode_Array loop + El_Type := Get_Element_Subtype (El_Type); + El_Info := Get_Info (El_Type); + end loop; New_Assign_Stmt - (New_Obj (Mem), - New_Address - (New_Slice - (New_Access_Element - (New_Convert_Ov (New_Obj_Value (Base), Char_Ptr_Type)), - Chararray_Type, - New_Dyadic_Op (ON_Mul_Ov, - New_Obj_Value (Var_Length), - New_Lit (New_Sizeof - (El_Info.Ortho_Ptr_Type (Kind), - Ghdl_Index_Type)))), - Char_Ptr_Type)); + (New_Obj (Var_Step), + New_Value (Get_Var (El_Info.C (Kind).Size_Var))); -- Set each index of the array. New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); @@ -6797,11 +6737,18 @@ package body Translation is New_Obj_Value (Var_I), New_Obj_Value (Var_Length), Ghdl_Bool_Type)); - Update_Field (Get_Element_Subtype (Def), Mem, Kind); - Inc_Var (Var_I); + New_Assign_Stmt + (New_Obj (Var_Mem), + New_Convert_Ov (Gen_Call_Type_Builder (Var_Mem, El_Type, Kind), + Info.T.Base_Ptr_Type (Kind))); + New_Assign_Stmt (New_Obj (Var_I), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Step))); Finish_Loop_Stmt (Label); - New_Return_Stmt (New_Obj_Value (Mem)); + New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_Mem), + Char_Ptr_Type)); Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); Finish_Subprogram_Body; @@ -6829,6 +6776,8 @@ package body Translation is Info := Get_Info (Def); Need_Size := False; List := Get_Elements_Declaration_List (Def); + + -- First, translate the anonymous type of the elements. for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; @@ -6844,6 +6793,7 @@ package body Translation is Field_Info := Add_Info (El, Kind_Field); end loop; + -- Then create the record type. Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop Start_Record_Type (El_List); @@ -6918,7 +6868,7 @@ package body Translation is El := Get_Nth_Element (List, I); exit when El = Null_Iir; El_Type := Get_Type (El); - if Get_Info (El_Type).C /= null then + if Is_Complex_Type (Get_Info (El_Type)) then -- Complex type. Update_Field (El_Type, Mem, Kind); end if; @@ -7374,32 +7324,16 @@ package body Translation is end case; end Create_Type_Definition_Type_Range; - function Get_Additionnal_Size (Def : Iir; Kind : Object_Kind_Type) - return O_Enode - is - Info : Type_Info_Acc; - begin - Info := Get_Info (Def); - - if Info.C = null then - -- Short-cut. - return O_Enode_Null; - else - return New_Value (Get_Var (Info.C (Kind).Size_Var)); - end if; - end Get_Additionnal_Size; - procedure Create_Type_Definition_Size_Var (Def : Iir) is Info : Type_Info_Acc; Res : O_Enode; - V : O_Cnode; - Add : O_Enode; begin Info := Get_Info (Def); if Info.C = null then return; end if; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop if Info.C (Kind).Size_Var /= null then Open_Temp; @@ -7409,65 +7343,38 @@ package body Translation is | Type_Mode_Unknown | Type_Mode_Protected => raise Internal_Error; - when Type_Mode_Array => - V := New_Sizeof (Info.Ortho_Type (Kind), - Ghdl_Index_Type); - Add := Get_Additionnal_Size - (Get_Element_Subtype (Def), Kind); - if Add /= O_Enode_Null then - Add := New_Dyadic_Op - (ON_Mul_Ov, Get_Array_Type_Length (Def), Add); - Res := New_Dyadic_Op (ON_Add_Ov, New_Lit (V), Add); - else - Res := New_Lit (V); - end if; when Type_Mode_Record => declare List : Iir_List; El : Iir_Element_Declaration; - N_Res : O_Enode; + El_Tinfo : Type_Info_Acc; begin - V := New_Sizeof (Info.Ortho_Type (Kind), - Ghdl_Index_Type); List := Get_Elements_Declaration_List (Get_Base_Type (Def)); - Res := New_Lit (V); + Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), + Ghdl_Index_Type)); for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; - N_Res := Get_Additionnal_Size (Get_Type (El), Kind); - if N_Res /= O_Enode_Null then - Res := New_Dyadic_Op (ON_Add_Ov, Res, N_Res); + El_Tinfo := Get_Info (Get_Type (El)); + if Is_Complex_Type (El_Tinfo) then + Res := New_Dyadic_Op + (ON_Add_Ov, + New_Value + (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Res); end if; end loop; end; - when Type_Mode_Ptr_Array => - -- If element is a composite type then - -- Return length * (sizeof (element) - -- + sizeof (element_ptr)) - -- else - -- Return length * sizeof (element) - -- end if + when Type_Mode_Array => declare - El_Type : Iir; - El_Tinfo : Type_Info_Acc; + El_Type : constant Iir := Get_Element_Subtype (Def); begin - El_Type := Get_Element_Subtype (Def); - El_Tinfo := Get_Info (El_Type); - Res := Chap3.Get_Object_Size - (T2M (El_Type, Kind), El_Type); - if El_Tinfo.C /= null then - Res := New_Dyadic_Op - (ON_Add_Ov, - Res, - New_Lit - (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind), - Ghdl_Index_Type))); - end if; Res := New_Dyadic_Op (ON_Mul_Ov, - Chap3.Get_Array_Type_Length (Def), - Res); + Get_Array_Type_Length (Def), + Chap3.Get_Object_Size (T2M (El_Type, Kind), + El_Type)); end; end case; New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); @@ -8043,38 +7950,6 @@ package body Translation is return New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Val)); end Get_Thin_Array_Length; - function Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) - return O_Enode - is - Index_List : Iir_List; - Index_Type : Iir; - Nbr_Dim : Natural; - Dim_Length : O_Enode; - Res : O_Enode; - Type_Info : Type_Info_Acc; - Index_Info : Type_Info_Acc; - begin - Index_List := Get_Index_Subtype_List (Atype); - Nbr_Dim := Get_Nbr_Elements (Index_List); - - Type_Info := Get_Info (Get_Base_Type (Atype)); - for Dim in 1 .. Nbr_Dim loop - Index_Type := Get_Nth_Element (Index_List, Dim - 1); - Index_Info := Get_Info (Get_Base_Type (Index_Type)); - Dim_Length := New_Value - (New_Selected_Element - (New_Selected_Element (New_Acc_Value (New_Obj (Ptr)), - Type_Info.T.Bounds_Vector (Dim)), - Index_Info.T.Range_Length)); - if Dim = 1 then - Res := Dim_Length; - else - Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); - end if; - end loop; - return Res; - end Get_Bounds_Ptr_Length; - function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) return Mnode is @@ -8153,8 +8028,7 @@ package body Translation is case Info.Type_Mode is when Type_Mode_Fat_Array => raise Internal_Error; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => return Varv2M (Info.T.Array_Bounds, Info, Mode_Value, Info.T.Bounds_Type, @@ -8189,8 +8063,7 @@ package body Translation is Info.T.Bounds_Type, Info.T.Bounds_Ptr_Type); end; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => return Get_Array_Type_Bounds (Info); when others => raise Internal_Error; @@ -8212,23 +8085,19 @@ package body Translation is Type_Info : Type_Info_Acc; Bounds : Mnode; begin - Index_List := Get_Index_Subtype_List (Atype); - Nbr_Dim := Get_Nbr_Elements (Index_List); - - -- Handle thin array case. + -- Handle non-complex array case. Type_Info := Get_Info (Atype); - case Type_Info.Type_Mode is - when Type_Mode_Ptr_Array => - Bounds := Get_Array_Type_Bounds (Atype); - if Nbr_Dim > 1 then - Bounds := Stabilize (Bounds); - end if; - when Type_Mode_Array => - return New_Lit (Get_Thin_Array_Length (Atype)); - when others => - raise Internal_Error; - end case; + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + end if; + -- FIXME: share code with get_array_length ??? + Index_List := Get_Index_Subtype_List (Atype); + Nbr_Dim := Get_Nbr_Elements (Index_List); + Bounds := Get_Array_Type_Bounds (Atype); + if Nbr_Dim > 1 then + Bounds := Stabilize (Bounds); + end if; for Dim in 1 .. Nbr_Dim loop Dim_Length := M2E (Range_To_Length (Bounds_To_Range (Bounds, Atype, Dim))); @@ -8241,30 +8110,55 @@ package body Translation is return Res; end Get_Array_Type_Length; - function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode + function Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) + return O_Enode is Index_List : Iir_List; + Index_Type : Iir; Nbr_Dim : Natural; Dim_Length : O_Enode; Res : O_Enode; Type_Info : Type_Info_Acc; - B : Mnode; + Index_Info : Type_Info_Acc; begin Index_List := Get_Index_Subtype_List (Atype); Nbr_Dim := Get_Nbr_Elements (Index_List); + Type_Info := Get_Info (Get_Base_Type (Atype)); + for Dim in 1 .. Nbr_Dim loop + Index_Type := Get_Nth_Element (Index_List, Dim - 1); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + Dim_Length := New_Value + (New_Selected_Element + (New_Selected_Element (New_Acc_Value (New_Obj (Ptr)), + Type_Info.T.Bounds_Vector (Dim)), + Index_Info.T.Range_Length)); + if Dim = 1 then + Res := Dim_Length; + else + Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); + end if; + end loop; + return Res; + end Get_Bounds_Ptr_Length; + + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode + is + Index_List : Iir_List; + Nbr_Dim : Natural; + Dim_Length : O_Enode; + Res : O_Enode; + Type_Info : Type_Info_Acc; + B : Mnode; + begin -- Handle thin array case. Type_Info := Get_Info (Atype); - case Type_Info.Type_Mode is - when Type_Mode_Ptr_Array - | Type_Mode_Array => - return Get_Array_Type_Length (Atype); - when Type_Mode_Fat_Array => - null; - when others => - raise Internal_Error; - end case; + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + end if; + Index_List := Get_Index_Subtype_List (Atype); + Nbr_Dim := Get_Nbr_Elements (Index_List); for Dim in 1 .. Nbr_Dim loop B := Get_Array_Bounds (Arr); Dim_Length := @@ -8298,24 +8192,73 @@ package body Translation is Info.T.Base_Type (Kind), Info.T.Base_Ptr_Type (Kind)); end; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => return Arr; when others => raise Internal_Error; end case; end Get_Array_Base; + function Reindex_Complex_Array + (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc) + return Mnode + is + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + pragma Assert (Is_Complex_Type (El_Tinfo)); + return + E2M + (New_Unchecked_Address + (New_Slice + (New_Access_Element + (New_Convert_Ov (M2E (Base), Char_Ptr_Type)), + Chararray_Type, + New_Dyadic_Op (ON_Mul_Ov, + New_Value + (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Index)), + El_Tinfo.Ortho_Ptr_Type (Kind)), + Res_Info, Kind); + end Reindex_Complex_Array; + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) return Mnode is - El_Type : Iir; + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); begin - El_Type := Get_Element_Subtype (Atype); - return Lo2M (New_Indexed_Element (M2Lv (Base), Index), - Get_Info (El_Type), Get_Object_Kind (Base)); + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, El_Tinfo); + else + return Lo2M (New_Indexed_Element (M2Lv (Base), Index), + El_Tinfo, Kind); + end if; end Index_Base; + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + T_Info : constant Type_Info_Acc := Get_Info (Atype); + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, T_Info); + else + return Lv2M (New_Slice (M2Lv (Base), + T_Info.T.Base_Type (Kind), + Index), + False, + T_Info.T.Base_Type (Kind), + T_Info.T.Base_Ptr_Type (Kind), + T_Info, Kind); + end if; + end Slice_Base; + function Get_Array_Ptr_Base_Ptr (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) return O_Lnode @@ -8328,8 +8271,7 @@ package body Translation is return New_Selected_Element (New_Access_Element (New_Value (Ptr)), Tinfo.T.Base_Field (Is_Sig)); - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => return Ptr; when others => raise Internal_Error; @@ -8352,8 +8294,7 @@ package body Translation is Dim - 1); Index_Info := Get_Info (Get_Base_Type (Index_Type)); case Array_Info.Type_Mode is - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => -- Extract bound variable. Res := Get_Var (Array_Info.T.Array_Bounds); when Type_Mode_Fat_Array => @@ -8381,8 +8322,7 @@ package body Translation is return New_Value (New_Selected_Element (New_Acc_Value (Ptr), Info.T.Bounds_Field (Is_Sig))); - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => return New_Address (Get_Var (Info.T.Array_Bounds), Info.T.Bounds_Ptr_Type); when others => @@ -8401,8 +8341,7 @@ package body Translation is when Type_Mode_Fat_Array => return New_Value (New_Selected_Element (Arr, Type_Info.T.Bounds_Field (Is_Sig))); - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => return New_Address (Get_Var (Type_Info.T.Array_Bounds), Type_Info.T.Bounds_Ptr_Type); when others => @@ -8453,91 +8392,6 @@ package body Translation is Pop_Identifier_Prefix (Mark); end Create_Array_Subtype; - function Get_Memory_Complex_1 - (Ptr : O_Lnode; Obj_Type : Iir; Kind : Object_Kind_Type) - return O_Enode - is - Info : Type_Info_Acc; - begin - Info := Get_Info (Obj_Type); - case Info.Type_Mode is - when Type_Mode_Ptr_Array => - return New_Value (Ptr); - when Type_Mode_Array => - return Get_Memory_Complex_1 - (New_Indexed_Element (Ptr, New_Lit (Ghdl_Index_0)), - Get_Element_Subtype (Obj_Type), - Kind); - when Type_Mode_Record => - declare - List : Iir_List; - El : Iir_Element_Declaration; - El_Type : Iir; - El_Info : Type_Info_Acc; - begin - List := Get_Elements_Declaration_List - (Get_Base_Type (Obj_Type)); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - El_Type := Get_Type (El); - El_Info := Get_Info (El_Type); - if El_Info.C /= null then - return Get_Memory_Complex_1 - (New_Selected_Element - (Ptr, Get_Info (El).Field_Node (Kind)), - El_Type, - Kind); - end if; - end loop; - -- Record is known to be complex but has no complex - -- element. - raise Internal_Error; - end; - when Type_Mode_Scalar - | Type_Mode_Unknown - | Type_Mode_File - | Type_Mode_Acc - | Type_Mode_Fat_Acc - | Type_Mode_Fat_Array - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Get_Memory_Complex_1; - --- -- VAR_PTR is a pointer to an object of type OBJ_TYPE (and kind KIND). --- -- This object is known to be of a complex type. --- -- Return the value of the first internal pointer of the object. --- function Get_Memory_Complex --- (Var_Ptr : O_Lnode; Obj_Type : Iir; Kind : Object_Kind_Type) --- return O_Enode --- is --- Info : Type_Info_Acc; --- Res : O_Enode; --- begin --- Info := Get_Info (Obj_Type); --- case Info.Type_Mode is --- when Type_Mode_Fat_Array --- | Type_Mode_Array --- | Type_Mode_Ptr_Array => --- Res := Get_Memory_Complex_1 --- (New_Indexed_Element --- (New_Acc_Value (Get_Array_Ptr_Base_Ptr --- (Var_Ptr, Obj_Type, Kind)), --- New_Unsigned_Literal (Ghdl_Index_Type, 0)), --- Get_Element_Subtype (Obj_Type), --- Kind); --- when Type_Mode_Record => --- Res := Get_Memory_Complex_1 --- (New_Acc_Value (Var_Ptr), Obj_Type, Kind); --- when Type_Mode_Non_Composite --- | Type_Mode_Unknown => --- -- Cannot be a complex type. --- raise Internal_Error; --- end case; --- return New_Convert_Ov (Res, Char_Ptr_Type_Node); --- end Get_Memory_Complex; - -- Copy SRC to DEST. -- Both have the same type, OTYPE. procedure Translate_Object_Copy (Dest : Mnode; @@ -8565,8 +8419,7 @@ package body Translation is Info.T.Base_Field (Kind))), Get_Object_Size (Dest, Obj_Type)); when Type_Mode_Record - | Type_Mode_Array - | Type_Mode_Ptr_Array => + | Type_Mode_Array => Gen_Memcpy (M2Addr (D), Src, Get_Object_Size (Dest, Obj_Type)); @@ -8606,8 +8459,7 @@ package body Translation is (M2Addr (Get_Array_Base (D)), M2Addr (Get_Array_Base (E2M (Src, Info, Kind))), Get_Object_Size (D, Obj_Type)); - when Type_Mode_Record - | Type_Mode_Ptr_Array => + when Type_Mode_Record => Gen_Memcpy (M2Addr (Dest), Src, Get_Object_Size (Dest, Obj_Type)); when Type_Mode_Array => @@ -8937,8 +8789,11 @@ package body Translation is begin L_Tinfo := Get_Info (L_Type); R_Tinfo := Get_Info (R_Type); + -- FIXME: optimize for a statically bounded array of a complex type. if L_Tinfo.Type_Mode = Type_Mode_Array - and R_Tinfo.Type_Mode = Type_Mode_Array + and then L_Tinfo.Type_Locally_Constrained + and then R_Tinfo.Type_Mode = Type_Mode_Array + and then R_Tinfo.Type_Locally_Constrained then -- Both left and right are thin array. -- Check here the length are the same. @@ -9197,7 +9052,6 @@ package body Translation is return Tinfo.Ortho_Type (Kind); when Type_Mode_Record | Type_Mode_Array - | Type_Mode_Ptr_Array | Type_Mode_Protected => -- For a complex type, use a pointer. return Tinfo.Ortho_Ptr_Type (Kind); @@ -10559,7 +10413,6 @@ package body Translation is -- check for matching bounds. Atype := Get_Ortho_Type (Decl_Type, Info.Alias_Kind); when Type_Mode_Array - | Type_Mode_Ptr_Array | Type_Mode_Acc | Type_Mode_Fat_Acc => -- Create an object pointer. @@ -10615,8 +10468,7 @@ package body Translation is Tinfo, Alias_Info.Alias_Kind)); Copy_Fat_Pointer (Alias_Node, Name_Node); Close_Temp; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => Open_Temp; Stabilize (Name_Node); New_Assign_Stmt @@ -12570,7 +12422,7 @@ package body Translation is (Fat_Array, Array_Info.T.Bounds_Field (Is_Sig)); -- Dereference it. Lval := New_Access_Element (New_Value (Lval)); - when Type_Mode_Ptr_Array => + when Type_Mode_Array => Lval := Get_Var (Array_Info.T.Array_Bounds); when others => raise Internal_Error; @@ -12594,21 +12446,16 @@ package body Translation is Dim - 1); Tinfo := Get_Info (Arr_Type); - case Tinfo.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Ptr_Array => - Rinfo := Get_Info (Get_Base_Type (Index_Type)); - return New_Value - (New_Selected_Element - (Fat_Array_To_Range (Arr, Arr_Type, Dim, Is_Sig), - Rinfo.T.Range_Length)); - when Type_Mode_Array => - Constraint := Get_Range_Constraint (Index_Type); - return New_Lit - (Chap7.Translate_Static_Range_Length (Constraint)); - when others => - raise Internal_Error; - end case; + if Tinfo.Type_Locally_Constrained then + Constraint := Get_Range_Constraint (Index_Type); + return New_Lit (Chap7.Translate_Static_Range_Length (Constraint)); + else + Rinfo := Get_Info (Get_Base_Type (Index_Type)); + return New_Value + (New_Selected_Element + (Fat_Array_To_Range (Arr, Arr_Type, Dim, Is_Sig), + Rinfo.T.Range_Length)); + end if; end Get_Array_Bound_Length; function Get_Array_Ptr_Bound_Length (Ptr : O_Lnode; @@ -12624,8 +12471,7 @@ package body Translation is when Type_Mode_Fat_Array => return Get_Array_Bound_Length (New_Acc_Value (Ptr), Arr_Type, Dim, Is_Sig); - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => return Get_Array_Bound_Length (O_Lnode_Null, Arr_Type, Dim, Is_Sig); when others => @@ -12970,9 +12816,6 @@ package body Translation is Prefix := Stabilize (Prefix_Orig); when Type_Mode_Array => Prefix := Prefix_Orig; - when Type_Mode_Ptr_Array => - -- FIXME: should save the bounds address ? - Prefix := Prefix_Orig; when others => raise Internal_Error; end case; @@ -12994,20 +12837,21 @@ package body Translation is (Range_Ptr, Chap7.Translate_Expression (Index, Ibasetype), Null_Iir, Itype, Index); - when Type_Mode_Ptr_Array => - -- Manually extract range since there is no infos for - -- index subtype. - Range_Ptr := Chap3.Bounds_To_Range - (Chap3.Get_Array_Type_Bounds (Prefix_Type), - Prefix_Type, Dim); - Stabilize (Range_Ptr); - R := Translate_Index_To_Offset - (Range_Ptr, - Chap7.Translate_Expression (Index, Ibasetype), - Index, Itype, Index); when Type_Mode_Array => - -- BASE is a thin array. - R := Translate_Thin_Index_Offset (Itype, Dim, Index); + if Prefix_Info.Type_Locally_Constrained then + R := Translate_Thin_Index_Offset (Itype, Dim, Index); + else + -- Manually extract range since there is no infos for + -- index subtype. + Range_Ptr := Chap3.Bounds_To_Range + (Chap3.Get_Array_Type_Bounds (Prefix_Type), + Prefix_Type, Dim); + Stabilize (Range_Ptr); + R := Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression (Index, Ibasetype), + Index, Itype, Index); + end if; when others => raise Internal_Error; end case; @@ -13017,16 +12861,12 @@ package body Translation is else -- If there are more dimension(s) to follow, then multiply -- the current offset by the length of the current dimension. - case Prefix_Info.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Ptr_Array => - Length := M2E (Chap3.Range_To_Length (Range_Ptr)); - when Type_Mode_Array => - Length := New_Lit (Chap7.Translate_Static_Range_Length - (Get_Range_Constraint (Itype))); - when others => - raise Internal_Error; - end case; + if Prefix_Info.Type_Locally_Constrained then + Length := New_Lit (Chap7.Translate_Static_Range_Length + (Get_Range_Constraint (Itype))); + else + Length := M2E (Chap3.Range_To_Length (Range_Ptr)); + end if; New_Assign_Stmt (New_Obj (Offset), New_Dyadic_Op (ON_Add_Ov, @@ -13124,7 +12964,9 @@ package body Translation is Slice_Info := Get_Info (Slice_Type); if Slice_Info.Type_Mode = Type_Mode_Array + and then Slice_Info.Type_Locally_Constrained and then Prefix_Info.Type_Mode = Type_Mode_Array + and then Prefix_Info.Type_Locally_Constrained then Data.Is_Off := True; Data.Prefix_Var := Prefix; @@ -13297,30 +13139,18 @@ package body Translation is return Mnode is -- Type of the slice. - Slice_Type : Iir; - Slice_Info : Type_Info_Acc; + Slice_Type : constant Iir := Get_Type (Expr); + Slice_Info : constant Type_Info_Acc := Get_Info (Slice_Type); -- Object kind of the prefix. - Kind : Object_Kind_Type; + Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); - Res_L : O_Lnode; Res_D : O_Dnode; begin - -- Evaluate the prefix. - Slice_Type := Get_Type (Expr); - - Kind := Get_Object_Kind (Prefix); - - Slice_Info := Get_Info (Slice_Type); - if Data.Is_Off then - return Lv2M - (New_Slice (M2Lv (Prefix), - Slice_Info.Ortho_Type (Kind), - New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, Data.Off))), - Slice_Info, - Kind); + return Chap3.Slice_Base + (Prefix, Slice_Type, New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Data.Off))); else -- Create the result (fat array) and assign the bounds field. case Slice_Info.Type_Mode is @@ -13333,23 +13163,16 @@ package body Translation is New_Assign_Stmt (New_Selected_Element (New_Obj (Res_D), Slice_Info.T.Base_Field (Kind)), - New_Address - (New_Slice (M2Lv (Chap3.Get_Array_Base (Prefix)), - Slice_Info.T.Base_Type (Kind), - New_Obj_Value (Data.Unsigned_Diff)), - Slice_Info.T.Base_Ptr_Type (Kind))); + M2E (Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, + New_Obj_Value (Data.Unsigned_Diff)))); return Dv2M (Res_D, Slice_Info, Kind); - when Type_Mode_Array - | Type_Mode_Ptr_Array => - Res_L := New_Slice - (M2Lv (Chap3.Get_Array_Base (Prefix)), - Slice_Info.T.Base_Type (Kind), + when Type_Mode_Array => + return Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, New_Obj_Value (Data.Unsigned_Diff)); - return Lv2M (Res_L, - True, - Slice_Info.T.Base_Type (Kind), - Slice_Info.T.Base_Ptr_Type (Kind), - Slice_Info, Kind); when others => raise Internal_Error; end case; @@ -13510,8 +13333,7 @@ package body Translation is when Type_Mode_Fat_Array => return Get_Var (Name_Info.Alias_Var, Type_Info, Name_Info.Alias_Kind); - when Type_Mode_Ptr_Array - | Type_Mode_Array + when Type_Mode_Array | Type_Mode_Record | Type_Mode_Acc | Type_Mode_Fat_Acc => @@ -14018,7 +13840,7 @@ package body Translation is Val := Create_Global_Const (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), O_Storage_Private, Res); - elsif Type_Info.Type_Mode = Type_Mode_Ptr_Array then + elsif Type_Info.Type_Mode = Type_Mode_Array then null; else raise Internal_Error; @@ -14641,8 +14463,7 @@ package body Translation is when Type_Mode_Fat_Array => -- unconstrained to unconstrained. return Expr; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => -- constrained to unconstrained. return Convert_Constrained_To_Unconstrained (Expr, Expr_Type, Atype, Is_Sig); @@ -14651,49 +14472,38 @@ package body Translation is end case; when Type_Mode_Array => -- X to constrained. - case Einfo.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Ptr_Array => - -- unconstrained to constrained. - return Convert_Array_To_Thin_Array - (Expr, Expr_Type, Atype, Is_Sig, Loc); - when Type_Mode_Array => - -- constrained to constrained. - declare - E_List, A_List : Iir_List; - E_El, A_El : Iir; - begin - E_List := Get_Index_Subtype_List (Expr_Type); - A_List := Get_Index_Subtype_List (Atype); - for I in Natural loop - E_El := Get_Nth_Element (E_List, I); - A_El := Get_Nth_Element (A_List, I); - exit when E_El = Null_Iir - and then A_El = Null_Iir; - if Eval_Discrete_Type_Length (E_El) - /= Eval_Discrete_Type_Length (A_El) - then - -- FIXME: generate a bound error ? - -- Even if this is caught at compile-time, - -- the code is not required to run. - Chap6.Gen_Bound_Error (Loc); - end if; - end loop; - end; - return Expr; - when others => - raise Internal_Error; - end case; - when Type_Mode_Ptr_Array => - case Einfo.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Array - | Type_Mode_Ptr_Array => - return Convert_Array_To_Thin_Array - (Expr, Expr_Type, Atype, Is_Sig, Loc); - when others => - raise Internal_Error; - end case; + if Einfo.Type_Locally_Constrained + and then Ainfo.Type_Locally_Constrained + then + -- FIXME: optimize static vs non-static + -- constrained to constrained. + declare + E_List, A_List : Iir_List; + E_El, A_El : Iir; + begin + E_List := Get_Index_Subtype_List (Expr_Type); + A_List := Get_Index_Subtype_List (Atype); + for I in Natural loop + E_El := Get_Nth_Element (E_List, I); + A_El := Get_Nth_Element (A_List, I); + exit when E_El = Null_Iir + and then A_El = Null_Iir; + if Eval_Discrete_Type_Length (E_El) + /= Eval_Discrete_Type_Length (A_El) + then + -- FIXME: generate a bound error ? + -- Even if this is caught at compile-time, + -- the code is not required to run. + Chap6.Gen_Bound_Error (Loc); + end if; + end loop; + end; + return Expr; + else + -- unconstrained to constrained. + return Convert_Array_To_Thin_Array + (Expr, Expr_Type, Atype, Is_Sig, Loc); + end if; when others => raise Internal_Error; end case; @@ -15315,8 +15125,7 @@ package body Translation is Chap3.Translate_Object_Copy (T, New_Obj_Value (E), Target_Type); end; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => -- Source is of type TARGET_TYPE, so no length check is -- necessary. Chap3.Translate_Object_Copy (Target, Val, Target_Type); @@ -15405,8 +15214,7 @@ package body Translation is Arr_Var := Stabilize (Target); Base_Ptr := Stabilize (Chap3.Get_Array_Base (Arr_Var)); Len_Val := Chap3.Get_Array_Length (Arr_Var, Target_Type); - when Type_Mode_Ptr_Array - | Type_Mode_Array => + when Type_Mode_Array => Base_Ptr := Stabilize (Chap3.Get_Array_Base (Target)); Len_Val := Chap3.Get_Array_Type_Length (Target_Type); when others => @@ -16063,8 +15871,7 @@ package body Translation is Res_Info := Get_Info (Res_Type); Expr_Info := Get_Info (Expr_Type); case Res_Info.Type_Mode is - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => declare E : O_Dnode; begin @@ -17291,8 +17098,7 @@ package body Translation is return New_Dyadic_Op (ON_And, V1, V2); end; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => declare Lc, Rc : O_Enode; Base_Type : Iir_Array_Type_Definition; @@ -17737,10 +17543,9 @@ package body Translation is M2Addr (Chap3.Get_Array_Bounds (R))); New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Var_Arr)), - New_Address (New_Slice (M2Lv (Chap3.Get_Array_Base (Res)), - Info.T.Base_Type (Mode_Value), - New_Obj_Value (Var_L_Len)), - Info.T.Base_Ptr_Type (Mode_Value))); + M2Addr (Chap3.Slice_Base (Chap3.Get_Array_Base (Res), + Arr_Type, + New_Obj_Value (Var_L_Len)))); Chap3.Translate_Object_Copy (Var_Arr, New_Obj_Value (Var_R), Arr_Type); Close_Temp; @@ -18344,8 +18149,7 @@ package body Translation is end loop; Close_Temp; end; - when Type_Mode_Array - | Type_Mode_Ptr_Array => + when Type_Mode_Array => declare Var_Max : O_Dnode; begin @@ -18746,7 +18550,6 @@ package body Translation is Gen_Return; when Type_Mode_Record | Type_Mode_Array - | Type_Mode_Ptr_Array | Type_Mode_Fat_Acc => -- * if the return type is a constrained composite type, copy -- it to the result area. @@ -19943,7 +19746,6 @@ package body Translation is Close_Temp; when Type_Mode_Array | Type_Mode_Record - | Type_Mode_Ptr_Array | Type_Mode_Fat_Array => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); @@ -19998,7 +19800,6 @@ package body Translation is New_Procedure_Call (Assocs); Close_Temp; when Type_Mode_Array - | Type_Mode_Ptr_Array | Type_Mode_Record => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); @@ -25663,9 +25464,6 @@ package body Translation is New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_subtype_array"), Ghdl_Rtik_Subtype_Array); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_subtype_array_ptr"), - Ghdl_Rtik_Subtype_Array_Ptr); New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_subtype_unconstrained_array"), @@ -26537,7 +26335,7 @@ package body Translation is Push_Rti_Node (Prev, False); Unit := Get_Unit_Chain (Atype); if Get_Info (Unit) /= null then - Mode := 1; + Mode := 4; else Mode := 0; end if; @@ -26739,13 +26537,19 @@ package body Translation is Finish_Const_Value (Res, Val); end Generate_Array_Type_Indexes; - function Type_To_Mode (Info : Type_Info_Acc) return Natural is + function Type_To_Mode (Atype : Iir) return Natural is + Res : Natural := 0; begin - if Info.C /= null then - return 1; - else - return 0; + if Is_Complex_Type (Get_Info (Atype)) then + Res := Res + 1; end if; + if Is_Anonymous_Type_Definition (Atype) + or else (Get_Kind (Get_Type_Declarator (Atype)) + = Iir_Kind_Anonymous_Type_Declaration) + then + Res := Res + 2; + end if; + return Res; end Type_To_Mode; procedure Generate_Array_Type_Definition @@ -26796,7 +26600,7 @@ package body Translation is New_Record_Aggr_El (Aggr, Generate_Common_Type - (Ghdl_Rtik_Type_Array, 0, Max_Depth, Type_To_Mode (Info))); + (Ghdl_Rtik_Type_Array, 0, Max_Depth, Type_To_Mode (Atype))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti)); New_Record_Aggr_El @@ -26858,8 +26662,6 @@ package body Translation is case Info.Type_Mode is when Type_Mode_Array => Kind := Ghdl_Rtik_Subtype_Array; - when Type_Mode_Ptr_Array => - Kind := Ghdl_Rtik_Subtype_Array_Ptr; when Type_Mode_Fat_Array => Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; when others => @@ -26867,8 +26669,8 @@ package body Translation is end case; New_Record_Aggr_El (Aggr, - Generate_Common_Type (Kind, Depth, - Info.T.Rti_Max_Depth, Type_To_Mode (Info))); + Generate_Common_Type + (Kind, Depth, Info.T.Rti_Max_Depth, Type_To_Mode (Atype))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); if Bounds = null then @@ -26880,18 +26682,18 @@ package body Translation is for I in Mode_Value .. Mode_Signal loop case Info.Type_Mode is when Type_Mode_Array => + Val := Get_Null_Loc; if Info.Ortho_Type (I) /= O_Tnode_Null then - Val := New_Union_Aggr (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Offset, - New_Sizeof (Info.Ortho_Type (I), - Ghdl_Index_Type)); - else - Val := Get_Null_Loc; - end if; - when Type_Mode_Ptr_Array => - if Info.C (I) .Size_Var/= null then - Val := Var_Acc_To_Loc (Info.C (I).Size_Var); - else - Val := Get_Null_Loc; + if Is_Complex_Type (Info) then + if Info.C (I).Size_Var /= null then + Val := Var_Acc_To_Loc (Info.C (I).Size_Var); + end if; + else + Val := New_Union_Aggr + (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Offset, + New_Sizeof (Info.Ortho_Type (I), + Ghdl_Index_Type)); + end if; end if; when Type_Mode_Fat_Array => Val := Get_Null_Loc; @@ -26989,7 +26791,7 @@ package body Translation is New_Record_Aggr_El (Aggr, Generate_Common_Type (Ghdl_Rtik_Type_Record, 0, Max_Depth, - Type_To_Mode (Info))); + Type_To_Mode (Atype))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Unsigned_Literal @@ -27020,7 +26822,7 @@ package body Translation is New_Record_Aggr_El (List, Generate_Common_Type (Ghdl_Rtik_Type_Protected, 0, 0, - Type_To_Mode (Info))); + Type_To_Mode (Atype))); New_Record_Aggr_El (List, New_Name_Address (Name)); Finish_Record_Aggr (List, Val); Finish_Const_Value (Info.Type_Rti, Val); @@ -27470,6 +27272,9 @@ package body Translation is case Get_Kind (Decl) is when Iir_Kind_Use_Clause => null; + when Iir_Kind_Anonymous_Type_Declaration => + -- Handled in subtype declaration. + null; when Iir_Kind_Type_Declaration | Iir_Kind_Subtype_Declaration => Add_Rti_Node (Generate_Type_Decl (Decl)); @@ -27525,9 +27330,6 @@ package body Translation is | Iir_Kind_Procedure_Body => -- Already handled by Translate_Subprogram_Body. null; - when Iir_Kind_Anonymous_Type_Declaration => - -- Handled in subtype declaration. - null; when Iir_Kind_Configuration_Specification | Iir_Kind_Attribute_Specification | Iir_Kind_Disconnection_Specification => -- cgit v1.2.3