OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2009-06-20  Ed Schonberg  <schonberg@adacore.com>

	* 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  <dewar@adacore.com>

	* 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  <quinot@adacore.com>

	* sem_prag.adb: Minor reformatting

	* exp_disp.ads: Minor reformatting

From-SVN: r148745
This commit is contained in:
Arnaud Charlet 2009-06-20 12:32:58 +02:00
parent e80d72ea16
commit 5afaf827b7
5 changed files with 58 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ada/ChangeLog
View File

@ -1,3 +1,20 @@
2009-06-20 Ed Schonberg <schonberg@adacore.com>
* 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 <dewar@adacore.com>
* 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 <quinot@adacore.com>
* sem_prag.adb: Minor reformatting
* exp_disp.ads: Minor reformatting
2009-06-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Is_OK_For_Limited_Init): An unchecked conversion of a

46
gcc/ada/a-nudira.adb
View File

@ -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

12
gcc/ada/exp_ch3.adb
View File

@ -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;

2
gcc/ada/exp_disp.ads
View File

@ -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

13
gcc/ada/sem_prag.adb
View File

@ -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);