[multiple changes]

2010-06-23  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb: Use predefined unsigned type in all cases.

2010-06-23  Bob Duff  <duff@adacore.com>

	* s-rannum.adb (Reset): Avoid overflow in calculation of Initiator.
	* g-pehage.ads: Minor comment fixes.
	* g-pehage.adb: Minor: Add some additional debugging printouts under
	Verbose flag.

2010-06-23  Robert Dewar  <dewar@adacore.com>

	* binde.adb (Better_Choice): Always prefer Pure/Preelab.
	(Worse_Choice): Always prefer Pure/Preelab.

From-SVN: r161246

gcc/ada/ChangeLog

+2010-06-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch4.adb: Use predefined unsigned type in all cases.
+
+2010-06-23  Bob Duff  <duff@adacore.com>
+
+	* s-rannum.adb (Reset): Avoid overflow in calculation of Initiator.
+	* g-pehage.ads: Minor comment fixes.
+	* g-pehage.adb: Minor: Add some additional debugging printouts under
+	Verbose flag.
+
+2010-06-23  Robert Dewar  <dewar@adacore.com>
+
+	* binde.adb (Better_Choice): Always prefer Pure/Preelab.
+	(Worse_Choice): Always prefer Pure/Preelab.
+
 2010-06-23  Vincent Celier  <celier@adacore.com>
 
 	* a-reatim.adb: Call System.OS_Primitives.Initialize during elaboration

gcc/ada/binde.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -224,25 +224,25 @@ package body Binde is
       After  : Unit_Id;
       R      : Succ_Reason;
       Ea_Id  : Elab_All_Id := No_Elab_All_Link);
-   --  Establish a successor link, Before must be elaborated before After,
-   --  and the reason for the link is R. Ea_Id is the contents to be placed
-   --  in the Elab_All_Link of the entry.
+   --  Establish a successor link, Before must be elaborated before After, and
+   --  the reason for the link is R. Ea_Id is the contents to be placed in the
+   --  Elab_All_Link of the entry.
 
    procedure Choose (Chosen : Unit_Id);
-   --  Chosen is the next entry chosen in the elaboration order. This
-   --  procedure updates all data structures appropriately.
+   --  Chosen is the next entry chosen in the elaboration order. This procedure
+   --  updates all data structures appropriately.
 
    function Corresponding_Body (U : Unit_Id) return Unit_Id;
    pragma Inline (Corresponding_Body);
-   --  Given a unit which is a spec for which there is a separate body,
-   --  return the unit id of the body. It is an error to call this routine
-   --  with a unit that is not a spec, or which does not have a separate body.
+   --  Given a unit which is a spec for which there is a separate body, return
+   --  the unit id of the body. It is an error to call this routine with a unit
+   --  that is not a spec, or which does not have a separate body.
 
    function Corresponding_Spec (U : Unit_Id) return Unit_Id;
    pragma Inline (Corresponding_Spec);
-   --  Given a unit which is a body for which there is a separate spec,
-   --  return the unit id of the spec. It is an error to call this routine
-   --  with a unit that is not a body, or which does not have a separate spec.
+   --  Given a unit which is a body for which there is a separate spec, return
+   --  the unit id of the spec. It is an error to call this routine with a unit
+   --  that is not a body, or which does not have a separate spec.
 
    procedure Diagnose_Elaboration_Problem;
    --  Called when no elaboration order can be found. Outputs an appropriate
@@ -276,6 +276,10 @@ package body Binde is
    pragma Inline (Is_Body_Unit);
    --  Determines if given unit is a body
 
+   function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean;
+   --  Returns True if corresponding unit is Pure or Preelaborate. Includes
+   --  dealing with testing flags on spec if it is given a body.
+
    function Is_Waiting_Body (U : Unit_Id) return Boolean;
    pragma Inline (Is_Waiting_Body);
    --  Determines if U is a waiting body, defined as a body which has
