[multiple changes]

2011-08-29  Robert Dewar  <dewar@adacore.com>

	* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.

2011-08-29  Bob Duff  <duff@adacore.com>

	* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
	of <>, because this is the routine that checks for dimensionality
	errors (for example, for a two-dimensional array, (others => <>) should
	be (others => (others => <>)).

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* impunit.adb: Add new run-time units.
	* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
	s-stposu.ads, s-stposu.adb: Code clean up.
	Handle protected class-wide or task class-wide types
	Handle C/C++/CIL/Java types.
	* s-spsufi.adb, s-spsufi.ads: New files.

From-SVN: r178205

gcc/ada/ChangeLog

+2011-08-29  Robert Dewar  <dewar@adacore.com>
+
+	* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.
+
+2011-08-29  Bob Duff  <duff@adacore.com>
+
+	* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
+	of <>, because this is the routine that checks for dimensionality
+	errors (for example, for a two-dimensional array, (others => <>) should
+	be (others => (others => <>)).
+
+2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* impunit.adb: Add new run-time units.
+	* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
+	s-stposu.ads, s-stposu.adb: Code clean up.
+	Handle protected class-wide or task class-wide types
+	Handle C/C++/CIL/Java types.
+	* s-spsufi.adb, s-spsufi.ads: New files.
+
 2011-08-29  Yannick Moy  <moy@adacore.com>
 
 	* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on

gcc/ada/Makefile.rtl

@@ -155,7 +155,6 @@ GNATRTL_NONTASKING_OBJS= \
   a-envvar$(objext) \
   a-except$(objext) \
   a-exctra$(objext) \
-  a-fihema$(objext) \
   a-finali$(objext) \
   a-flteio$(objext) \
   a-fwteio$(objext) \
@@ -291,6 +290,7 @@ GNATRTL_NONTASKING_OBJS= \
   a-tiunio$(objext) \
   a-unccon$(objext) \
   a-uncdea$(objext) \
+  a-undesu$(objext) \
   a-wichha$(objext) \
   a-wichun$(objext) \
   a-widcha$(objext) \
@@ -496,6 +496,7 @@ GNATRTL_NONTASKING_OBJS= \
   s-ficobl$(objext) \
   s-fileio$(objext) \
   s-filofl$(objext) \
+  s-finmas$(objext) \
   s-finroo$(objext) \
   s-fishfl$(objext) \
   s-flocon$(objext) \
@@ -606,12 +607,14 @@ GNATRTL_NONTASKING_OBJS= \
   s-sequio$(objext) \
   s-shasto$(objext) \
   s-soflin$(objext) \
+  s-spsufi$(objext) \
   s-stache$(objext) \
   s-stalib$(objext) \
   s-stausa$(objext) \
   s-stchop$(objext) \
   s-stoele$(objext) \
   s-stopoo$(objext) \
+  s-stposu$(objext) \
   s-stratt$(objext) \
   s-strhas$(objext) \
   s-string$(objext) \

gcc/ada/a-exexpr-gcc.adb

@@ -277,13 +277,15 @@ package body Exception_Propagation is
 
    procedure GNAT_GCC_Exception_Cleanup
      (Reason : Unwind_Reason_Code;
-      Excep  : not null GNAT_GCC_Exception_Access) is
+      Excep  : not null GNAT_GCC_Exception_Access)
+   is
       pragma Unreferenced (Reason);
 
       procedure Free is new Unchecked_Deallocation
         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 
       Copy : GNAT_GCC_Exception_Access := Excep;
+
    begin
       --  Simply free the memory
 
@@ -303,6 +305,7 @@ package body Exception_Propagation is
       UW_Argument  : System.Address) return Unwind_Reason_Code
    is
       pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
+
    begin
       --  Terminate when the end of the stack is reached
 
@@ -332,6 +335,7 @@ package body Exception_Propagation is
       Reraised : Boolean := False)
    is
       pragma Unreferenced (Excep, Current, Reraised);
