[multiple changes]

2015-05-12  Ed Schonberg  <schonberg@adacore.com>

	* a-coormu.ads, a-coormu.adb: Add Indexing aspect, Reference_Type,
	and Reference_Control_Type to support element iterators over
	ordered multisets.
	* a-ciormu.ads, a-ciormu.adb: Ditto for
	indefinite_ordered_multisets.

2015-05-12  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_N_Expression_With_Actions): Force
	the evaluation of the EWA expression.  Code cleanup.
	(Process_Transient_Object): Code cleanup.
	* exp_util.adb (Is_Aliased): Controlled transient objects found
	within EWA nodes are not aliased.
	(Is_Finalizable_Transient): Iterators are not finalizable transients.

From-SVN: r223076

gcc/ada/ChangeLog

+2015-05-12  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-coormu.ads, a-coormu.adb: Add Indexing aspect, Reference_Type,
+	and Reference_Control_Type to support element iterators over
+	ordered multisets.
+	* a-ciormu.ads, a-ciormu.adb: Ditto for
+	indefinite_ordered_multisets.
+
+2015-05-12  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch4.adb (Expand_N_Expression_With_Actions): Force
+	the evaluation of the EWA expression.  Code cleanup.
+	(Process_Transient_Object): Code cleanup.
+	* exp_util.adb (Is_Aliased): Controlled transient objects found
+	within EWA nodes are not aliased.
+	(Is_Finalizable_Transient): Iterators are not finalizable transients.
+
 2015-05-12  Robert Dewar  <dewar@adacore.com>
 
 	* sem_prag.adb (Process_Atomic_Independent_Shared_Volatile):

gcc/ada/a-ciormu.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2015, 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- --
@@ -353,6 +353,45 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
       return Node.Color;
    end Color;
 