@@ -286,16 +290,16 @@ package body Binde is
       Link : Elab_All_Id) return Elab_All_Id;
    --  Make an Elab_All_Entries table entry with the given Unam and Link
 
-   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
-   --  This function uses the Info field set in the names table to obtain
-   --  the unit Id of a unit, given its name id value.
-
-   function Worse_Choice (U1, U2 : Unit_Id) return Boolean;
+   function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean;
    --  This is like Better_Choice, and has the same interface, but returns
-   --  true if U1 is a worse choice than U2 in the sense of the -h (horrible
+   --  true if U1 is a worse choice than U2 in the sense of the -p (pessimistic
    --  elaboration order) switch. We still have to obey Ada rules, so it is
    --  not quite the direct inverse of Better_Choice.
 
+   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
+   --  This function uses the Info field set in the names table to obtain
+   --  the unit Id of a unit, given its name id value.
+
    procedure Write_Dependencies;
    --  Write out dependencies (called only if appropriate option is set)
 
@@ -323,7 +327,7 @@ package body Binde is
       --  Note: the checks here are applied in sequence, and the ordering is
       --  significant (i.e. the more important criteria are applied first).
 
-      --  Prefer a waiting body to any other case
+      --  Prefer a waiting body to one that is not a waiting body
 
       if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
          if Debug_Flag_B then
@@ -370,6 +374,28 @@ package body Binde is
 
          return False;
 
+      --  Prefer a pure or preelaborable unit to one that is not
+
+      elsif Is_Pure_Or_Preelab_Unit (U1)
+              and then not
+            Is_Pure_Or_Preelab_Unit (U2)
+      then
+         if Debug_Flag_B then
+            Write_Line ("  True: u1 is pure/preelab, u2 is not");
+         end if;
+
+         return True;
+
+      elsif Is_Pure_Or_Preelab_Unit (U2)
+              and then not
+            Is_Pure_Or_Preelab_Unit (U1)
+      then
+         if Debug_Flag_B then
+            Write_Line ("  False: u2 is pure/preelab, u1 is not");
+         end if;
+
+         return False;
+
       --  Prefer a body to a spec
 
       elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
@@ -1141,7 +1167,7 @@ package body Binde is
               or else ((not Pessimistic_Elab_Order)
                          and then Better_Choice (U, Best_So_Far))
               or else (Pessimistic_Elab_Order
-                         and then Worse_Choice (U, Best_So_Far))
+                         and then Pessimistic_Better_Choice (U, Best_So_Far))
             then
                if Debug_Flag_N then
                   Write_Str ("    tentatively chosen (best so far)");
@@ -1321,6 +1347,28 @@ package body Binde is
         or else Units.Table (U).Utype = Is_Body_Only;
    end Is_Body_Unit;
 
+   -----------------------------
+   -- Is_Pure_Or_Preelab_Unit --
+   -----------------------------
+
+   function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is
+   begin
+      --  If we have a body with separate spec, test flags on the spec
+
+      if Units.Table (U).Utype = Is_Body then
+         return Units.Table (U + 1).Preelab
+                  or else
+                Units.Table (U + 1).Pure;
+
+      --  Otherwise we have a spec or body acting as spec, test flags on unit
+
+      else
+         return Units.Table (U).Preelab
+                  or else
+                Units.Table (U).Pure;
+      end if;
+   end Is_Pure_Or_Preelab_Unit;
+
    ---------------------
    -- Is_Waiting_Body --
    ---------------------
@@ -1346,51 +1394,115 @@ package body Binde is
       return Elab_All_Entries.Last;
    end Make_Elab_Entry;
 
-   ----------------
-   -- Unit_Id_Of --
-   ----------------
-
-   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
-      Info : constant Int := Get_Name_Table_Info (Uname);
-   begin
-      pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
-      return Unit_Id (Info);
-   end Unit_Id_Of;
-
-   ------------------
-   -- Worse_Choice --
-   ------------------
+   -------------------------------
+   -- Pessimistic_Better_Choice --
+   -------------------------------
 
