diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4598,13 +4598,7 @@ package body Exp_Attr is ---------------------------------- when Attribute_Max_Size_In_Storage_Elements => declare - Typ : constant Entity_Id := Etype (N); - Attr : Node_Id; - Atyp : Entity_Id; - - Conversion_Added : Boolean := False; - -- A flag which tracks whether the original attribute has been - -- wrapped inside a type conversion. + Typ : constant Entity_Id := Etype (N); begin -- If the prefix is X'Class, we transform it into a direct reference @@ -4618,40 +4612,22 @@ package body Exp_Attr is return; end if; - Apply_Universal_Integer_Attribute_Checks (N); - - -- The universal integer check may sometimes add a type conversion, - -- retrieve the original attribute reference from the expression. - - Attr := N; - - if Nkind (Attr) = N_Type_Conversion then - Attr := Expression (Attr); - Conversion_Added := True; - end if; - - pragma Assert (Nkind (Attr) = N_Attribute_Reference); - -- Heap-allocated controlled objects contain two extra pointers which -- are not part of the actual type. Transform the attribute reference -- into a runtime expression to add the size of the hidden header. - if Needs_Finalization (Ptyp) - and then not Header_Size_Added (Attr) - then - Set_Header_Size_Added (Attr); - - Atyp := Etype (Attr); + if Needs_Finalization (Ptyp) and then not Header_Size_Added (N) then + Set_Header_Size_Added (N); -- Generate: -- P'Max_Size_In_Storage_Elements + - -- Atyp (Header_Size_With_Padding (Ptyp'Alignment)) + -- Typ (Header_Size_With_Padding (Ptyp'Alignment)) - Rewrite (Attr, + Rewrite (N, Make_Op_Add (Loc, - Left_Opnd => Relocate_Node (Attr), + Left_Opnd => Relocate_Node (N), Right_Opnd => - Convert_To (Atyp, + Convert_To (Typ, Make_Function_Call (Loc, Name => New_Occurrence_Of @@ -4663,16 +4639,13 @@ package body Exp_Attr is New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Alignment)))))); - Analyze_And_Resolve (Attr, Atyp); - - -- Add a conversion to the target type - - if not Conversion_Added then - Convert_To_And_Rewrite (Typ, Attr); - end if; - + Analyze_And_Resolve (N, Typ); return; end if; + + -- In the other cases apply the required checks + + Apply_Universal_Integer_Attribute_Checks (N); end; -------------------- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -172,6 +172,10 @@ package body Exp_Ch4 is -- routine is to find the real type by looking up the tree. We also -- determine if the operation must be rounded. + function Get_Size_For_Range (Lo, Hi : Uint) return Uint; + -- Return the size of a small signed integer type covering Lo .. Hi, the + -- main goal being to return a size lower than that of standard types. + function Has_Inferable_Discriminants (N : Node_Id) return Boolean; -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable -- discriminants if it has a constrained nominal type, unless the object @@ -12270,6 +12274,41 @@ package body Exp_Ch4 is end; end if; + -- If the conversion is from Universal_Integer and requires an overflow + -- check, try to do an intermediate conversion to a narrower type first + -- without overflow check, in order to avoid doing the overflow check + -- in Universal_Integer, which can be a very large type. + + if Operand_Type = Universal_Integer and then Do_Overflow_Check (N) then + declare + Lo, Hi, Siz : Uint; + OK : Boolean; + Typ : Entity_Id; + + begin + Determine_Range (Operand, OK, Lo, Hi, Assume_Valid => True); + + if OK then + Siz := Get_Size_For_Range (Lo, Hi); + + -- We use the base type instead of the first subtype because + -- overflow checks are done in the base type, so this avoids + -- the need for useless conversions. + + if Siz < System_Max_Integer_Size then + Typ := Etype (Integer_Type_For (Siz, Uns => False)); + + Convert_To_And_Rewrite (Typ, Operand); + Analyze_And_Resolve + (Operand, Typ, Suppress => Overflow_Check); + + Analyze_And_Resolve (N, Target_Type); + goto Done; + end if; + end if; + end; + end if; + -- Do validity check if validity checking operands if Validity_Checks_On and Validity_Check_Operands then @@ -13328,6 +13367,54 @@ package body Exp_Ch4 is end if; end Fixup_Universal_Fixed_Operation; + ------------------------ + -- Get_Size_For_Range -- + ------------------------ + + function Get_Size_For_Range (Lo, Hi : Uint) return Uint is + + function Is_OK_For_Range (Siz : Uint) return Boolean; + -- Return True if a signed integer with given size can cover Lo .. Hi + + -------------------------- + -- Is_OK_For_Range -- + -------------------------- + + function Is_OK_For_Range (Siz : Uint) return Boolean is + B : constant Uint := Uint_2 ** (Siz - 1); + + begin + -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) + + return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B; + end Is_OK_For_Range; + + begin + -- This is (almost always) the size of Integer + + if Is_OK_For_Range (Uint_32) then + return Uint_32; + + -- Check 63 + + elsif Is_OK_For_Range (Uint_63) then + return Uint_63; + + -- This is (almost always) the size of Long_Long_Integer + + elsif Is_OK_For_Range (Uint_64) then + return Uint_64; + + -- Check 127 + + elsif Is_OK_For_Range (Uint_127) then + return Uint_127; + + else + return Uint_128; + end if; + end Get_Size_For_Range; + --------------------------------- -- Has_Inferable_Discriminants -- --------------------------------- @@ -14135,58 +14222,6 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (R); Tsiz : constant Uint := RM_Size (Typ); - function Get_Size_For_Range (Lo, Hi : Uint) return Uint; - -- Return the size of a small signed integer type covering Lo .. Hi. - -- The important thing is to return a size lower than that of Typ. - - ------------------------ - -- Get_Size_For_Range -- - ------------------------ - - function Get_Size_For_Range (Lo, Hi : Uint) return Uint is - - function Is_OK_For_Range (Siz : Uint) return Boolean; - -- Return True if a signed integer with given size can cover Lo .. Hi - - -------------------------- - -- Is_OK_For_Range -- - -------------------------- - - function Is_OK_For_Range (Siz : Uint) return Boolean is - B : constant Uint := Uint_2 ** (Siz - 1); - - begin - -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) - - return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B; - end Is_OK_For_Range; - - begin - -- This is (almost always) the size of Integer - - if Is_OK_For_Range (Uint_32) then - return Uint_32; - - -- If the size of Typ is 64 then check 63 - - elsif Tsiz = Uint_64 and then Is_OK_For_Range (Uint_63) then - return Uint_63; - - -- This is (almost always) the size of Long_Long_Integer - - elsif Is_OK_For_Range (Uint_64) then - return Uint_64; - - -- If the size of Typ is 128 then check 127 - - elsif Tsiz = Uint_128 and then Is_OK_For_Range (Uint_127) then - return Uint_127; - - else - return Uint_128; - end if; - end Get_Size_For_Range; - -- Local variables L : Node_Id;