[multiple changes]

2014-07-30  Ed Schonberg  <schonberg@adacore.com>

	* a-chtgop.ads, a-chtgop.adb (Delete_Node_At_Index): New
	subprogram, used by all versions of hashed sets, to delete a node
	whose element has been improperly updated through a Reference_
	Preserving key.
	* a-cohase.adb: Remove Delete_Node, use new common procedure
	Delete_Node_At_Index.
	* a-cihase.ads: Add Reference_Control_Type to package Generic_Keys.
	* a-cihase.adb: Add Adjust and Finalize routines for
	Reference_Control_Type.
	(Reference_Preserving_Key): Build aggregate for
	Reference_Control_Type

2014-07-30  Yannick Moy  <moy@adacore.com>

	* checks.adb, checks.ads (Determine_Range_R): New procedure to
	determine the possible range of a floating-point expression.

2014-07-30  Ed Schonberg  <schonberg@adacore.com>

	* a-cborse.ads: Add Reference_Control_Type to package Generic_Keys.
	* a-cborse.adb: Add Adjust and Finalize routines for
	Reference_Control_Type.
	(Reference_Preserving_Key): Build aggregate for
	Reference_Control_Type.
	(Delete): Check for tampering, and raise Program_Error (not
	Constraint_Error) when attempting to delete an element not in
	the set.
	(Insert): Ditto.

2014-07-30  Bob Duff  <duff@adacore.com>

	* a-elchha.adb, a-except-2005.adb, a-except.adb, a-exexda.adb,
	* a-exextr.adb, a-exstat.adb, exp_intr.ads, s-tassta.adb:
	Exception_Information is used to produce useful debugging
	information for the programmer. However, it was also used to
	implement the stream attributes for type Exception_Occurrence. The
	latter requires a stable and portable interface, which meant
	that we couldn't include a symbolic traceback. A separate set of
	routines was used to provide symbolic tracebacks under program
	control (i.e. not automatically). The goal of this ticket is
	to provide such automatic tracebacks, so the change here is to
	split the two functionalities: Exception_Information gives the
	maximally useful information for debugging (i.e. it now includes
	a symbolic traceback when a decorator is set, and it can be
	improved freely in the future without disturbing streaming).
	Untailored_Exception_Information always uses hexadecimal addresses
	in the traceback, has a stable and portable output, and is now
	used for streaming.

2014-07-30  Eric Botcazou  <ebotcazou@adacore.com>

	* exp_aggr.adb (Expand_Array_Aggregate): Add missing test
	on the target of the assignment to find out whether it
	can be directly done by the back-end.
	* exp_util.adb (Is_Possibly_Unaligned_Slice): Remove obscure test.

From-SVN: r213279

gcc/ada/ChangeLog

+2014-07-30  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-chtgop.ads, a-chtgop.adb (Delete_Node_At_Index): New
+	subprogram, used by all versions of hashed sets, to delete a node
+	whose element has been improperly updated through a Reference_
+	Preserving key.
+	* a-cohase.adb: Remove Delete_Node, use new common procedure
+	Delete_Node_At_Index.
+	* a-cihase.ads: Add Reference_Control_Type to package Generic_Keys.
+	* a-cihase.adb: Add Adjust and Finalize routines for
+	Reference_Control_Type.
+	(Reference_Preserving_Key): Build aggregate for
+	Reference_Control_Type
+
+2014-07-30  Yannick Moy  <moy@adacore.com>
+
+	* checks.adb, checks.ads (Determine_Range_R): New procedure to
+	determine the possible range of a floating-point expression.
+
+2014-07-30  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-cborse.ads: Add Reference_Control_Type to package Generic_Keys.
+	* a-cborse.adb: Add Adjust and Finalize routines for
+	Reference_Control_Type.
+	(Reference_Preserving_Key): Build aggregate for
+	Reference_Control_Type.
+	(Delete): Check for tampering, and raise Program_Error (not
+	Constraint_Error) when attempting to delete an element not in
+	the set.
+	(Insert): Ditto.
+
+2014-07-30  Bob Duff  <duff@adacore.com>
+
+	* a-elchha.adb, a-except-2005.adb, a-except.adb, a-exexda.adb,
+	* a-exextr.adb, a-exstat.adb, exp_intr.ads, s-tassta.adb:
+	Exception_Information is used to produce useful debugging
+	information for the programmer. However, it was also used to
+	implement the stream attributes for type Exception_Occurrence. The
+	latter requires a stable and portable interface, which meant
+	that we couldn't include a symbolic traceback. A separate set of
+	routines was used to provide symbolic tracebacks under program
+	control (i.e. not automatically). The goal of this ticket is
+	to provide such automatic tracebacks, so the change here is to
+	split the two functionalities: Exception_Information gives the
+	maximally useful information for debugging (i.e. it now includes
+	a symbolic traceback when a decorator is set, and it can be
+	improved freely in the future without disturbing streaming).
+	Untailored_Exception_Information always uses hexadecimal addresses
+	in the traceback, has a stable and portable output, and is now
+	used for streaming.
+
+2014-07-30  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* exp_aggr.adb (Expand_Array_Aggregate): Add missing test
+	on the target of the assignment to find out whether it
+	can be directly done by the back-end.
+	* exp_util.adb (Is_Possibly_Unaligned_Slice): Remove obscure test.
+
 2014-07-30  Robert Dewar  <dewar@adacore.com>
 
 	* inline.adb, a-coorse.adb, a-coorse.ads, a-cohase.adb, a-cohase.ads,

gcc/ada/a-cborse.adb

@@ -482,6 +482,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is
          raise Program_Error with "Position cursor designates wrong set";
       end if;
 
+      if Container.Busy > 0 then
+         raise Program_Error with
+           "attempt to tamper with cursors (set is busy)";
+      end if;
+
       pragma Assert (Vet (Container, Position.Node),
                      "bad cursor in Delete");
 
@@ -496,7 +501,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
 
    begin
       if X = 0 then
-         raise Constraint_Error with "attempt to delete element not in set";
+         raise Program_Error with "attempt to delete element not in set";
       end if;
 
       Tree_Operations.Delete_Node_Sans_Free (Container, X);
@@ -734,6 +739,23 @@ package body Ada.Containers.Bounded_Ordered_Sets is
            Is_Less_Key_Node    => Is_Less_Key_Node,
            Is_Greater_Key_Node => Is_Greater_Key_Node);
 
+      ------------
+      -- Adjust --
+      ------------
+
+      procedure Adjust (Control : in out Reference_Control_Type) is
+      begin
+         if Control.Container /= null then
+            declare
+               B : Natural renames Control.Container.Busy;
+               L : Natural renames Control.Container.Lock;
+            begin
+               B := B + 1;
+               L := L + 1;
+            end;
+         end if;
+      end Adjust;
+
       -------------
       -- Ceiling --
       -------------
@@ -842,6 +864,30 @@ package body Ada.Containers.Bounded_Ordered_Sets is
          end if;
       end Exclude;
 