-   function Worse_Choice (U1, U2 : Unit_Id) return Boolean is
+   function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is
       UT1 : Unit_Record renames Units.Table (U1);
       UT2 : Unit_Record renames Units.Table (U2);
 
    begin
+      if Debug_Flag_B then
+         Write_Str ("Pessimistic_Better_Choice (");
+         Write_Unit_Name (UT1.Uname);
+         Write_Str (", ");
+         Write_Unit_Name (UT2.Uname);
+         Write_Line (")");
+      end if;
+
       --  Note: the checks here are applied in sequence, and the ordering is
       --  significant (i.e. the more important criteria are applied first).
 
-      --  If either unit is internal, then use Better_Choice, since the
-      --  language requires that predefined units not mess up in the choice
-      --  of elaboration order, and for internal units, any problems are
-      --  ours and not the programmers.
+      --  If either unit is predefined or internal, then we use the normal
+      --  Better_Choice rule, since we don't want to disturb the elaboration
+      --  rules of the language with -p, same treatment for Pure/Preelab.
+
+      --  Prefer a predefined unit to a non-predefined unit
 
-      if UT1.Internal or else UT2.Internal then
-         return Better_Choice (U1, U2);
+      if UT1.Predefined and then not UT2.Predefined then
+         if Debug_Flag_B then
+            Write_Line ("  True: u1 is predefined, u2 is not");
+         end if;
 
-      --  Prefer anything else to a waiting body (!)
+         return True;
+
+      elsif UT2.Predefined and then not UT1.Predefined then
+         if Debug_Flag_B then
+            Write_Line ("  False: u2 is predefined, u1 is not");
+         end if;
+
+         return False;
+
+      --  Prefer an internal unit to a non-internal unit
+
+      elsif UT1.Internal and then not UT2.Internal then
+         if Debug_Flag_B then
+            Write_Line ("  True: u1 is internal, u2 is not");
+         end if;
+
+         return True;
+
+      elsif UT2.Internal and then not UT1.Internal then
+         if Debug_Flag_B then
+            Write_Line ("  False: u2 is internal, u1 is not");
+         end if;
+
+         return False;
+
+      --  Prefer a pure or preelaborable unit to one that is not
+
+      elsif Is_Pure_Or_Preelab_Unit (U1)
+              and then not
+            Is_Pure_Or_Preelab_Unit (U2)
+      then
+         if Debug_Flag_B then
+            Write_Line ("  True: u1 is pure/preelab, u2 is not");
+         end if;
+
+         return True;
+
+      elsif Is_Pure_Or_Preelab_Unit (U2)
+              and then not
+            Is_Pure_Or_Preelab_Unit (U1)
+      then
+         if Debug_Flag_B then
+            Write_Line ("  False: u2 is pure/preelab, u1 is not");
+         end if;
+
+         return False;
+
+      --  Prefer anything else to a waiting body. We want to make bodies wait
+      --  as long as possible, till we are forced to choose them!
 
       elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
+         if Debug_Flag_B then
+            Write_Line ("  False: u1 is waiting body, u2 is not");
+         end if;
+
          return False;
 
       elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
+         if Debug_Flag_B then
+            Write_Line ("  True: u2 is waiting body, u1 is not");
+         end if;
+
          return True;
 
       --  Prefer a spec to a body (!)
 
       elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
+         if Debug_Flag_B then
+            Write_Line ("  False: u1 is body, u2 is not");
+         end if;
+
          return False;
 
       elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
+         if Debug_Flag_B then
+            Write_Line ("  True: u2 is body, u1 is not");
+         end if;
+
          return True;
 
       --  If both are waiting bodies, then prefer the one whose spec is
@@ -1404,12 +1516,24 @@ package body Binde is
       --  A before the spec of B if it could. Since it could not, there it
       --  must be the case that A depends on B. It is therefore a good idea
       --  to put the body of B last so that if there is an elaboration order