+
    begin
       --  In the GNAT-SJLJ case this "stack" only exists implicitly, by way of
       --  local occurrence declarations together with save/restore operations
@@ -345,8 +349,10 @@ package body Exception_Propagation is
    -------------------------
 
    procedure Setup_Current_Excep
-     (GCC_Exception : not null GCC_Exception_Access) is
+     (GCC_Exception : not null GCC_Exception_Access)
+   is
       Excep : constant EOA := Get_Current_Excep.all;
+
    begin
       --  Setup the exception occurrence
 
@@ -356,7 +362,7 @@ package body Exception_Propagation is
 
          declare
             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
-              To_GNAT_GCC_Exception (GCC_Exception);
+                                To_GNAT_GCC_Exception (GCC_Exception);
          begin
             Excep.all := GNAT_Occurrence.Occurrence;
          end;
@@ -404,7 +410,8 @@ package body Exception_Propagation is
    -----------------------------
 
    procedure Reraise_GCC_Exception
-     (GCC_Exception : not null GCC_Exception_Access) is
+     (GCC_Exception : not null GCC_Exception_Access)
+   is
    begin
       --  Simply propagate it
       Propagate_GCC_Exception (GCC_Exception);
@@ -418,7 +425,8 @@ package body Exception_Propagation is
    --  the two phase scheme it implements.
 
    procedure Propagate_GCC_Exception
-     (GCC_Exception : not null GCC_Exception_Access) is
+     (GCC_Exception : not null GCC_Exception_Access)
+   is
    begin
       --  Perform a standard raise first. If a regular handler is found, it
       --  will be entered after all the intermediate cleanups have run. If
@@ -436,15 +444,15 @@ package body Exception_Propagation is
 
       --  Now, un a forced unwind to trigger cleanups. Control should not
       --  resume there, if there are cleanups and in any cases as the
-      --  unwinding hook calls Unhandled_Exception_Terminate when end of stack
-      --  is reached.
+      --  unwinding hook calls Unhandled_Exception_Terminate when end of
+      --  stack is reached.
 
       Unwind_ForcedUnwind (GCC_Exception,
                            CleanupUnwind_Handler'Address,
                            System.Null_Address);
 
-      --  We get here in case of error.
-      --  The debugger has been notified before the second step above.
+      --  We get here in case of error. The debugger has been notified before
+      --  the second step above.
 
       Setup_Current_Excep (GCC_Exception);
       Unhandled_Exception_Terminate;
@@ -455,8 +463,8 @@ package body Exception_Propagation is
    -------------------------
 
    --  Build an object suitable for the libgcc processing and call
