[multiple changes]

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

	* a-coorse.adb, a-coorse.ads (Generic_Keys): Add a
	Reference_Control_Type to generic package, to keep additional
	information for Reference_Types that manipulate keys. Add Adjust and
	Finalize procedures for this type.
	(Finalize): When finalizing a reference_preserving_key, verify
	that the key of the new value is equivalent to the key of the
	original element, raise Program_Error otherwise.
	(Insert): Detect tampering.
	(Reference_Preserving_Key): Build proper Reference_Control_Type,
	and update Busy and Lock bits to detect tampering.
	* a-cohase.ads: Keep with-clause private.

2014-07-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_N_Op_Eq): Emit a warning when the operands
	of an equality are of an Unchecked_Union type and lack inferable
	discriminants.

From-SVN: r213277

5 files changed, 139 insertions, 14 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d216f82..fba9ada 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+2014-07-30  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-coorse.adb, a-coorse.ads (Generic_Keys): Add a
+	Reference_Control_Type to generic package, to keep additional
+	information for Reference_Types that manipulate keys. Add Adjust and
+	Finalize procedures for this type.
+	(Finalize): When finalizing a reference_preserving_key, verify
+	that the key of the new value is equivalent to the key of the
+	original element, raise Program_Error otherwise.
+	(Insert): Detect tampering.
+	(Reference_Preserving_Key): Build proper Reference_Control_Type,
+	and update Busy and Lock bits to detect tampering.
+	* a-cohase.ads: Keep with-clause private.
+
+2014-07-30  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch4.adb (Expand_N_Op_Eq): Emit a warning when the operands
+	of an equality are of an Unchecked_Union type and lack inferable
+	discriminants.
+
 2014-07-30  Bob Duff  <duff@adacore.com>
 
 	* g-exctra.adb, g-exctra.ads, s-exctra.adb, s-exctra.ads, Makefile.rtl,
diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads
index 9e40f0e..cfe048a 100644
--- a/gcc/ada/a-cohase.ads
+++ b/gcc/ada/a-cohase.ads
@@ -35,7 +35,7 @@ with Ada.Iterator_Interfaces;
 
 private with Ada.Containers.Hash_Tables;
 private with Ada.Streams;
-with Ada.Finalization;
+private with Ada.Finalization;
 
 generic
    type Element_Type is private;
diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb
index 675b40f..116305b 100644
--- a/gcc/ada/a-coorse.adb
+++ b/gcc/ada/a-coorse.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- --
@@ -690,6 +690,24 @@ package body Ada.Containers.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
+               Tree : Tree_Type renames Control.Container.Tree;
+               B : Natural renames Tree.Busy;
+               L : Natural renames Tree.Lock;
+            begin
+               B := B + 1;
+               L := L + 1;
+            end;
+         end if;
+      end Adjust;
+
       -------------
       -- Ceiling --
       -------------
@@ -793,6 +811,32 @@ package body Ada.Containers.Ordered_Sets is
          end if;
       end Exclude;
 
+      --------------
+      -- Finalize --
+      --------------
+
+      procedure Finalize (Control : in out Reference_Control_Type) is
+      begin
+         if Control.Container /= null then
+            declare
+               Tree : Tree_Type renames Control.Container.Tree;
+               B : Natural renames Tree.Busy;
+               L : Natural renames Tree.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;
+            Control.Old_Key   := null;
+         end if;
+      end Finalize;
+
       ----------
       -- Find --
       ----------
@@ -890,11 +934,24 @@ package body Ada.Containers.Ordered_Sets is
            (Vet (Container.Tree, 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
+            Tree : Tree_Type renames Container.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
 
-         return (Element => Position.Node.Element'Access);
+         begin
+            return R : constant Reference_Type :=
+              (Element  => Position.Node.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
@@ -908,11 +965,24 @@ package body Ada.Containers.Ordered_Sets is
             raise Constraint_Error with "key not in set";
          end if;
 
-         --  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
+            Tree : Tree_Type renames Container.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
 
-         return (Element => Node.Element'Access);
+         begin
+            return R : constant Reference_Type :=
+              (Element  => Node.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;
 
       -------------
diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads
index cf0110c..eea99f1 100644
--- a/gcc/ada/a-coorse.ads
+++ b/gcc/ada/a-coorse.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 --
@@ -278,8 +278,30 @@ package Ada.Containers.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;
+
+      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;
 
       use Ada.Streams;
 
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 72e47d8..b3d180f 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -7357,12 +7357,25 @@ package body Exp_Ch4 is
                  Make_Raise_Program_Error (Loc,
                    Reason => PE_Unchecked_Union_Restriction));
 
+               --  Emit a warning on source equalities only, otherwise the
+               --  message may appear out of place due to internal use. The
+               --  warning is unconditional because it is required by the
+               --  language.
+
+               if Comes_From_Source (N) then
+                  Error_Msg_N
+                    ("??Unchecked_Union discriminants cannot be determined",
+                     N);
+                  Error_Msg_N
+                    ("\Program_Error will be raised for equality operation",
+                     N);
+               end if;
+
                --  Prevent Gigi from generating incorrect code by rewriting
                --  the equality as a standard False (documented where???).
 
                Rewrite (N,
                  New_Occurrence_Of (Standard_False, Loc));
-
             end if;
 
          --  If a type support function is present (for complex cases), use it