From: Arnaud Charlet Date: Sat, 20 Jun 2009 10:32:58 +0000 (+0200) Subject: [multiple changes] X-Git-Tag: releases/gcc-4.5.0~5086 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=5afaf827b7b4a5f34f6baf1a92ac14f797191fc1;p=thirdparty%2Fgcc.git [multiple changes] 2009-06-20 Ed Schonberg * exp_ch3.adb (Build_Record_Init_Proc): When copying initial expressions (possibly from a parent type) indicate that the scope of the new itypes is the initialization procedure being built. 2009-06-20 Robert Dewar * a-nudira.adb (Fits_In_32_Bits): New name (inverted sense) for Needs_64, and now computed without anomolies for some dynamic types. 2009-06-20 Thomas Quinot * sem_prag.adb: Minor reformatting * exp_disp.ads: Minor reformatting From-SVN: r148745 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 66edece62cd1..f30a5c425b78 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2009-06-20 Ed Schonberg + + * exp_ch3.adb (Build_Record_Init_Proc): When copying initial + expressions (possibly from a parent type) indicate that the scope of + the new itypes is the initialization procedure being built. + +2009-06-20 Robert Dewar + + * a-nudira.adb (Fits_In_32_Bits): New name (inverted sense) for + Needs_64, and now computed without anomolies for some dynamic types. + +2009-06-20 Thomas Quinot + + * sem_prag.adb: Minor reformatting + + * exp_disp.ads: Minor reformatting + 2009-06-20 Ed Schonberg * sem_ch3.adb (Is_OK_For_Limited_Init): An unchecked conversion of a diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb index 3a8819b6aaa7..3ed4fedfe14c 100644 --- a/gcc/ada/a-nudira.adb +++ b/gcc/ada/a-nudira.adb @@ -51,24 +51,34 @@ package body Ada.Numerics.Discrete_Random is type Pointer is access all State; - Need_64 : constant Boolean := Rst'Pos (Rst'Last) > 2**31 - 1 - or else - Rst'Pos (Rst'First) < 2**31; - -- Set if we need more than 32 bits in the result. In practice we will - -- only use the meaningful 48 bits of any 64 bit number generated, since - -- if more than 48 bits are required, we split the computation into two - -- separate parts, since the algorithm does not behave above 48 bits. + Fits_In_32_Bits : constant Boolean := + Rst'Size < 31 + or else (Rst'Size = 31 + and then Rst'Pos (Rst'First) < 0); + -- This is set True if we do not need more than 32 bits in the result. If + -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit + -- number generated, since if more than 48 bits are required, we split the + -- computation into two separate parts, since the algorithm does not behave + -- above 48 bits. + + -- The way this expression works is that obviously if the size is 31 bits, + -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the + -- range has negative values. It is too conservative in the case that the + -- programmer has set a size greater than the default, e.g. a size of 33 + -- for an integer type with a size of 1..10. But an over-conservative + -- result is OK. The important thing is that the value is only True if + -- we know the result will fit in 32-bits signed. If the value is False + -- when it could be True, the behavior will be correct, just a bit less + -- efficient than it could have been in some unusual cases. -- - -- Note: the right hand side used to be Int'Last, but that won't work - -- since it means that if Rst is a dynamic subtype, the comparison is - -- evaluated at run time in type Int, which is too small. In practice - -- the use of dynamic bounds is rare, and this constant will always - -- be evaluated at compile time in an instance. - -- - -- This still is not quite right for dynamic subtypes of 64-bit modular - -- types where the upper bound can exceed the upper bound of universal - -- integer. Not clear how to do this with a nice static expression ??? - -- Might have to introduce a special Type'First_In_32_Bits attribute! + -- One might assume that we could get a more accurate result by testing + -- the lower and upper bounds of the type Rst against the bounds of 32-bit + -- Integer. However, there is no easy way to do that. Why? Because in the + -- relatively rare case where this expresion has to be evaluated at run + -- time rather than compile time (when the bounds are dynamic), we need a + -- type to use for the computation. But the possible range of upper bound + -- values for Rst (remembering the possibility of 64-bit modular types) is + -- from -2**63 to 2**64-1, and no run-time type has a big enough range. ----------------------- -- Local Subprograms -- @@ -134,7 +144,7 @@ package body Ada.Numerics.Discrete_Random is if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then return Rst'First; - elsif Need_64 then + elsif not Fits_In_32_Bits then return Rst'Val (Interfaces.Integer_64 (TF)); else diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 70287a652c1d..87beb499f37b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1850,9 +1850,10 @@ package body Exp_Ch3 is -- Take a copy of Exp to ensure that later copies of this component -- declaration in derived types see the original tree, not a node - -- rewritten during expansion of the init_proc. + -- rewritten during expansion of the init_proc. If the copy contains + -- itypes, the scope of the new itypes is the init.proc being built. - Exp := New_Copy_Tree (Exp); + Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id); Res := New_List ( Make_Assignment_Statement (Loc, @@ -1870,7 +1871,7 @@ package body Exp_Ch3 is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Lhs), + Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id), Selector_Name => New_Reference_To (First_Tag_Component (Typ), Loc)), @@ -1893,10 +1894,11 @@ package body Exp_Ch3 is then Append_List_To (Res, Make_Adjust_Call ( - Ref => New_Copy_Tree (Lhs), + Ref => New_Copy_Tree (Lhs, New_Scope => Proc_Id), Typ => Etype (Id), Flist_Ref => - Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), + Find_Final_List + (Etype (Id), New_Copy_Tree (Lhs, New_Scope => Proc_Id)), With_Attach => Make_Integer_Literal (Loc, 1))); end if; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index c91798f24509..978f0e65f318 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -146,7 +146,7 @@ package Exp_Disp is -- Snames.adb. -- Categorize the new PPO name as predefined by adding an entry in - -- Is_Predefined_Dispatching_Operation in Exp_Util.adb. + -- Is_Predefined_Dispatching_Operation in Exp_Disp. -- Generate the specification of the new PPO in Make_Predefined_ -- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f69fcda99eb8..ea43c9135c44 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2802,8 +2802,7 @@ package body Sem_Prag is end if; if Warn_On_Export_Import and then Is_Exported (Def_Id) then - Error_Msg_N - ("?duplicate Export_Object pragma", N); + Error_Msg_N ("?duplicate Export_Object pragma", N); else Set_Exported (Def_Id, Arg_Internal); end if; @@ -2843,8 +2842,8 @@ package body Sem_Prag is ("?duplicate Import_Object pragma", N); -- Check for explicit initialization present. Note that an - -- initialization that generated by the code generator, e.g. - -- for an access type, does not count here. + -- initialization generated by the code generator, e.g. for an + -- access type, does not count here. elsif Present (Expression (Parent (Def_Id))) and then @@ -3141,12 +3140,10 @@ package body Sem_Prag is Formal := First_Formal (Ent); if No (Formal) then - Error_Pragma - ("at least one parameter required for pragma%"); + Error_Pragma ("at least one parameter required for pragma%"); elsif Ekind (Formal) /= E_Out_Parameter then - Error_Pragma - ("first parameter must have mode out for pragma%"); + Error_Pragma ("first parameter must have mode out for pragma%"); else Set_Is_Valued_Procedure (Ent);