-   --  Unwind_RaiseException to actually throw, taking care of handling
-   --  the two phase scheme it implements.
+   --  Unwind_RaiseException to actually do the raise, taking care of
+   --  handling the two phase scheme it implements.
 
    procedure Propagate_Exception
      (E                   : Exception_Id;
@@ -494,14 +502,16 @@ package body Exception_Propagation is
 
       --  Allocate the GCC exception
 
-      GCC_Exception := new GNAT_GCC_Exception'
-        (Header    => (Class => GNAT_Exception_Class,
-                       Cleanup => GNAT_GCC_Exception_Cleanup'Address,
-                       Private1 => 0,
-                       Private2 => 0),
-         Occurrence => Excep.all);
+      GCC_Exception :=
+        new GNAT_GCC_Exception'
+          (Header     => (Class => GNAT_Exception_Class,
+                          Cleanup => GNAT_GCC_Exception_Cleanup'Address,
+                          Private1 => 0,
+                          Private2 => 0),
+           Occurrence => Excep.all);
+
+      --  Propagate it
 
-      --  Propagate it.
       Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
    end Propagate_Exception;
 

gcc/ada/a-synbar.adb

@@ -61,7 +61,6 @@ package body Ada.Synchronous_Barriers is
 
          Notified := Wait'Count = 0;
       end Wait;
-
    end Synchronous_Barrier;
 
    ----------------------

gcc/ada/a-undesu.adb

@@ -17,20 +17,15 @@
 
 --  ??? What is the header version here, see a-uncdea.adb. No GPL?
 
-with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
+with System.Storage_Pools.Subpools,
+     System.Storage_Pools.Subpools.Finalization;
+
+use System.Storage_Pools.Subpools,
+    System.Storage_Pools.Subpools.Finalization;
 
 procedure Ada.Unchecked_Deallocate_Subpool
   (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
 is
 begin
-   --  Finalize all controlled objects allocated on the input subpool
-
-   --  ??? It is awkward to create a child of Storage_Pools.Subpools for the
-   --  sole purpose of exporting Finalize_Subpool.
-
---   Finalize_Subpool (Subpool);
-
-   --  Dispatch to the user-defined implementation of Deallocate_Subpool
-
-   Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+   Finalize_And_Deallocate (Subpool);
 end Ada.Unchecked_Deallocate_Subpool;

gcc/ada/exp_ch3.adb

@@ -6626,35 +6626,31 @@ package body Exp_Ch3 is
             --  finalization support if not needed.
 
             if not Comes_From_Source (Def_Id)
-               and then not Has_Private_Declaration (Def_Id)
+              and then not Has_Private_Declaration (Def_Id)
             then
                null;
 
-            elsif (Needs_Finalization (Desig_Type)
-                    and then Convention (Desig_Type) /= Convention_Java
-                    and then Convention (Desig_Type) /= Convention_CIL)
-              or else
-                (Is_Incomplete_Or_Private_Type (Desig_Type)
-                  and then No (Full_View (Desig_Type))
-
-                  --  An exception is made for types defined in the run-time
-                  --  because Ada.Tags.Tag itself is such a type and cannot
-                  --  afford this unnecessary overhead that would generates a
-                  --  loop in the expansion scheme...
-
-                   and then not In_Runtime (Def_Id)
-
-                  --  Another exception is if Restrictions (No_Finalization)
-                  --  is active, since then we know nothing is controlled.
+            --  An exception is made for types defined in the run-time because
+            --  Ada.Tags.Tag itself is such a type and cannot afford this
+            --  unnecessary overhead that would generates a loop in the
+            --  expansion scheme. Another exception is if Restrictions
+            --  (No_Finalization) is active, since then we know nothing is
+            --  controlled.
 
-                   and then not Restriction_Active (No_Finalization))
+            elsif Restriction_Active (No_Finalization)
+              or else In_Runtime (Def_Id)
+            then
+               null;
 
-               --  If the designated type is not frozen yet, its controlled
-               --  status must be retrieved explicitly.
+            --  The machinery assumes that incomplete or private types are
+            --  always completed by a controlled full vies.
 
+            elsif Needs_Finalization (Desig_Type)
+              or else
+                (Is_Incomplete_Or_Private_Type (Desig_Type)
+                  and then No (Full_View (Desig_Type)))
               or else
                 (Is_Array_Type (Desig_Type)
-                  and then not Is_Frozen (Desig_Type)
                   and then Needs_Finalization (Component_Type (Desig_Type)))
             then
                Build_Finalization_Master (Def_Id);

gcc/ada/exp_ch7.ads

@@ -84,8 +84,8 @@ package Exp_Ch7 is
    --  Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_
    --  Deep_Record_Body. Generate the following conditional raise statement:
    --
-   --    if Raised_Id then
-   --       Raise_From_Controlled_Operation (E_Id, Abort_Id);
+   --    if Raised_Id and then not Abort_Id then
+   --       Raise_From_Controlled_Operation (E_Id);
    --    end if;
    --
    --  Abort_Id is a local boolean flag which is set when the finalization was

gcc/ada/exp_util.adb

@@ -327,10 +327,11 @@ package body Exp_Util is
      (N           : Node_Id;
       Is_Allocate : Boolean)
    is
-      Expr      : constant Node_Id   := Expression (N);
-      Ptr_Typ   : constant Entity_Id := Etype (Expr);
-      Desig_Typ : constant Entity_Id :=
-                    Available_View (Designated_Type (Ptr_Typ));
+      Desig_Typ    : Entity_Id;
+      Expr         : Node_Id;
+      Pool_Id      : Entity_Id;
+      Proc_To_Call : Node_Id := Empty;
+      Ptr_Typ      : Entity_Id;
 
       function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
       --  Locate TSS primitive Finalize_Address in type Typ
@@ -351,13 +352,33 @@ package body Exp_Util is
          Utyp : Entity_Id := Typ;
 
       begin
+         --  Handle protected class-wide or task class-wide types
+
+         if Is_Class_Wide_Type (Utyp) then
+            if Is_Concurrent_Type (Root_Type (Utyp)) then
+               Utyp := Root_Type (Utyp);
+
+            elsif Is_Private_Type (Root_Type (Utyp))
+              and then Present (Full_View (Root_Type (Utyp)))
+              and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
+            then
+               Utyp := Full_View (Root_Type (Utyp));
+            end if;
+         end if;
+
+         --  Handle private types
+
          if Is_Private_Type (Utyp)
            and then Present (Full_View (Utyp))
          then
             Utyp := Full_View (Utyp);
          end if;
 
-         if Is_Concurrent_Type (Utyp) then
+         --  Handle protected and task types
+
+         if Is_Concurrent_Type (Utyp)
+           and then Present (Corresponding_Record_Type (Utyp))
+         then
             Utyp := Corresponding_Record_Type (Utyp);
          end if;
 
@@ -459,18 +480,91 @@ package body Exp_Util is
    --  Start of processing for Build_Allocate_Deallocate_Proc
 
    begin
-      --  The allocation / deallocation of a non-controlled object does not
-      --  need the machinery created by this routine.
+      --  Obtain the attributes of the allocation / deallocation
+
+      if Nkind (N) = N_Free_Statement then
+         Expr := Expression (N);
+         Ptr_Typ := Base_Type (Etype (Expr));
+         Proc_To_Call := Procedure_To_Call (N);
+
+      else
+         if Nkind (N) = N_Object_Declaration then
+            Expr := Expression (N);
+         else
+            Expr := N;
+         end if;
+
+         Ptr_Typ := Base_Type (Etype (Expr));
+
+         --  The allocator may have been rewritten into something else
+
+         if Nkind (Expr) = N_Allocator then
+            Proc_To_Call := Procedure_To_Call (Expr);
+         end if;
+      end if;
+
+      Pool_Id := Associated_Storage_Pool (Ptr_Typ);
+      Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
 
-      if not Needs_Finalization (Desig_Typ) then
+      --  Handle concurrent types
+
+      if Is_Concurrent_Type (Desig_Typ)
+        and then Present (Corresponding_Record_Type (Desig_Typ))
+      then
+         Desig_Typ := Corresponding_Record_Type (Desig_Typ);
+      end if;
+
+      --  Do not process allocations / deallocations without a pool
+
+      if No (Pool_Id) then
          return;
 
-      --  The allocator or free statement has already been expanded and already
-      --  has a custom Allocate / Deallocate routine.
+      --  Do not process allocations on / deallocations from the secondary
+      --  stack.
+
+      elsif Is_RTE (Pool_Id, RE_SS_Pool) then
+         return;
+
+      --  Do not replicate the machinery if the allocator / free has already
+      --  been expanded and has a custom Allocate / Deallocate.
+
+      elsif Present (Proc_To_Call)
+        and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
+      then
+         return;
+      end if;
+
+      if Needs_Finalization (Desig_Typ) then
+
+         --  Certain run-time configurations and targets do not provide support
+         --  for controlled types.
+
+         if Restriction_Active (No_Finalization) then
+            return;
+
+         --  Do nothing if the access type may never allocate / deallocate
+         --  objects.
+
+         elsif No_Pool_Assigned (Ptr_Typ) then
+            return;
+
+         --  Access-to-controlled types are not supported on .NET/JVM since
+         --  these targets cannot support pools and address arithmetic.
+
+         elsif VM_Target /= No_VM then
+            return;
+         end if;
+
+         --  The allocation / deallocation of a controlled object must be
+         --  chained on / detached from a finalization master.
+
+         pragma Assert (Present (Finalization_Master (Ptr_Typ)));
+
+      --  The only other kind of allocation / deallocation supported by this
+      --  routine is on / from a subpool.
 
       elsif Nkind (Expr) = N_Allocator
-        and then Present (Procedure_To_Call (Expr))
-        and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr))
+        and then No (Subpool_Handle_Name (Expr))
       then
          return;
       end if;
