[multiple changes]

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

gcc/ada/ChangeLog

 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
 	function call is a legal expression to initialize a limited object.
 

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

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;
 

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

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