-      --  problem, we will find it (that's what horrible order is about)
+      --  problem, we will find it (that's what pssimistic order is about)
 
       elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
-         return
-           UNR.Table (Corresponding_Spec (U1)).Elab_Position <
-           UNR.Table (Corresponding_Spec (U2)).Elab_Position;
+         declare
+            Result : constant Boolean :=
+                       UNR.Table (Corresponding_Spec (U1)).Elab_Position <
+                       UNR.Table (Corresponding_Spec (U2)).Elab_Position;
+         begin
+            if Debug_Flag_B then
+               if Result then
+                  Write_Line ("  True: based on waiting body elab positions");
+               else
+                  Write_Line ("  False: based on waiting body elab positions");
+               end if;
+            end if;
+
+            return Result;
+         end;
       end if;
 
       --  Remaining choice rules are disabled by Debug flag -do
@@ -1420,44 +1544,81 @@ package body Binde is
          --  as Elaborate_Body_Desirable. In the normal case, we generally want
          --  to delay the elaboration of these specs as long as possible, so
          --  that bodies have better chance of being elaborated closer to the
-         --  specs. Worse_Choice as usual wants to do the opposite and
-         --  elaborate such specs as early as possible.
+         --  specs. Pessimistic_Better_Choice as usual wants to do the opposite
+         --  and elaborate such specs as early as possible.
 
          --  If we have two units, one of which is a spec for which this flag
          --  is set, and the other is not, we normally prefer to delay the spec
-         --  for which the flag is set, and so Worse_Choice does the opposite.
+         --  for which the flag is set, so again Pessimistic_Better_Choice does
+         --  the opposite.
 
          if not UT1.Elaborate_Body_Desirable
            and then UT2.Elaborate_Body_Desirable
          then
+            if Debug_Flag_B then
+               Write_Line ("  False: u1 is elab body desirable, u2 is not");
+            end if;
+
             return False;
 
          elsif not UT2.Elaborate_Body_Desirable
            and then UT1.Elaborate_Body_Desirable
          then
+            if Debug_Flag_B then
+               Write_Line ("  True: u1 is elab body desirable, u2 is not");
+            end if;
+
             return True;
 
             --  If we have two specs that are both marked as Elaborate_Body
             --  desirable, we normally prefer the one whose body is nearer to
             --  being able to be elaborated, based on the Num_Pred count. This
             --  helps to ensure bodies are as close to specs as possible. As
-            --  usual, Worse_Choice does the opposite.
+            --  usual, Pessimistic_Better_Choice does the opposite.
 
          elsif UT1.Elaborate_Body_Desirable
            and then UT2.Elaborate_Body_Desirable
          then
-            return UNR.Table (Corresponding_Body (U1)).Num_Pred >=
-              UNR.Table (Corresponding_Body (U2)).Num_Pred;
+            declare
+               Result : constant Boolean :=
+                          UNR.Table (Corresponding_Body (U1)).Num_Pred >=
+                          UNR.Table (Corresponding_Body (U2)).Num_Pred;
+            begin
+               if Debug_Flag_B then
+                  if Result then
+                     Write_Line ("  True based on Num_Pred compare");
+                  else
+                     Write_Line ("  False based on Num_Pred compare");
+                  end if;
+               end if;
+
+               return Result;
+            end;
          end if;
       end if;
 
       --  If we fall through, it means that no preference rule applies, so we
       --  use alphabetical order to at least give a deterministic result. Since
-      --  Worse_Choice is in the business of stirring up the order, we will
-      --  use reverse alphabetical ordering.
+      --  Pessimistic_Better_Choice is in the business of stirring up the
+      --  order, we will use reverse alphabetical ordering.
+
+      if Debug_Flag_B then
+         Write_Line ("  choose on reverse alpha order");
+      end if;
 
       return Uname_Less (UT2.Uname, UT1.Uname);
-   end Worse_Choice;
+   end Pessimistic_Better_Choice;
+
+   ----------------
+   -- Unit_Id_Of --
+   ----------------
+
+   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
+      Info : constant Int := Get_Name_Table_Info (Uname);
+   begin
+      pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
+      return Unit_Id (Info);
+   end Unit_Id_Of;
 
    ------------------------
    -- Write_Dependencies --

gcc/ada/exp_ch4.adb

@@ -6927,7 +6927,7 @@ package body Exp_Ch4 is
                Utyp := RTE (RE_Unsigned_16);
 
             elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then
-               Utyp := Typ;
+               Utyp := RTE (RE_Unsigned_32);
 
             else
                Utyp := RTE (RE_Long_Long_Unsigned);

gcc/ada/g-pehage.adb

@@ -33,6 +33,7 @@
 
 with Ada.IO_Exceptions;       use Ada.IO_Exceptions;
 with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Directories;
 
 with GNAT.Heap_Sort_G;
 with GNAT.OS_Lib;      use GNAT.OS_Lib;
@@ -888,6 +889,11 @@ package body GNAT.Perfect_Hash_Generators is
 
    procedure Finalize is
    begin
+      if Verbose then
+         Put (Output, "Finalize");
+         New_Line (Output);
+      end if;
+
       --  Deallocate all the WT components (both initial and reduced
       --  ones) to avoid memory leaks.
 
@@ -1165,6 +1171,11 @@ package body GNAT.Perfect_Hash_Generators is
       Tries  : Positive     := Default_Tries)
    is
    begin
+      if Verbose then
+         Put (Output, "Initialize");
+         New_Line (Output);
+      end if;
+
       --  Deallocate the part of the table concerning the reduced words.
       --  Initial words are already present in the table. We may have reduced
       --  words already there because a previous computation failed. We are
@@ -1245,6 +1256,11 @@ package body GNAT.Perfect_Hash_Generators is
       Len  : constant Natural := Value'Length;
 
    begin
+      if Verbose then
+         Put (Output, "Inserting """ & Value & """");
+         New_Line (Output);
+      end if;
+
       WT.Set_Last (NK);
       WT.Table (NK) := New_Word (Value);
       NK := NK + 1;
@@ -1494,6 +1510,12 @@ package body GNAT.Perfect_Hash_Generators is
 
    begin
 
+      if Verbose then
+         Put (Output,
+              "Producing " & Ada.Directories.Current_Directory & "/" & FName);
+         New_Line (Output);
+      end if;
+
       File := Create_File (FName, Binary);
 
       if File = Invalid_FD then

gcc/ada/g-pehage.ads

@@ -124,11 +124,11 @@ package GNAT.Perfect_Hash_Generators is
    procedure Compute (Position : String := Default_Position);
    --  Compute the hash function. Position allows to define selection of
    --  character positions used in the word hash function. Positions can be
-   --  separated by commas and range like x-y may be used. Character '$'
+   --  separated by commas and ranges like x-y may be used. Character '$'
    --  represents the final character of a word. With an empty position, the
    --  generator automatically produces positions to reduce the memory usage.
-   --  Raise Too_Many_Tries in case that the algorithm does not succeed in less
-   --  than Tries attempts (see Initialize).
+   --  Raise Too_Many_Tries if the algorithm does not succeed within Tries
+   --  attempts (see Initialize).
 
    procedure Produce (Pkg_Name : String := Default_Pkg_Name);
    --  Generate the hash function package Pkg_Name. This package includes the

gcc/ada/s-rannum.adb

@@ -484,7 +484,12 @@ package body System.Random_Numbers is
    -----------
 
    procedure Reset (Gen : Generator) is
-      X : constant Unsigned_32 := Unsigned_32 ((Calendar.Clock - Y2K) * 64.0);
+      Clock              : constant Time := Calendar.Clock;
+      Duration_Since_Y2K : constant Duration := Clock - Y2K;
+
+      X : constant Unsigned_32 :=
+            Unsigned_32'Mod (Unsigned_64 (Duration_Since_Y2K) * 64);
+
    begin
       Init (Gen, X);
    end Reset;