@@ -486,36 +580,27 @@ package body Exp_Util is
          Fin_Addr_Id  : Entity_Id;
          Fin_Mas_Act  : Node_Id;
          Fin_Mas_Id   : Entity_Id;
-         Fin_Mas_Typ  : Entity_Id;
          Proc_To_Call : Entity_Id;
+         Subpool      : Node_Id := Empty;
 
       begin
-         --  When dealing with an access subtype, always use the base type
-         --  since it carries all the attributes.
-
-         if Ekind (Ptr_Typ) = E_Access_Subtype then
-            Fin_Mas_Typ := Base_Type (Ptr_Typ);
-         else
-            Fin_Mas_Typ := Ptr_Typ;
-         end if;
-
-         Actuals := New_List;
-
          --  Step 1: Construct all the actuals for the call to library routine
          --  Allocate_Any_Controlled / Deallocate_Any_Controlled.
 
          --  a) Storage pool
 
-         Append_To (Actuals,
-           New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
+         Actuals := New_List (New_Reference_To (Pool_Id, Loc));
 
          if Is_Allocate then
 
             --  b) Subpool
 
-            if Present (Subpool_Handle_Name (Expr)) then
-               Append_To (Actuals,
-                 New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
+            if Nkind (Expr) = N_Allocator then
+               Subpool := Subpool_Handle_Name (Expr);
+            end if;
+
+            if Present (Subpool) then
+               Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
             else
                Append_To (Actuals, Make_Null (Loc));
             end if;
@@ -523,7 +608,7 @@ package body Exp_Util is
             --  c) Finalization master
 
             if Needs_Finalization (Desig_Typ) then