+   ------------------------
+   -- Constant_Reference --
+   ------------------------
+
+   function Constant_Reference
+     (Container : aliased Set;
+      Position  : Cursor) return Constant_Reference_Type
+   is
+   begin
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      if Position.Container /= Container'Unrestricted_Access then
+         raise Program_Error with
+           "Position cursor designates wrong container";
+      end if;
+
+      pragma Assert (Vet (Position.Container.Tree, Position.Node),
+                     "bad cursor in Constant_Reference");
+
+      --  Note: in predefined container units, the creation of a reference
+      --  increments the busy bit of the container, and its finalization
+      --  decrements it. In the absence of control machinery, this tampering
+      --  protection is missing.
+
+      declare
+         T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+         pragma Unreferenced (T);
+      begin
+         return R : constant Constant_Reference_Type :=
+           (Element => Position.Node.Element,
+            Control => (Container => Container'Unrestricted_Access))
+         do
+            null;
+         end return;
+      end;
+   end Constant_Reference;
+
    --------------
    -- Contains --
    --------------
@@ -1730,6 +1769,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
       raise Program_Error with "attempt to stream set cursor";
    end Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
    ---------------------
    -- Replace_Element --
    ---------------------
@@ -2055,4 +2102,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
       raise Program_Error with "attempt to stream set cursor";
    end Write;
 
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
 end Ada.Containers.Indefinite_Ordered_Multisets;

gcc/ada/a-ciormu.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2015, 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- --
@@ -52,8 +52,9 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
    --  otherwise, it returns True.
 
    type Set is tagged private
-   with Default_Iterator => Iterate,
-        Iterator_Element => Element_Type;
+   with Constant_Indexing => Constant_Reference,
+        Default_Iterator  => Iterate,
+        Iterator_Element  => Element_Type;
 
    pragma Preelaborable_Initialization (Set);
 
@@ -128,6 +129,15 @@ package Ada.Containers.Indefinite_Ordered_Multisets is
    --  change the value of the element while Process is executing (to "tamper
    --  with elements") will raise Program_Error.
 
+   type Constant_Reference_Type
+     (Element : not null access constant Element_Type) is private
+        with Implicit_Dereference => Element;
+
+   function Constant_Reference
+     (Container : aliased Set;
+      Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
+
    procedure Assign (Target : in out Set; Source : Set);
 
    function Copy (Source : Set) return Set;
@@ -469,6 +479,19 @@ private
    type Set_Access is access all Set;
    for Set_Access'Storage_Size use 0;
 
+   --  In all predefined libraries the following type is controlled, for proper
+   --  management of tampering checks. For performance reason we omit this
+   --  machinery for multisets, which are used in a number of our tools.
+
+   type Reference_Control_Type is record
+      Container : Set_Access;
+   end record;
+
+   type Constant_Reference_Type
+     (Element : not null access constant Element_Type) is record
+      Control : Reference_Control_Type;
+   end record;
+
    type Cursor is record
       Container : Set_Access;
       Node      : Node_Access;
@@ -500,6 +523,18 @@ private
 
    for Set'Read use Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type);
+
+   for Constant_Reference_Type'Read use Read;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type);
+
+   for Constant_Reference_Type'Write use Write;
+
    Empty_Set : constant Set :=
                  (Controlled with Tree => (First  => null,
                                            Last   => null,

gcc/ada/a-coormu.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2015, 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- --
@@ -321,6 +321,45 @@ package body Ada.Containers.Ordered_Multisets is
       return Node.Color;
    end Color;
 
+   ------------------------
+   -- Constant_Reference --
+   ------------------------
+
+   function Constant_Reference
+     (Container : aliased Set;
+      Position  : Cursor) return Constant_Reference_Type
+   is
+   begin
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      if Position.Container /= Container'Unrestricted_Access then
+         raise Program_Error with
+           "Position cursor designates wrong container";
+      end if;
+
+      pragma Assert (Vet (Position.Container.Tree, Position.Node),
+                     "bad cursor in Constant_Reference");
+
+      --  Note: in predefined container units, the creation of a reference
+      --  increments the busy bit of the container, and its finalization
+      --  decrements it. In the absence of control machinery, this tampering
+      --  protection is missing.
+
+      declare
+         T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+         pragma Unreferenced (T);
+      begin
+         return R : constant Constant_Reference_Type :=
+           (Element => Position.Node.Element'Unrestricted_Access,
+            Control => (Container => Container'Unrestricted_Access))
+         do
+            null;
+         end return;
+      end;
+   end Constant_Reference;
+
    --------------
    -- Contains --
    --------------
@@ -1638,6 +1677,14 @@ package body Ada.Containers.Ordered_Multisets is
       raise Program_Error with "attempt to stream set cursor";
    end Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
    ---------------------
    -- Replace_Element --
    ---------------------
@@ -1937,4 +1984,11 @@ package body Ada.Containers.Ordered_Multisets is
       raise Program_Error with "attempt to stream set cursor";
    end Write;
 
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
 end Ada.Containers.Ordered_Multisets;

gcc/ada/a-coormu.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2015, 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- --
@@ -51,8 +51,9 @@ package Ada.Containers.Ordered_Multisets is
    --  otherwise, it returns True.
 
    type Set is tagged private
-   with Default_Iterator => Iterate,
-        Iterator_Element => Element_Type;
+   with Constant_Indexing => Constant_Reference,
+        Default_Iterator  => Iterate,
+        Iterator_Element  => Element_Type;
 
    pragma Preelaborable_Initialization (Set);
 
@@ -127,6 +128,15 @@ package Ada.Containers.Ordered_Multisets is
    --  change the value of the element while Process is executing (to "tamper
    --  with elements") will raise Program_Error.
 
+   type Constant_Reference_Type
+     (Element : not null access constant Element_Type) is private
+        with Implicit_Dereference => Element;
+
+   function Constant_Reference
+     (Container : aliased Set;
+      Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
+
    procedure Assign (Target : in out Set; Source : Set);
 
    function Copy (Source : Set) return Set;
@@ -473,6 +483,19 @@ private
    type Set_Access is access all Set;
    for Set_Access'Storage_Size use 0;
 
+   --  In all predefined libraries the following type is controlled, for proper
+   --  management of tampering checks. For performance reason we omit this
+   --  machinery for multisets, which are used in a number of our tools.
+
+   type Reference_Control_Type is record
+      Container : Set_Access;
+   end record;
+
+   type Constant_Reference_Type
+     (Element : not null access constant Element_Type) is record
+      Control : Reference_Control_Type;
+   end record;
+
    type Cursor is record
       Container : Set_Access;
       Node      : Node_Access;
@@ -504,6 +527,18 @@ private
 
    for Set'Read use Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type);
+
+   for Constant_Reference_Type'Read use Read;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type);
+
+   for Constant_Reference_Type'Write use Write;
+
    Empty_Set : constant Set :=
                  (Controlled with Tree => (First  => null,
                                            Last   => null,

gcc/ada/exp_util.adb

@@ -4713,7 +4713,6 @@ package body Exp_Util is
    is
       Obj_Id  : constant Entity_Id := Defining_Identifier (Decl);
       Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
-      Desig   : Entity_Id := Obj_Typ;
 
       function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
       --  Determine whether transient object Trans_Id is initialized either
@@ -4916,31 +4915,61 @@ package body Exp_Util is
       --  Start of processing for Is_Aliased
 
       begin
-         Stmt := First_Stmt;
-         while Present (Stmt) loop
-            if Nkind (Stmt) = N_Object_Declaration then
-               Expr := Expression (Stmt);
-
-               if Present (Expr)
-                 and then Nkind (Expr) = N_Reference
-                 and then Nkind (Prefix (Expr)) = N_Identifier
-                 and then Entity (Prefix (Expr)) = Trans_Id
-               then
-                  return True;
-               end if;
+         --  A controlled transient object is not considered aliased when it
+         --  appears inside an expression_with_actions node even when there are
+         --  explicit aliases of it:
+
+         --    do
+         --       Trans_Id : Ctrl_Typ ...;  --  controlled transient object
+         --       Alias : ... := Trans_Id;  --  object is aliased
+         --       Val : constant Boolean :=
+         --               ... Alias ...;    --  aliasing ends
+         --       <finalize Trans_Id>       --  object safe to finalize
+         --    in Val end;
+
+         --  Expansion ensures that all aliases are encapsulated in the actions
+         --  list and do not leak to the expression by forcing the evaluation
+         --  of the expression.
+
+         if Nkind (Rel_Node) = N_Expression_With_Actions then
+            return False;
 
-            elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
-               Ren_Obj := Find_Renamed_Object (Stmt);
+         --  Otherwise examine the statements after the controlled transient
+         --  object and look for various forms of aliasing.
 
-               if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
-                  return True;
+         else
+            Stmt := First_Stmt;
+            while Present (Stmt) loop
+               if Nkind (Stmt) = N_Object_Declaration then
+                  Expr := Expression (Stmt);
+
+                  --  Aliasing of the form:
+                  --    Obj : ... := Trans_Id'reference;
+
+                  if Present (Expr)
+                    and then Nkind (Expr) = N_Reference
+                    and then Nkind (Prefix (Expr)) = N_Identifier
+                    and then Entity (Prefix (Expr)) = Trans_Id
+                  then
+                     return True;
+                  end if;
+
+               elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
+                  Ren_Obj := Find_Renamed_Object (Stmt);
+
+                  --  Aliasing of the form:
+                  --    Obj : ... renames ... Trans_Id ...;
+
+                  if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
+                     return True;
+                  end if;
                end if;
-            end if;
 
-            Next (Stmt);
-         end loop;
+               Next (Stmt);
+            end loop;
 
-         return False;
+            return False;
+         end if;
       end Is_Aliased;
 
       ------------------
@@ -5041,6 +5070,10 @@ package body Exp_Util is
          return False;
       end Is_Iterated_Container;
 
+      --  Local variables
+
+      Desig : Entity_Id := Obj_Typ;
+
    --  Start of processing for Is_Finalizable_Transient
 
    begin
@@ -5083,6 +5116,12 @@ package body Exp_Util is
 
           and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
 
+          --  Do not consider iterators because those are treated as normal
+          --  controlled objects and are processed by the usual finalization
+          --  machinery. This avoids the double finalization of an iterator.
+
+          and then not Is_Iterator (Desig)
+
           --  Do not consider containers in the context of iterator loops. Such
           --  transient objects must exist for as long as the loop is around,
           --  otherwise any operation carried out by the iterator will fail.