+      --------------
+      -- Finalize --
+      --------------
+
+      procedure Finalize (Control : in out Reference_Control_Type) is
+      begin
+         if Control.Container /= null then
+            declare
+               B : Natural renames Control.Container.Busy;
+               L : Natural renames Control.Container.Lock;
+            begin
+               B := B - 1;
+               L := L - 1;
+            end;
+
+            if not (Key (Control.Pos) = Control.Old_Key.all) then
+               Delete (Control.Container.all, Key (Control.Pos));
+               raise Program_Error;
+            end if;
+
+            Control.Container := null;
+         end if;
+      end Finalize;
+
       ----------
       -- Find --
       ----------
@@ -939,15 +985,24 @@ package body Ada.Containers.Bounded_Ordered_Sets is
            (Vet (Container, Position.Node),
             "bad cursor in function Reference_Preserving_Key");
 
-         --  Some form of finalization will be required in order to actually
-         --  check that the key-part of the element designated by Position has
-         --  not changed.  ???
-
          declare
             N : Node_Type renames Container.Nodes (Position.Node);
+            B : Natural renames Container.Busy;
+            L : Natural renames Container.Lock;
          begin
-            return (Element => N.Element'Access);
+            return R : constant Reference_Type :=
+                (Element  => N.Element'Access,
+                 Control =>
+                    (Controlled with
+                      Container => Container'Access,
+                      Pos       => Position,
+                      Old_Key   => new Key_Type'(Key (Position))))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
          end;
+
       end Reference_Preserving_Key;
 
       function Reference_Preserving_Key
@@ -963,8 +1018,21 @@ package body Ada.Containers.Bounded_Ordered_Sets is
 
          declare
             N : Node_Type renames Container.Nodes (Node);
+            B : Natural renames Container.Busy;
+            L : Natural renames Container.Lock;
          begin
-            return (Element => N.Element'Access);
+            return R : constant Reference_Type :=
+                (Element  => N.Element'Access,
+                 Control =>
+                    (Controlled with
+                      Container => Container'Access,
+                       Pos      => Find (Container, Key),
+                       Old_Key  => new Key_Type'(Key)))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+
          end;
       end Reference_Preserving_Key;
 
@@ -1181,6 +1249,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is
    --  Start of processing for Insert_Sans_Hint
 
    begin
+      if Container.Busy > 0 then
+         raise Program_Error with
+           "attemot to tamper with cursors (set is busy)";
+      end if;
+
       Conditional_Insert_Sans_Hint
         (Container,
          New_Item,

gcc/ada/a-cborse.ads

@@ -277,11 +277,33 @@ package Ada.Containers.Bounded_Ordered_Sets is
          Key       : Key_Type) return Reference_Type;
 
    private
-      type Reference_Type (Element : not null access Element_Type) is
-        null record;
+      type Set_Access is access all Set;
+      for Set_Access'Storage_Size use 0;
+
+      type Key_Access is access all Key_Type;
 
       use Ada.Streams;
 
+      type Reference_Control_Type is
+        new Ada.Finalization.Controlled with
+      record
+         Container : Set_Access;
+         Pos       : Cursor;
+         Old_Key   : Key_Access;
+      end record;
+
+      overriding procedure
+         Adjust (Control : in out Reference_Control_Type);
+      pragma Inline (Adjust);
+
+      overriding procedure
+         Finalize (Control : in out Reference_Control_Type);
+      pragma Inline (Finalize);
+
+      type Reference_Type (Element : not null access Element_Type) is record
+         Control  : Reference_Control_Type;
+      end record;
+
       procedure Read
         (Stream : not null access Root_Stream_Type'Class;
          Item   : out Reference_Type);

gcc/ada/a-chtgop.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2014, 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- --
@@ -195,6 +195,51 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
       end loop;
    end Clear;
 
+   --------------------------
+   -- Delete_Node_At_Index --
+   --------------------------
+
+   procedure Delete_Node_At_Index
+     (HT   : in out Hash_Table_Type;
+      Indx : Hash_Type;
+      X    : in out Node_Access)
+   is
+      Prev : Node_Access;
+      Curr : Node_Access;
+
+   begin
+      Prev := HT.Buckets (Indx);
+      if Prev = X then
+         HT.Buckets (Indx) := Next (Prev);
+         HT.Length := HT.Length - 1;
+         Free (X);
+         return;
+      end if;
+
+      if HT.Length = 1 then
+         raise Program_Error with
+           "attempt to delete node not in its proper hash bucket";
+      end if;
+
+      loop
+         Curr := Next (Prev);
+
+         if Curr = null then
+            raise Program_Error with
+              "attempt to delete node not in its proper hash bucket";
+         end if;
+
+         if Curr = X then
+            Set_Next (Node => Prev, Next => Next (Curr));
+            HT.Length := HT.Length - 1;
+            Free (X);
+            return;
+         end if;
+         Prev := Curr;
+      end loop;
+
+   end Delete_Node_At_Index
+;
    ---------------------------
    -- Delete_Node_Sans_Free --
    ---------------------------

gcc/ada/a-chtgop.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2014, 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- --
@@ -128,6 +128,16 @@ package Ada.Containers.Hash_Tables.Generic_Operations is
    --  rehashed onto the new buckets array, and the old buckets array is
    --  deallocated. Program_Error is raised if the hash table is busy.
 
+   procedure Delete_Node_At_Index
+     (HT    : in out Hash_Table_Type;
+      Indx  : Hash_Type;
+      X     : in out Node_Access);
+
+   --  Delete a node whose bucket position is known. Used to remove a node
+   --  whose element has been modified through a key_preserving reference.
+   --  We cannot use the value of the element precisely because the current
+   --  value does not correspond to the hash code that determines the bucket.
+
    procedure Delete_Node_Sans_Free
      (HT : in out Hash_Table_Type;
       X  : Node_Access);

gcc/ada/a-cihase.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2014, 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- --
@@ -2139,6 +2139,24 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
            Hash      => Hash,
            Equivalent_Keys => Equivalent_Key_Node);
 
+      ------------
+      -- Adjust --
+      ------------
+
+      procedure Adjust (Control : in out Reference_Control_Type) is
+      begin
+         if Control.Container /= null then
+            declare
+               HT : Hash_Table_Type renames Control.Container.HT;
+               B : Natural renames HT.Busy;
+               L : Natural renames HT.Lock;
+            begin
+               B := B + 1;
+               L := L + 1;
+            end;
+         end if;
+      end Adjust;
+
       ------------------------
       -- Constant_Reference --
       ------------------------
@@ -2249,6 +2267,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
          Free (X);
       end Exclude;
 
+      --------------
+      -- Finalize --
+      --------------
+
+      procedure Finalize (Control : in out Reference_Control_Type) is
+      begin
+         if Control.Container /= null then
+            declare
+               HT   : Hash_Table_Type renames Control.Container.HT;
+               B : Natural renames HT.Busy;
+               L : Natural renames HT.Lock;
+            begin
+               B := B - 1;
+               L := L - 1;
+            end;
+
+            if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then
+               HT_Ops.Delete_Node_At_Index
+                 (Control.Container.HT, Control.Index,  Control.Old_Pos.Node);
+               raise Program_Error;
+            end if;
+
+            Control.Container := null;
+         end if;
+      end Finalize;
+
       ----------
       -- Find --
       ----------
@@ -2322,11 +2366,25 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
            (Vet (Position),
             "bad cursor in function Reference_Preserving_Key");
 
-         --  Some form of finalization will be required in order to actually
-         --  check that the key-part of the element designated by Position has
-         --  not changed.  ???
+         declare
+            HT : Hash_Table_Type renames Container.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
 
-         return (Element => Position.Node.Element.all'Access);
+         begin
+            return R : constant Reference_Type :=
+              (Element  => Position.Node.Element.all'Access,
+                 Control =>
+                   (Controlled with
+                     Container => Container'Access,
+                     Index     => HT_Ops.Index (HT, Position.Node),
+                     Old_Pos   => Position,
+                     Old_Hash  => Hash (Key (Position))))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end Reference_Preserving_Key;
 
       function Reference_Preserving_Key
@@ -2345,11 +2403,26 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
             raise Program_Error with "Node has no element";
          end if;
 
-         --  Some form of finalization will be required in order to actually
-         --  check that the key-part of the element designated by Key has not
-         --  changed.  ???
+         declare
+            HT : Hash_Table_Type renames Container.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+            P : constant Cursor := Find (Container, Key);
 
-         return (Element => Node.Element.all'Access);
+         begin
+            return R : constant Reference_Type :=
+              (Element  => Node.Element.all'Access,
+                 Control =>
+                   (Controlled with
+                     Container => Container'Access,
+                     Index  => HT_Ops.Index (HT, P.Node),
+                     Old_Pos => P,
+                     Old_Hash => Hash (Key)))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end Reference_Preserving_Key;
 
       -------------

gcc/ada/a-cihase.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -430,8 +430,29 @@ package Ada.Containers.Indefinite_Hashed_Sets is
          Key       : Key_Type) return Reference_Type;
 
    private
-      type Reference_Type (Element : not null access Element_Type)
-         is null record;
+      type Set_Access is access all Set;
+      for Set_Access'Storage_Size use 0;
+
+      type Reference_Control_Type is
+        new Ada.Finalization.Controlled with
+      record
+         Container : Set_Access;
+         Index     : Hash_Type;
+         Old_Pos   : Cursor;
+         Old_Hash  : Hash_Type;
+      end record;
+
+      overriding procedure
+         Adjust (Control : in out Reference_Control_Type);
+      pragma Inline (Adjust);
+
+      overriding procedure
+         Finalize (Control : in out Reference_Control_Type);
+      pragma Inline (Finalize);
+
+      type Reference_Type (Element : not null access Element_Type) is record
+         Control  : Reference_Control_Type;
+      end record;
 
       use Ada.Streams;
 

gcc/ada/a-cohase.adb

@@ -132,15 +132,6 @@ package body Ada.Containers.Hashed_Sets is
    procedure Write_Nodes is
       new HT_Ops.Generic_Write (Write_Node);
 
-   procedure Delete_Node
-     (C    : in out Set;
-      Indx : Hash_Type;
-      X    : in out Node_Access);
-   --  Delete a node whose bucket position is known. Used to remove a node
-   --  whose element has been modified through a key_preserving reference.
-   --  We cannot use the value of the element precisely because the current
-   --  value does not correspond to the hash code that determines the bucket.
-
    ---------
    -- "=" --
    ---------
@@ -337,48 +328,6 @@ package body Ada.Containers.Hashed_Sets is
       Position.Container := null;
    end Delete;
 
-   procedure Delete_Node
-     (C    : in out Set;
-      Indx : Hash_Type;
-      X    : in out Node_Access)
-   is
-      HT   : Hash_Table_Type renames C.HT;
-      Prev : Node_Access;
-      Curr : Node_Access;
-
-   begin
-      Prev := HT.Buckets (Indx);
-      if Prev = X then
-         HT.Buckets (Indx) := Next (Prev);
-         HT.Length := HT.Length - 1;
-         Free (X);
-         return;
-      end if;
-
-      if HT.Length = 1 then
-         raise Program_Error with
-           "attempt to delete node not in its proper hash bucket";
-      end if;
-
-      loop
-         Curr := Next (Prev);
-
-         if Curr = null then
-            raise Program_Error with
-              "attempt to delete node not in its proper hash bucket";
-         end if;
-
-         if Curr = X then
-            Set_Next (Node => Prev, Next => Next (Curr));
-            HT.Length := HT.Length - 1;
-            Free (X);
-            return;
-         end if;
-         Prev := Curr;
-      end loop;
-
-   end Delete_Node;
-
    ----------------
    -- Difference --
    ----------------
@@ -2138,8 +2087,8 @@ package body Ada.Containers.Hashed_Sets is
 
             if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
             then
-               Delete_Node
-                 (Control.Container.all, Control.Index,  Control.Old_Pos.Node);
+               HT_Ops.Delete_Node_At_Index
+                (Control.Container.HT, Control.Index,  Control.Old_Pos.Node);
                raise Program_Error with "key not preserved in reference";
             end if;
 

gcc/ada/a-elchha.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2003-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2003-2014, 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- --
@@ -53,10 +53,11 @@ is
    pragma Import
      (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
 
-   procedure Append_Info_Exception_Information
+   procedure Append_Info_Untailored_Exception_Information
      (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural);
    pragma Import
-     (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
+     (Ada, Append_Info_Untailored_Exception_Information,
+      "__gnat_append_info_u_e_info");
 
    procedure To_Stderr (S : String);
    pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
@@ -129,7 +130,7 @@ begin
       To_Stderr ("Execution terminated by unhandled exception");
       To_Stderr (Nline);
 
-      Append_Info_Exception_Information (Except, Nobuf, Ptr);
+      Append_Info_Untailored_Exception_Information (Except, Nobuf, Ptr);
    end if;
 
    Unhandled_Terminate;

gcc/ada/a-except-2005.adb

@@ -138,12 +138,17 @@ package body Ada.Exceptions is
       --  to contain the indicated Id value and message. Message is a string
       --  which is generated as the exception message.
 
-      --------------------------------------
-      -- Exception information subprogram --
-      --------------------------------------
+      ---------------------------------------
+      -- Exception information subprograms --
+      ---------------------------------------
 
-      function Exception_Information (X : Exception_Occurrence) return String;
-      --  The format of the exception information is as follows:
+      function Untailored_Exception_Information
+        (X : Exception_Occurrence) return String;
+      --  This is used by Stream_Attributes.EO_To_String to convert an
+      --  Exception_Occurrence to a String for the stream attributes.
+      --  String_To_EO understands the format, as documented here.
+      --
+      --  The format of the string is as follows:
       --
       --    Exception_Name: <exception name> (as in Exception_Name)
       --    Message: <message> (only if Exception_Message is empty)
@@ -164,10 +169,6 @@ package body Ada.Exceptions is
       --  that an equivalent modification to the routine String_To_EO must be
       --  made to preserve proper functioning of the stream attributes.
 
-      ---------------------------------------
-      -- Exception backtracing subprograms --
-      ---------------------------------------
-
       --  What is automatically output when exception tracing is on is the
       --  usual exception information with the call chain backtrace possibly
       --  tailored by a backtrace decorator. Modifying Exception_Information
@@ -177,28 +178,23 @@ package body Ada.Exceptions is
       --  the possibly tailored output, which is equivalent if no decorator is
       --  currently set:
 
-      function Tailored_Exception_Information
-        (X : Exception_Occurrence) return String;
-      --  Exception information to be output in the case of automatic tracing
-      --  requested through GNAT.Exception_Traces.
+      function Exception_Information (X : Exception_Occurrence) return String;
+      --  This is the implementation of Ada.Exceptions.Exception_Information,
+      --  as defined in the Ada RM.
       --
-      --  This is the same as Exception_Information if no backtrace decorator
-      --  is currently in place. Otherwise, this is Exception_Information with
-      --  the call chain raw addresses replaced by the result of a call to the
-      --  current decorator provided with the call chain addresses.
-
-      pragma Export
-        (Ada, Tailored_Exception_Information,
-           "__gnat_tailored_exception_information");
-      --  This is currently used by System.Tasking.Stages
+      --  If no traceback decorator (see GNAT.Exception_Traces) is currently
+      --  in place, this is the same as Untailored_Exception_Information.
+      --  Otherwise, the decorator is used to produce a symbolic traceback
+      --  instead of hexadecimal addresses.
+      --
+      --  Note that unlike Untailored_Exception_Information, there is no need
+      --  to keep the output of Exception_Information stable for streaming
+      --  purposes, and in fact the output differs across platforms.
 
    end Exception_Data;
 
    package Exception_Traces is
 
-      use Exception_Data;
-      --  Imports Tailored_Exception_Information
-
       ----------------------------------------------
       -- Run-Time Exception Notification Routines --
       ----------------------------------------------
@@ -737,8 +733,8 @@ package body Ada.Exceptions is
    -- EO_To_String --
    ------------------
 
-   --  We use the null string to represent the null occurrence, otherwise
-   --  we output the Exception_Information string for the occurrence.
+   --  We use the null string to represent the null occurrence, otherwise we
+   --  output the Untailored_Exception_Information string for the occurrence.
 
    function EO_To_String (X : Exception_Occurrence) return String
      renames Stream_Attributes.EO_To_String;

gcc/ada/a-except.adb

@@ -116,12 +116,17 @@ package body Ada.Exceptions is
       --  message. Message is a string which is generated as the exception
       --  message.
 
-      --------------------------------------
-      -- Exception information subprogram --
-      --------------------------------------
+      ---------------------------------------
+      -- Exception information subprograms --
+      ---------------------------------------
 
-      function Exception_Information (X : Exception_Occurrence) return String;
-      --  The format of the exception information is as follows:
+      function Untailored_Exception_Information
+        (X : Exception_Occurrence) return String;
+      --  This is used by Stream_Attributes.EO_To_String to convert an
+      --  Exception_Occurrence to a String for the stream attributes.
+      --  String_To_EO understands the format, as documented here.
+      --
+      --  The format of the string is as follows:
       --
       --    Exception_Name: <exception name> (as in Exception_Name)
       --    Message: <message> (only if Exception_Message is empty)
@@ -129,25 +134,19 @@ package body Ada.Exceptions is
       --    Call stack traceback locations:  (only if at least one location)
       --    <0xyyyyyyyy 0xyyyyyyyy ...>      (is recorded)
       --
-      --  The lines are separated by a ASCII.LF character
-      --
-      --  The nnnn is the partition Id given as decimal digits
-      --
+      --  The lines are separated by a ASCII.LF character.
+      --  The nnnn is the partition Id given as decimal digits.
       --  The 0x... line represents traceback program counter locations, in
       --  execution order with the first one being the exception location. It
       --  is present only
       --
-      --  The Exception_Name and Message lines are omitted in the abort signal
-      --  case, since this is not really an exception.
+      --  The Exception_Name and Message lines are omitted in the abort
+      --  signal case, since this is not really an exception.
 
       --  Note: If the format of the generated string is changed, please note
       --  that an equivalent modification to the routine String_To_EO must be
       --  made to preserve proper functioning of the stream attributes.
 
-      ---------------------------------------
-      -- Exception backtracing subprograms --
-      ---------------------------------------
-
       --  What is automatically output when exception tracing is on is the
       --  usual exception information with the call chain backtrace possibly
       --  tailored by a backtrace decorator. Modifying Exception_Information
@@ -157,28 +156,23 @@ package body Ada.Exceptions is
       --  the possibly tailored output, which is equivalent if no decorator is
       --  currently set:
 
-      function Tailored_Exception_Information
-        (X : Exception_Occurrence) return String;
-      --  Exception information to be output in the case of automatic tracing
-      --  requested through GNAT.Exception_Traces.
+      function Exception_Information (X : Exception_Occurrence) return String;
+      --  This is the implementation of Ada.Exceptions.Exception_Information,
+      --  as defined in the Ada RM.
       --
-      --  This is the same as Exception_Information if no backtrace decorator
-      --  is currently in place. Otherwise, this is Exception_Information with
-      --  the call chain raw addresses replaced by the result of a call to the
-      --  current decorator provided with the call chain addresses.
-
-      pragma Export
-        (Ada, Tailored_Exception_Information,
-           "__gnat_tailored_exception_information");
-      --  This is currently used by System.Tasking.Stages
+      --  If no traceback decorator (see GNAT.Exception_Traces) is currently
+      --  in place, this is the same as Untailored_Exception_Information.
+      --  Otherwise, the decorator is used to produce a symbolic traceback
+      --  instead of hexadecimal addresses.
+      --
+      --  Note that unlike Untailored_Exception_Information, there is no need
+      --  to keep the output of Exception_Information stable for streaming
+      --  purposes, and in fact the output differs across platforms.
 
    end Exception_Data;
 
    package Exception_Traces is
 
-      use Exception_Data;
-      --  Imports Tailored_Exception_Information
-
       ----------------------------------------------
       -- Run-Time Exception Notification Routines --
       ----------------------------------------------
@@ -774,7 +768,7 @@ package body Ada.Exceptions is
    ------------------
 
    --  We use the null string to represent the null occurrence, otherwise we
-   --  output the Exception_Information string for the occurrence.
+   --  output the Untailored_Exception_Information string for the occurrence.
 
    function EO_To_String (X : Exception_Occurrence) return String
      renames Stream_Attributes.EO_To_String;
@@ -806,9 +800,9 @@ package body Ada.Exceptions is
    begin
       if X.Id = Null_Id then
          raise Constraint_Error;
+      else
+         return Exception_Data.Exception_Information (X);
       end if;
-
-      return Exception_Data.Exception_Information (X);
    end Exception_Information;
 
    -----------------------

gcc/ada/a-exexda.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, 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- --
@@ -36,39 +36,40 @@ package body Exception_Data is
 
    --  This unit implements the Exception_Information related services for
    --  both the Ada standard requirements and the GNAT.Exception_Traces
-   --  facility.
+   --  facility. This is also used by the implementation of the stream
+   --  attributes of types Exception_Id and Exception_Occurrence.
 
    --  There are common parts between the contents of Exception_Information
-   --  (the regular Ada interface) and Tailored_Exception_Information (what
-   --  the automatic backtracing output includes). The overall structure is
-   --  sketched below:
+   --  (the regular Ada interface) and Untailored_Exception_Information (used
+   --  for streaming, and when there is no symbolic traceback available) The
+   --  overall structure is sketched below:
 
    --
-   --                      Exception_Information
+   --                 Untailored_Exception_Information
    --                               |
    --                       +-------+--------+
    --                       |                |
-   --                Basic_Exc_Info & Basic_Exc_Tback
-   --                    (B_E_I)          (B_E_TB)
+   --                Basic_Exc_Info & Untailored_Exc_Tback
+   --                    (B_E_I)         (U_E_TB)
 
    --           o--
    --  (B_E_I)  |  Exception_Name: <exception name> (as in Exception_Name)
    --           |  Message: <message> (or a null line if no message)
    --           |  PID=nnnn (if != 0)
    --           o--
-   --  (B_E_TB) |  Call stack traceback locations:
+   --  (U_E_TB) |  Call stack traceback locations:
    --           |  <0xyyyyyyyy 0xyyyyyyyy ...>
    --           o--
 
-   --                  Tailored_Exception_Information
+   --                     Exception_Information
    --                               |
    --                    +----------+----------+
    --                    |                     |
-   --             Basic_Exc_Info    &  Tailored_Exc_Tback
+   --             Basic_Exc_Info    &      traceback
    --                                          |
    --                              +-----------+------------+
    --                              |                        |
-   --                       Basic_Exc_Tback    Or    Tback_Decorator
+   --                     Untailored_Exc_Tback    Or    Tback_Decorator
    --                     if no decorator set           otherwise
 
    --  Functions returning String imply secondary stack use, which is a heavy
@@ -81,8 +82,8 @@ package body Exception_Data is
 
    --  The procedural interface is composed of two major sections: a neutral
    --  section for basic types like Address, Character, Natural or String, and
-   --  an exception oriented section for the e.g. Basic_Exception_Information.
-   --  This is the Append_Info family of procedures below.
+   --  an exception oriented section for the exception names, messages, and
+   --  information. This is the Append_Info family of procedures below.
 
    --  Output to stderr is commanded by passing an empty buffer to update, and
    --  care is taken not to overflow otherwise.
@@ -140,12 +141,12 @@ package body Exception_Data is
       Info : in out String;
       Ptr  : in out Natural);
 
-   procedure Append_Info_Basic_Exception_Traceback
+   procedure Append_Info_Untailored_Exception_Traceback
      (X    : Exception_Occurrence;
       Info : in out String;
       Ptr  : in out Natural);
 
-   procedure Append_Info_Exception_Information
+   procedure Append_Info_Untailored_Exception_Information
      (X    : Exception_Occurrence;
       Info : in out String;
       Ptr  : in out Natural);
@@ -162,7 +163,7 @@ package body Exception_Data is
    function Basic_Exception_Info_Maxlength
      (X : Exception_Occurrence) return Natural;
 
-   function Basic_Exception_Tback_Maxlength
+   function Untailored_Exception_Traceback_Maxlength
      (X : Exception_Occurrence) return Natural;
 
    function Exception_Info_Maxlength
@@ -181,11 +182,11 @@ package body Exception_Data is
    -- Functional Interface --
    --------------------------
 
-   function Basic_Exception_Traceback
+   function Untailored_Exception_Traceback
      (X : Exception_Occurrence) return String;
    --  Returns an image of the complete call chain associated with an
    --  exception occurrence in its most basic form, that is as a raw sequence
-   --  of hexadecimal binary addresses.
+   --  of hexadecimal addresses.
 
    function Tailored_Exception_Traceback
      (X : Exception_Occurrence) return String;
@@ -201,7 +202,8 @@ package body Exception_Data is
      (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
 
    pragma Export
-     (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
+     (Ada, Append_Info_Untailored_Exception_Information,
+      "__gnat_append_info_u_e_info");
 
    pragma Export
      (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
@@ -375,16 +377,16 @@ package body Exception_Data is
         + BEI_PID_Header'Length + 15;
    end Basic_Exception_Info_Maxlength;
 
-   -------------------------------------------
-   -- Append_Info_Basic_Exception_Traceback --
-   -------------------------------------------
+   ------------------------------------------------
+   -- Append_Info_Untailored_Exception_Traceback --
+   ------------------------------------------------
 
    --  As for Basic_Exception_Information:
 
    BETB_Header : constant String := "Call stack traceback locations:";
    LDAD_Header : constant String := "Load address: ";
 
-   procedure Append_Info_Basic_Exception_Traceback
+   procedure Append_Info_Untailored_Exception_Traceback
      (X    : Exception_Occurrence;
       Info : in out String;
       Ptr  : in out Natural)
@@ -417,13 +419,13 @@ package body Exception_Data is
       end loop;
 
       Append_Info_NL (Info, Ptr);
-   end Append_Info_Basic_Exception_Traceback;
+   end Append_Info_Untailored_Exception_Traceback;
 
-   -----------------------------------------
-   -- Basic_Exception_Traceback_Maxlength --
-   -----------------------------------------
+   ----------------------------------------------
+   -- Untailored_Exception_Traceback_Maxlength --
+   ----------------------------------------------
 
-   function Basic_Exception_Tback_Maxlength
+   function Untailored_Exception_Traceback_Maxlength
      (X : Exception_Occurrence) return Natural
    is
       Space_Per_Address : constant := 2 + 16 + 1;
@@ -432,21 +434,21 @@ package body Exception_Data is
       return
         LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
           X.Num_Tracebacks * Space_Per_Address + 1;
-   end Basic_Exception_Tback_Maxlength;
+   end Untailored_Exception_Traceback_Maxlength;
 
-   ---------------------------------------
-   -- Append_Info_Exception_Information --
-   ---------------------------------------
+   --------------------------------------------------
+   -- Append_Info_Untailored_Exception_Information --
+   --------------------------------------------------
 
-   procedure Append_Info_Exception_Information
+   procedure Append_Info_Untailored_Exception_Information
      (X    : Exception_Occurrence;
       Info : in out String;
       Ptr  : in out Natural)
    is
    begin
       Append_Info_Basic_Exception_Information (X, Info, Ptr);
-      Append_Info_Basic_Exception_Traceback   (X, Info, Ptr);
-   end Append_Info_Exception_Information;
+      Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
+   end Append_Info_Untailored_Exception_Information;
 
    ------------------------------
    -- Exception_Info_Maxlength --
@@ -458,7 +460,7 @@ package body Exception_Data is
    begin
       return
         Basic_Exception_Info_Maxlength (X)
-        + Basic_Exception_Tback_Maxlength (X);
+        + Untailored_Exception_Traceback_Maxlength (X);
    end Exception_Info_Maxlength;
 
    -----------------------------------
@@ -546,32 +548,33 @@ package body Exception_Data is
    end Exception_Message_Length;
 
    -------------------------------
-   -- Basic_Exception_Traceback --
+   -- Untailored_Exception_Traceback --
    -------------------------------
 
-   function Basic_Exception_Traceback
+   function Untailored_Exception_Traceback
      (X : Exception_Occurrence) return String
    is
-      Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X));
+      Info : aliased String
+                       (1 .. Untailored_Exception_Traceback_Maxlength (X));
       Ptr  : Natural := Info'First - 1;
    begin
-      Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
+      Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
       return Info (Info'First .. Ptr);
-   end Basic_Exception_Traceback;
+   end Untailored_Exception_Traceback;
 
-   ---------------------------
-   -- Exception_Information --
-   ---------------------------
+   --------------------------------------
+   -- Untailored_Exception_Information --
+   --------------------------------------
 
-   function Exception_Information
+   function Untailored_Exception_Information
      (X : Exception_Occurrence) return String
    is
       Info : String (1 .. Exception_Info_Maxlength (X));
       Ptr  : Natural := Info'First - 1;
    begin
-      Append_Info_Exception_Information (X, Info, Ptr);
+      Append_Info_Untailored_Exception_Information (X, Info, Ptr);
       return Info (Info'First .. Ptr);
-   end Exception_Information;
+   end Untailored_Exception_Information;
 
    -------------------------
    -- Set_Exception_C_Msg --
@@ -713,17 +716,17 @@ package body Exception_Data is
 
    begin
       if Wrapper = null then
-         return Basic_Exception_Traceback (X);
+         return Untailored_Exception_Traceback (X);
       else
          return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
       end if;
    end Tailored_Exception_Traceback;
 
-   ------------------------------------
-   -- Tailored_Exception_Information --
-   ------------------------------------
+   ---------------------------
+   -- Exception_Information --
+   ---------------------------
 
-   function Tailored_Exception_Information
+   function Exception_Information
      (X : Exception_Occurrence) return String
    is
       --  The tailored exception information is the basic information
@@ -739,6 +742,6 @@ package body Exception_Data is
       Append_Info_Basic_Exception_Information (X, Info, Ptr);
       Append_Info_String (Tback_Info, Info, Ptr);
       return Info (Info'First .. Ptr);
-   end Tailored_Exception_Information;
+   end Exception_Information;
 
 end Exception_Data;

gcc/ada/a-exextr.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, 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- --
@@ -99,7 +99,7 @@ package body Exception_Traces is
 
          To_Stderr ("Exception raised");
          To_Stderr (Nline);
-         To_Stderr (Tailored_Exception_Information (Excep.all));
+         To_Stderr (Exception_Information (Excep.all));
          Unlock_Task.all;
       end if;
 

gcc/ada/a-exstat.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, 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- --
@@ -59,15 +59,15 @@ package body Stream_Attributes is
    -- EO_To_String --
    ------------------
 
-   --  We use the null string to represent the null occurrence, otherwise
-   --  we output the Exception_Information string for the occurrence.
+   --  We use the null string to represent the null occurrence, otherwise we
+   --  output the Untailored_Exception_Information string for the occurrence.
 
    function EO_To_String (X : Exception_Occurrence) return String is
    begin
       if X.Id = Null_Id then
          return "";
       else
-         return Exception_Information (X);
+         return Exception_Data.Untailored_Exception_Information (X);
       end if;
    end EO_To_String;
 

gcc/ada/checks.adb

@@ -61,7 +61,6 @@ with Stringt;  use Stringt;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Ttypes;   use Ttypes;
-with Urealp;   use Urealp;
 with Validsw;  use Validsw;
 
 package body Checks is
@@ -4076,18 +4075,20 @@ package body Checks is
    type Cache_Index is range 0 .. Cache_Size - 1;
    --  Determine size of below cache (power of 2 is more efficient)
 
-   Determine_Range_Cache_N  : array (Cache_Index) of Node_Id;
-   Determine_Range_Cache_V  : array (Cache_Index) of Boolean;
-   Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
-   Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
+   Determine_Range_Cache_N    : array (Cache_Index) of Node_Id;
+   Determine_Range_Cache_V    : array (Cache_Index) of Boolean;
+   Determine_Range_Cache_Lo   : array (Cache_Index) of Uint;
+   Determine_Range_Cache_Hi   : array (Cache_Index) of Uint;
+   Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal;
+   Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal;
    --  The above arrays are used to implement a small direct cache for
-   --  Determine_Range calls. Because of the way Determine_Range recursively
-   --  traces subexpressions, and because overflow checking calls the routine
-   --  on the way up the tree, a quadratic behavior can otherwise be
-   --  encountered in large expressions. The cache entry for node N is stored
-   --  in the (N mod Cache_Size) entry, and can be validated by checking the
-   --  actual node value stored there. The Range_Cache_V array records the
-   --  setting of Assume_Valid for the cache entry.
+   --  Determine_Range and Determine_Range_R calls. Because of the way these
+   --  subprograms recursively traces subexpressions, and because overflow
+   --  checking calls the routine on the way up the tree, a quadratic behavior
+   --  can otherwise be encountered in large expressions. The cache entry for
+   --  node N is stored in the (N mod Cache_Size) entry, and can be validated
+   --  by checking the actual node value stored there. The Range_Cache_V array
+   --  records the setting of Assume_Valid for the cache entry.
 
    procedure Determine_Range
      (N            : Node_Id;
@@ -4544,7 +4545,7 @@ package body Checks is
       if OK1 then
 
          --  If the refined value of the low bound is greater than the type
-         --  high bound, then reset it to the more restrictive value. However,
+         --  low bound, then reset it to the more restrictive value. However,
          --  we do NOT do this for the case of a modular type where the
          --  possible upper bound on the value is above the base type high
          --  bound, because that means the result could wrap.
@@ -4596,6 +4597,427 @@ package body Checks is
          end if;
    end Determine_Range;
 
+   -----------------------
+   -- Determine_Range_R --
+   -----------------------
+
+   procedure Determine_Range_R
+     (N            : Node_Id;
+      OK           : out Boolean;
+      Lo           : out Ureal;
+      Hi           : out Ureal;
+      Assume_Valid : Boolean := False)
+   is
+      Typ : Entity_Id := Etype (N);
+      --  Type to use, may get reset to base type for possibly invalid entity
+
+      Lo_Left : Ureal;
+      Hi_Left : Ureal;
+      --  Lo and Hi bounds of left operand
+
+      Lo_Right : Ureal;
+      Hi_Right : Ureal;
+      --  Lo and Hi bounds of right (or only) operand
+
+      Bound : Node_Id;
+      --  Temp variable used to hold a bound node
+
+      Hbound : Ureal;
+      --  High bound of base type of expression
+
+      Lor : Ureal;
+      Hir : Ureal;
+      --  Refined values for low and high bounds, after tightening
+
+      OK1 : Boolean;
+      --  Used in lower level calls to indicate if call succeeded
+
+      Cindex : Cache_Index;
+      --  Used to search cache
+
+      Btyp : Entity_Id;
+      --  Base type
+
+      function OK_Operands return Boolean;
+      --  Used for binary operators. Determines the ranges of the left and
+      --  right operands, and if they are both OK, returns True, and puts
+      --  the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
+
+      function Round_Machine (B : Ureal) return Ureal;
+      --  B is a real bound. Round it using mode Round_Even.
+
+      -----------------
+      -- OK_Operands --
+      -----------------
+
+      function OK_Operands return Boolean is
+      begin
+         Determine_Range_R
+           (Left_Opnd  (N), OK1, Lo_Left,  Hi_Left, Assume_Valid);
+
+         if not OK1 then
+            return False;
+         end if;
+
+         Determine_Range_R
+           (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
+         return OK1;
+      end OK_Operands;
+
+      -------------------
+      -- Round_Machine --
+      -------------------
+
+      function Round_Machine (B : Ureal) return Ureal is
+      begin
+         return Machine (Typ, B, Round_Even, N);
+      end Round_Machine;
+
+   --  Start of processing for Determine_Range_R
+
+   begin
+      --  Prevent junk warnings by initializing range variables
+
+      Lo  := No_Ureal;
+      Hi  := No_Ureal;
+      Lor := No_Ureal;
+      Hir := No_Ureal;
+
+      --  For temporary constants internally generated to remove side effects
+      --  we must use the corresponding expression to determine the range of
+      --  the expression. But note that the expander can also generate
+      --  constants in other cases, including deferred constants.
+
+      if Is_Entity_Name (N)
+        and then Nkind (Parent (Entity (N))) = N_Object_Declaration
+        and then Ekind (Entity (N)) = E_Constant
+        and then Is_Internal_Name (Chars (Entity (N)))
+      then
+         if Present (Expression (Parent (Entity (N)))) then
+            Determine_Range_R
+              (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
+
+         elsif Present (Full_View (Entity (N))) then
+            Determine_Range_R
+              (Expression (Parent (Full_View (Entity (N)))),
+               OK, Lo, Hi, Assume_Valid);
+
+         else
+            OK := False;
+         end if;
+         return;
+      end if;
+
+      --  If type is not defined, we can't determine its range
+
+      if No (Typ)
+
+        --  We don't deal with anything except IEEE floating-point types
+
+        or else not Is_Floating_Point_Type (Typ)
+        or else Float_Rep (Typ) /= IEEE_Binary
+
+        --  Ignore type for which an error has been posted, since range in
+        --  this case may well be a bogosity deriving from the error. Also
+        --  ignore if error posted on the reference node.
+
+        or else Error_Posted (N) or else Error_Posted (Typ)
+      then
+         OK := False;
+         return;
+      end if;
+
+      --  For all other cases, we can determine the range
+
+      OK := True;
+
+      --  If value is compile time known, then the possible range is the one
+      --  value that we know this expression definitely has.
+
+      if Compile_Time_Known_Value (N) then
+         Lo := Expr_Value_R (N);
+         Hi := Lo;
+         return;
+      end if;
+
+      --  Return if already in the cache
+
+      Cindex := Cache_Index (N mod Cache_Size);
+
+      if Determine_Range_Cache_N (Cindex) = N
+           and then
+         Determine_Range_Cache_V (Cindex) = Assume_Valid
+      then
+         Lo := Determine_Range_Cache_Lo_R (Cindex);
+         Hi := Determine_Range_Cache_Hi_R (Cindex);
+         return;
+      end if;
+
+      --  Otherwise, start by finding the bounds of the type of the expression,
+      --  the value cannot be outside this range (if it is, then we have an
+      --  overflow situation, which is a separate check, we are talking here
+      --  only about the expression value).
+
+      --  First a check, never try to find the bounds of a generic type, since
+      --  these bounds are always junk values, and it is only valid to look at
+      --  the bounds in an instance.
+
+      if Is_Generic_Type (Typ) then
+         OK := False;
+         return;
+      end if;
+
+      --  First step, change to use base type unless we know the value is valid
+
+      if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
+        or else Assume_No_Invalid_Values
+        or else Assume_Valid
+      then
+         null;
+      else
+         Typ := Underlying_Type (Base_Type (Typ));
+      end if;
+
+      --  Retrieve the base type. Handle the case where the base type is a
+      --  private type.
+
+      Btyp := Base_Type (Typ);
+
+      if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
+         Btyp := Full_View (Btyp);
+      end if;
+
+      --  We use the actual bound unless it is dynamic, in which case use the
+      --  corresponding base type bound if possible. If we can't get a bound
+      --  then we figure we can't determine the range (a peculiar case, that
+      --  perhaps cannot happen, but there is no point in bombing in this
+      --  optimization circuit).
+
+      --  First the low bound
+
+      Bound := Type_Low_Bound (Typ);
+
+      if Compile_Time_Known_Value (Bound) then
+         Lo := Expr_Value_R (Bound);
+
+      elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
+         Lo := Expr_Value_R (Type_Low_Bound (Btyp));
+
+      else
+         OK := False;
+         return;
+      end if;
+
+      --  Now the high bound
+
+      Bound := Type_High_Bound (Typ);
+
+      --  We need the high bound of the base type later on, and this should
+      --  always be compile time known. Again, it is not clear that this
+      --  can ever be false, but no point in bombing.
+
+      if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
+         Hbound := Expr_Value_R (Type_High_Bound (Btyp));
+         Hi := Hbound;
+
+      else
+         OK := False;
+         return;
+      end if;
+
+      --  If we have a static subtype, then that may have a tighter bound so
+      --  use the upper bound of the subtype instead in this case.
+
+      if Compile_Time_Known_Value (Bound) then
+         Hi := Expr_Value_R (Bound);
+      end if;
+
+      --  We may be able to refine this value in certain situations. If any
+      --  refinement is possible, then Lor and Hir are set to possibly tighter
+      --  bounds, and OK1 is set to True.
+
+      case Nkind (N) is
+
+         --  For unary plus, result is limited by range of operand
+
+         when N_Op_Plus =>
+            Determine_Range_R
+              (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
+
+         --  For unary minus, determine range of operand, and negate it
+
+         when N_Op_Minus =>
+            Determine_Range_R
+              (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
+
+            if OK1 then
+               Lor := -Hi_Right;
+               Hir := -Lo_Right;
+            end if;
+
+         --  For binary addition, get range of each operand and do the
+         --  addition to get the result range.
+
+         when N_Op_Add =>
+            if OK_Operands then
+               Lor := Round_Machine (Lo_Left + Lo_Right);
+               Hir := Round_Machine (Hi_Left + Hi_Right);
+            end if;
+
+         --  For binary subtraction, get range of each operand and do the worst
+         --  case subtraction to get the result range.
+
+         when N_Op_Subtract =>
+            if OK_Operands then
+               Lor := Round_Machine (Lo_Left - Hi_Right);
+               Hir := Round_Machine (Hi_Left - Lo_Right);
+            end if;
+
+         --  For multiplication, get range of each operand and do the
+         --  four multiplications to get the result range.
+
+         when N_Op_Multiply =>
+            if OK_Operands then
+               declare
+                  M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right);
+                  M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right);
+                  M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right);
+                  M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right);
+               begin
+                  Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4));
+                  Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4));
+               end;
+            end if;
+
+         --  For division, consider separately the cases where the right
+         --  operand is positive or negative. Otherwise, the right operand
+         --  can be arbitrarily close to zero, so the result is likely to
+         --  be unbounded in one direction, do not attempt to compute it.
+
+         when N_Op_Divide =>
+            if OK_Operands then
+
+               --  Right operand is positive
+
+               if Lo_Right > Ureal_0 then
+
+                  --  If the low bound of the left operand is negative, obtain
+                  --  the overall low bound by dividing it by the smallest
+                  --  value of the right operand, and otherwise by the largest
+                  --  value of the right operand.
+
+                  if Lo_Left < Ureal_0 then
+                     Lor := Round_Machine (Lo_Left / Lo_Right);
+                  else
+                     Lor := Round_Machine (Lo_Left / Hi_Right);
+                  end if;
+
+                  --  If the high bound of the left operand is negative, obtain
+                  --  the overall high bound by dividing it by the largest
+                  --  value of the right operand, and otherwise by the
+                  --  smallest value of the right operand.
+
+                  if Hi_Left < Ureal_0 then
+                     Hir := Round_Machine (Hi_Left / Hi_Right);
+                  else
+                     Hir := Round_Machine (Hi_Left / Lo_Right);
+                  end if;
+
+               --  Right operand is negative
+
+               elsif Hi_Right < Ureal_0 then
+
+                  --  If the low bound of the left operand is negative, obtain
+                  --  the overall low bound by dividing it by the largest
+                  --  value of the right operand, and otherwise by the smallest
+                  --  value of the right operand.
+
+                  if Lo_Left < Ureal_0 then
+                     Lor := Round_Machine (Lo_Left / Hi_Right);
+                  else
+                     Lor := Round_Machine (Lo_Left / Lo_Right);
+                  end if;
+
+                  --  If the high bound of the left operand is negative, obtain
+                  --  the overall high bound by dividing it by the smallest
+                  --  value of the right operand, and otherwise by the
+                  --  largest value of the right operand.
+
+                  if Hi_Left < Ureal_0 then
+                     Hir := Round_Machine (Hi_Left / Lo_Right);
+                  else
+                     Hir := Round_Machine (Hi_Left / Hi_Right);
+                  end if;
+
+               else
+                  OK1 := False;
+               end if;
+            end if;
+
+         --  For type conversion from one floating-point type to another, we
+         --  can refine the range using the converted value.
+
+         when N_Type_Conversion =>
+            Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid);
+
+         --  Nothing special to do for all other expression kinds
+
+         when others =>
+            OK1 := False;
+            Lor := No_Ureal;
+            Hir := No_Ureal;
+      end case;
+
+      --  At this stage, if OK1 is true, then we know that the actual result of
+      --  the computed expression is in the range Lor .. Hir. We can use this
+      --  to restrict the possible range of results.
+
+      if OK1 then
+
+         --  If the refined value of the low bound is greater than the type
+         --  low bound, then reset it to the more restrictive value.
+
+         if Lor > Lo then
+            Lo := Lor;
+         end if;
+
+         --  Similarly, if the refined value of the high bound is less than the
+         --  value so far, then reset it to the more restrictive value.
+
+         if Hir < Hi then
+            Hi := Hir;
+         end if;
+      end if;
+
+      --  Set cache entry for future call and we are all done
+
+      Determine_Range_Cache_N    (Cindex) := N;
+      Determine_Range_Cache_V    (Cindex) := Assume_Valid;
+      Determine_Range_Cache_Lo_R (Cindex) := Lo;
+      Determine_Range_Cache_Hi_R (Cindex) := Hi;
+      return;
+
+   --  If any exception occurs, it means that we have some bug in the compiler,
+   --  possibly triggered by a previous error, or by some unforeseen peculiar
+   --  occurrence. However, this is only an optimization attempt, so there is
+   --  really no point in crashing the compiler. Instead we just decide, too
+   --  bad, we can't figure out a range in this case after all.
+
+   exception
+      when others =>
+
+         --  Debug flag K disables this behavior (useful for debugging)
+
+         if Debug_Flag_K then
+            raise;
+         else
+            OK := False;
+            Lo := No_Ureal;
+            Hi := No_Ureal;
+            return;
+         end if;
+   end Determine_Range_R;
+
    ------------------------------------
    -- Discriminant_Checks_Suppressed --
    ------------------------------------

gcc/ada/checks.ads

@@ -40,6 +40,7 @@ with Namet;  use Namet;
 with Table;
 with Types;  use Types;
 with Uintp;  use Uintp;
+with Urealp; use Urealp;
 
 package Checks is
 
@@ -302,6 +303,18 @@ package Checks is
    --  then this assumption is valid, if False, then processing is done using
    --  base types to allow invalid values.
 
+   procedure Determine_Range_R
+     (N            : Node_Id;
+      OK           : out Boolean;
+      Lo           : out Ureal;
+      Hi           : out Ureal;
+      Assume_Valid : Boolean := False);
+   --  Similar to Determine_Range, but for a node N of floating-point type. OK
+   --  is True on return only for IEEE floating-point types and only if we do
+   --  not have to worry about extended precision (i.e. on the x86, we must be
+   --  using -msse2 -mfpmath=sse. At the current time, this is used only in
+   --  GNATprove, though we could consider using it more generally in future.
+
    procedure Install_Null_Excluding_Check (N : Node_Id);
    --  Determines whether an access node requires a runtime access check and
    --  if so inserts the appropriate run-time check.

gcc/ada/exp_aggr.adb

@@ -5345,10 +5345,11 @@ package body Exp_Aggr is
          --  then we could go into an infinite recursion.
 
          if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
-           and then not AAMP_On_Target
            and then VM_Target = No_VM
+           and then not AAMP_On_Target
            and then not Generate_SCIL
            and then not Possible_Bit_Aligned_Component (Target)
+           and then not Is_Possibly_Unaligned_Slice (Target)
            and then Aggr_Assignment_OK_For_Backend (N)
          then
             if Maybe_In_Place_OK then

gcc/ada/exp_util.adb

@@ -5041,18 +5041,6 @@ package body Exp_Util is
          return False;
       end if;
 
-      --  Always assume the worst for a nested record component with a
-      --  component clause, which gigi/gcc does not appear to handle well.
-      --  It is not clear why this special test is needed at all ???
-
-      if Nkind (Prefix (N)) = N_Selected_Component
-        and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
-        and then
-          Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
-      then
-         return True;
-      end if;
-
       --  We only need to worry if the target has strict alignment
 
       if not Target_Strict_Alignment then

gcc/ada/s-tassta.adb

@@ -1524,12 +1524,6 @@ package body System.Tasking.Stages is
         Ada.Unchecked_Conversion
          (Task_Id, System.Task_Primitives.Task_Address);
 
-      function Tailored_Exception_Information
-        (E : Exception_Occurrence) return String;
-      pragma Import
-        (Ada, Tailored_Exception_Information,
-         "__gnat_tailored_exception_information");
-
       Excep : constant Exception_Occurrence_Access :=
                 SSL.Get_Current_Excep.all;
 
@@ -1553,7 +1547,7 @@ package body System.Tasking.Stages is
       To_Stderr (System.Address_Image (To_Address (Self_Id)));
       To_Stderr (" terminated by unhandled exception");
       To_Stderr ((1 => ASCII.LF));
-      To_Stderr (Tailored_Exception_Information (Excep.all));
+      To_Stderr (Exception_Information (Excep.all));
       Initialization.Task_Unlock (Self_Id);
    end Trace_Unhandled_Exception_In_Task;