-               Fin_Mas_Id  := Finalization_Master (Fin_Mas_Typ);
+               Fin_Mas_Id  := Finalization_Master (Ptr_Typ);
                Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
 
                --  Handle the case where the master is actually a pointer to a
@@ -545,7 +630,9 @@ package body Exp_Util is
 
             Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
 
-            if Present (Fin_Addr_Id) then
+            if Needs_Finalization (Desig_Typ) then
+               pragma Assert (Present (Fin_Addr_Id));
+
                Append_To (Actuals,
                  Make_Attribute_Reference (Loc,
                    Prefix         => New_Reference_To (Fin_Addr_Id, Loc),
@@ -654,11 +741,23 @@ package body Exp_Util is
 
                   Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
                end;
+
+            --  The object is statically known to be controlled
+
+            else
+               Append_To (Actuals, New_Reference_To (Standard_True, Loc));
             end if;
          else
             Append_To (Actuals, New_Reference_To (Standard_False, Loc));
          end if;
 
+         --  i) On_Subpool
+
+         if Is_Allocate then
+            Append_To (Actuals,
+              New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
+         end if;
+
          --  Step 2: Build a wrapper Allocate / Deallocate which internally
          --  calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
 
@@ -5296,6 +5395,16 @@ package body Exp_Util is
       if Restriction_Active (No_Finalization) then
          return False;
 
+      --  C, C++, CIL and Java types are not considered controlled. It is
+      --  assumed that the non-Ada side will handle their clean up.
+
+      elsif Convention (T) = Convention_C
+        or else Convention (T) = Convention_CIL
+        or else Convention (T) = Convention_CPP
+        or else Convention (T) = Convention_Java
+      then
+         return False;
+
       else
          --  Class-wide types are treated as controlled because derivations
          --  from the root type can introduce controlled components.

gcc/ada/exp_util.ads

@@ -198,8 +198,13 @@ package Exp_Util is
      (N           : Node_Id;
       Is_Allocate : Boolean);
    --  Create a custom Allocate/Deallocate to be associated with an allocation
-   --  or deallocation of a controlled or class-wide object. In the case of
-   --  allocation, N is the declaration of the temporary variable which
+   --  or deallocation:
+   --
+   --    1) controlled objects
+   --    2) class-wide objects
+   --    3) any kind of object on a subpool
+   --
+   --  N must be an allocator or the declaration of a temporary variable which
    --  represents the expression of the original allocator node, otherwise N
    --  must be a free statement. If flag Is_Allocate is set, the generated
    --  routine is allocate, deallocate otherwise.

gcc/ada/freeze.adb

@@ -1439,27 +1439,24 @@ package body Freeze is
                end loop;
             end;
 
-         --  We add finalization collections to access types whose designated
-         --  types require finalization. This is normally done when freezing
-         --  the type, but this misses recursive type definitions where the
-         --  later members of the recursion introduce controlled components
-         --  (such as can happen when incomplete types are involved), as well
-         --  cases where a component type is private and the controlled full
-         --  type occurs after the access type is frozen. Cases that don't
-         --  need a finalization collection are generic formal types (the
-         --  actual type will have it) and types with Java and CIL conventions,
-         --  since those are used for API bindings. (Are there any other cases
-         --  that should be excluded here???)
+         --  We add finalization masters to access types whose designated types
+         --  require finalization. This is normally done when freezing the
+         --  type, but this misses recursive type definitions where the later
+         --  members of the recursion introduce controlled components (such as
+         --  can happen when incomplete types are involved), as well cases
+         --  where a component type is private and the controlled full type
+         --  occurs after the access type is frozen. Cases that don't need a
+         --  finalization master are generic formal types (the actual type will
+         --  have it) and types with Java and CIL conventions, since those are
+         --  used for API bindings. (Are there any other cases that should be
+         --  excluded here???)
 
          elsif Is_Access_Type (E)
            and then Comes_From_Source (E)
            and then not Is_Generic_Type (E)
            and then Needs_Finalization (Designated_Type (E))
-           and then No (Associated_Collection (E))
-           and then Convention (Designated_Type (E)) /= Convention_Java
-           and then Convention (Designated_Type (E)) /= Convention_CIL
          then
-            Build_Finalization_Collection (E);
+            Build_Finalization_Master (E);
          end if;
 
          Next_Entity (E);

gcc/ada/impunit.adb

@@ -346,6 +346,7 @@ package body Impunit is
 
      "s-addima",    -- System.Address_Image
      "s-assert",    -- System.Assertions
+     "s-finmas",    -- System.Finalization_Masters
      "s-memory",    -- System.Memory
      "s-parint",    -- System.Partition_Interface
      "s-pooglo",    -- System.Pool_Global
@@ -508,6 +509,7 @@ package body Impunit is
    Non_Imp_File_Names_12 : constant File_List := (
      "s-multip",    -- System.Multiprocessors
      "s-mudido",    -- System.Multiprocessors.Dispatching_Domains
+     "s-stposu",    -- System.Storage_Pools.Subpools
      "a-cobove",    -- Ada.Containers.Bounded_Vectors
      "a-cbdlli",    -- Ada.Containers.Bounded_Doubly_Linked_Lists
      "a-cborse",    -- Ada.Containers.Bounded_Ordered_Sets
@@ -521,11 +523,13 @@ package body Impunit is
      "a-extiin",    -- Ada.Execution_Time.Interrupts
      "a-iteint",    -- Ada.Iterator_Interfaces
      "a-synbar",    -- Ada.Synchronous_Barriers
+     "a-undesu",    -- Ada.Unchecked_Deallocate_Subpool
 
    -----------------------------------------
    -- GNAT Defined Additions to Ada 20012 --
    -----------------------------------------
 
+     "s-spsufi",    -- System.Storage_Pools.Subpools.Finalization
      "a-cofove",    -- Ada.Containers.Formal_Vectors
      "a-cfdlli",    -- Ada.Containers.Formal_Doubly_Linked_Lists
      "a-cforse",    -- Ada.Containers.Formal_Ordered_Sets

gcc/ada/s-finmas.ads

@@ -35,6 +35,8 @@ with Ada.Unchecked_Conversion;
 with System.Storage_Elements;
 with System.Storage_Pools;
 
+pragma Compiler_Unit;
+
 package System.Finalization_Masters is
    pragma Preelaborate (System.Finalization_Masters);
 

gcc/ada/s-spsufi.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--        S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S .       --
+--                          F I N A L I Z A T I O N                         --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--             Copyright (C) 2011, 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+package body System.Storage_Pools.Subpools.Finalization is
+
+   -----------------------------
+   -- Finalize_And_Deallocate --
+   -----------------------------
+
+   procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is
+   begin
+      --  Do nothing if the subpool was never created or never used. The latter
+      --  case may arise with an array of subpool implementations.
+
+      if Subpool = null
+        or else Subpool.Owner = null
+        or else Subpool.Node = null
+      then
+         return;
+      end if;
+
+      --  Clean up all controlled objects allocated through the subpool
+
+      Finalize_Subpool (Subpool);
+
+      --  Dispatch to the user-defined implementation of Deallocate_Subpool
+
+      Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+
+      Subpool := null;
+   end Finalize_And_Deallocate;
+
+end System.Storage_Pools.Subpools.Finalization;

gcc/ada/s-spsufi.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--        S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S .       --
+--                          F I N A L I Z A T I O N                         --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--             Copyright (C) 2011, 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Compiler_Unit;
+
+package System.Storage_Pools.Subpools.Finalization is
+
+   procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle);
+   --  This routine performs the following actions:
+   --    1) Finalize all objects chained on the subpool's master
+   --    2) Remove the the subpool from the owner's list of subpools
+   --    3) Deallocate the doubly linked list node associated with the subpool
+   --    4) Call Deallocate_Subpool
+
+end System.Storage_Pools.Subpools.Finalization;

gcc/ada/sem_aggr.adb

@@ -1309,6 +1309,10 @@ package body Sem_Aggr is
       --  for discrete choices such as "L .. H => Expr" or the OTHERS choice).
       --  In this event we do not resolve Expr unless expansion is disabled.
       --  To know why, see the DELAYED COMPONENT RESOLUTION note above.
+      --
+      --  NOTE: In the case of "... => <>", we pass the in the
+      --  N_Component_Association node as Expr, since there is no Expression in
+      --  that case, and we need a Sloc for the error message.
 
       ---------
       -- Add --
@@ -1635,6 +1639,13 @@ package body Sem_Aggr is
                end if;
             end if;
 
+            --  If it's "... => <>", nothing to resolve
+
+            if Nkind (Expr) = N_Component_Association then
+               pragma Assert (Box_Present (Expr));
+               return Success;
+            end if;
+
             --  Ada 2005 (AI-231): Propagate the type to the nested aggregate.
             --  Required to check the null-exclusion attribute (if present).
             --  This value may be overridden later on.
@@ -1644,19 +1655,29 @@ package body Sem_Aggr is
             Resolution_OK := Resolve_Array_Aggregate
               (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
 
-         --  Do not resolve the expressions of discrete or others choices
-         --  unless the expression covers a single component, or the expander
-         --  is inactive.
+         else
+
+            --  If it's "... => <>", nothing to resolve
 
-         elsif Single_Elmt
-           or else not Expander_Active
-           or else In_Spec_Expression
-         then
-            Analyze_And_Resolve (Expr, Component_Typ);
-            Check_Expr_OK_In_Limited_Aggregate (Expr);
-            Check_Non_Static_Context (Expr);
-            Aggregate_Constraint_Checks (Expr, Component_Typ);
-            Check_Unset_Reference (Expr);
+            if Nkind (Expr) = N_Component_Association then
+               pragma Assert (Box_Present (Expr));
+               return Success;
+            end if;
+
+            --  Do not resolve the expressions of discrete or others choices
+            --  unless the expression covers a single component, or the
+            --  expander is inactive.
+
+            if Single_Elmt
+              or else not Expander_Active
+              or else In_Spec_Expression
+            then
+               Analyze_And_Resolve (Expr, Component_Typ);
+               Check_Expr_OK_In_Limited_Aggregate (Expr);
+               Check_Non_Static_Context (Expr);
+               Aggregate_Constraint_Checks (Expr, Component_Typ);
+               Check_Unset_Reference (Expr);
+            end if;
          end if;
 
          if Raises_Constraint_Error (Expr)
@@ -1988,9 +2009,15 @@ package body Sem_Aggr is
 
                   --  Ada 2005 (AI-287): In case of default initialization of a
                   --  component the expander will generate calls to the
-                  --  corresponding initialization subprogram.
+                  --  corresponding initialization subprogram. We need to call
+                  --  Resolve_Aggr_Expr to check the rules about
+                  --  dimensionality.
 
-                  null;
+                  if not Resolve_Aggr_Expr (Assoc,
+                                            Single_Elmt => Single_Choice)
+                  then
+                     return Failure;
+                  end if;
 
                elsif not Resolve_Aggr_Expr (Expression (Assoc),
                                             Single_Elmt => Single_Choice)
@@ -2321,9 +2348,13 @@ package body Sem_Aggr is
 
                --  Ada 2005 (AI-287): In case of default initialization of a
                --  component the expander will generate calls to the
-               --  corresponding initialization subprogram.
+               --  corresponding initialization subprogram. We need to call
+               --  Resolve_Aggr_Expr to check the rules about
+               --  dimensionality.
 
-               null;
+               if not Resolve_Aggr_Expr (Assoc, Single_Elmt => False) then
+                  return Failure;
+               end if;
 
             elsif not Resolve_Aggr_Expr (Expression (Assoc),
                                          Single_Elmt => False)

gcc/ada/sem_ch13.adb

@@ -1471,6 +1471,7 @@ package body Sem_Ch13 is
 
                else
                   case A_Id is
+
                      --  For Pre/Post cases, insert immediately after the
                      --  entity declaration, since that is the required pragma
                      --  placement.

gcc/ada/sem_ch6.adb

@@ -2348,7 +2348,7 @@ package body Sem_Ch6 is
          --  the proper back-annotations.
 
          if not Is_Frozen (Spec_Id)
-           and then (Expander_Active or ASIS_Mode)
+           and then (Expander_Active or else ASIS_Mode)
          then
             --  Force the generation of its freezing node to ensure proper
             --  management of access types in the backend.
@@ -6081,14 +6081,13 @@ package body Sem_Ch6 is
             end if;
 
             --  In the case of functions whose result type needs finalization,
-            --  add an extra formal of type Ada.Finalization.Heap_Management.
-            --  Finalization_Collection_Ptr.
+            --  add an extra formal which represents the finalization master.
 
-            if Needs_BIP_Collection (E) then
+            if Needs_BIP_Finalization_Master (E) then
                Discard :=
                  Add_Extra_Formal
-                   (E, RTE (RE_Finalization_Collection_Ptr),
-                    E, BIP_Formal_Suffix (BIP_Collection));
+                   (E, RTE (RE_Finalization_Master_Ptr),
+                    E, BIP_Formal_Suffix (BIP_Finalization_Master));
             end if;
 
             --  If the result type contains tasks, we have two extra formals: