2011-09-06 Ed Schonberg <schonberg@adacore.com>

	* exp_ch6.adb (Expand_Inlined_Call): Fix use of uninitialized
	variable for type of return value when return type is
	unconstrained and context is an assignment.

2011-09-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Check_Class_Wide_Actual): Do not generate body of
	class-wide operation if expansion is not enabled.

2011-09-06  Eric Botcazou  <ebotcazou@adacore.com>

	* checks.adb (Apply_Scalar_Range_Check): Deal with access
	type prefix.

2011-09-06  Yannick Moy  <moy@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications, case
	Aspect_Invariant): Do not issue error at this point on illegal
	pragma placement, as this is checked later on when analyzing
	the corresponding pragma.
	* sem_prag.adb (Error_Pragma_Arg_Alternate_Name): New procedure
	similar to Error_Pragma_Arg, except the source name of the
	aspect/pragma to use in warnings may be equal to parameter
	Alt_Name (Analyze_Pragma, case Pragma_Invariant): refine error
	message to distinguish source name of pragma/aspect, and whether
	the illegality resides in the type being public, or being private
	without a public declaration

2011-09-06  Thomas Quinot  <quinot@adacore.com>

	* g-socket.adb (Check_For_Fd_Set): On Windows, no need for bitmap
	size check (fd_set is implemented differently on that platform).

2011-09-06  Thomas Quinot  <quinot@adacore.com>

	* s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
	s-tpoaal.adb, s-taprop-mingw.adb, s-taprop-linux.adb,
	s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop.ads,
	s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb
	(ATCB_Allocation): New subpackage of
	System.Tasking.Primitive_Operations, shared across all targets
	with full tasking runtime.
	(ATCB_Allocation.New_ATCB): Moved there (from target specific
	s-taprop bodies).
	(ATCB_Allocation.Free_ATCB): New subprogram. Deallocate an ATCB,
	taking care of establishing a local temporary ATCB if the one
	being deallocated is Self, to avoid a reference to the freed
	ATCB in Abort_Undefer.

2011-09-06  Thomas Quinot  <quinot@adacore.com>

	* s-tassta.adb, s-taskin.ads (Free_Task): If the task is not
	terminated, mark it for deallocation upon termination.
	(Terminate_Task): Call Free_Task again if the task is marked
	for automatic deallocation upon termination.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178582 138bc75d-0d04-0410-961f-82ee72b054a4

21 files changed, 442 insertions, 337 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 270e0bfec64..0b5216f1e0c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,61 @@
+2011-09-06  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch6.adb (Expand_Inlined_Call): Fix use of uninitialized
+	variable for type of return value when return type is
+	unconstrained and context is an assignment.
+
+2011-09-06  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch8.adb (Check_Class_Wide_Actual): Do not generate body of
+	class-wide operation if expansion is not enabled.
+
+2011-09-06  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* checks.adb (Apply_Scalar_Range_Check): Deal with access
+	type prefix.
+
+2011-09-06  Yannick Moy  <moy@adacore.com>
+
+	* sem_ch13.adb (Analyze_Aspect_Specifications, case
+	Aspect_Invariant): Do not issue error at this point on illegal
+	pragma placement, as this is checked later on when analyzing
+	the corresponding pragma.
+	* sem_prag.adb (Error_Pragma_Arg_Alternate_Name): New procedure
+	similar to Error_Pragma_Arg, except the source name of the
+	aspect/pragma to use in warnings may be equal to parameter
+	Alt_Name (Analyze_Pragma, case Pragma_Invariant): refine error
+	message to distinguish source name of pragma/aspect, and whether
+	the illegality resides in the type being public, or being private
+	without a public declaration
+
+2011-09-06  Thomas Quinot  <quinot@adacore.com>
+
+	* g-socket.adb (Check_For_Fd_Set): On Windows, no need for bitmap
+	size check (fd_set is implemented differently on that platform).
+
+2011-09-06  Thomas Quinot  <quinot@adacore.com>
+
+	* s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
+	s-tpoaal.adb, s-taprop-mingw.adb, s-taprop-linux.adb,
+	s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop.ads,
+	s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb
+	(ATCB_Allocation): New subpackage of
+	System.Tasking.Primitive_Operations, shared across all targets
+	with full tasking runtime.
+	(ATCB_Allocation.New_ATCB): Moved there (from target specific
+	s-taprop bodies).
+	(ATCB_Allocation.Free_ATCB): New subprogram. Deallocate an ATCB,
+	taking care of establishing a local temporary ATCB if the one
+	being deallocated is Self, to avoid a reference to the freed
+	ATCB in Abort_Undefer.
+
+2011-09-06  Thomas Quinot  <quinot@adacore.com>
+
+	* s-tassta.adb, s-taskin.ads (Free_Task): If the task is not
+	terminated, mark it for deallocation upon termination.
+	(Terminate_Task): Call Free_Task again if the task is marked
+	for automatic deallocation upon termination.
+
 2011-09-06  Robert Dewar  <dewar@adacore.com>
 
 	* a-cbprqu.ads, a-cbsyqu.ads, a-cuprqu.ads, a-cusyqu.ads,
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index cb07771343b..336b14462c2 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -1877,6 +1877,9 @@ package body Checks is
       if Is_Subscr_Ref then
          Arr := Prefix (Parnt);
          Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
+         if Is_Access_Type (Arr_Typ) then
+            Arr_Typ := Directly_Designated_Type (Arr_Typ);
+         end if;
       end if;
 
       if not Do_Range_Check (Expr) then
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index f5765a32c78..b3003893eef 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3740,8 +3740,15 @@ package body Exp_Ch6 is
       New_A    : Node_Id;
       Num_Ret  : Int := 0;
       Ret_Type : Entity_Id;
-      Targ     : Node_Id;
-      Targ1    : Node_Id;
+
+      Targ : Node_Id;
+      --  The target of the call. If context is an assignment statement then
+      --  this is the left-hand side of the assignment. else it is a temporary
+      --  to which the return value is assigned prior to rewriting the call.
+
+      Targ1 : Node_Id;
+      --  A separate target used when the return type is unconstrained
+
       Temp     : Entity_Id;
       Temp_Typ : Entity_Id;
 
@@ -3749,8 +3756,8 @@ package body Exp_Ch6 is
       --  Entity in declaration in an extended_return_statement
 
       Is_Unc : constant Boolean :=
-                    Is_Array_Type (Etype (Subp))
-                      and then not Is_Constrained (Etype (Subp));
+                 Is_Array_Type (Etype (Subp))
+                   and then not Is_Constrained (Etype (Subp));
       --  If the type returned by the function is unconstrained and the call
       --  can be inlined, special processing is required.
 
@@ -3841,6 +3848,7 @@ package body Exp_Ch6 is
                   Rewrite (N, New_Copy (A));
                end if;
             end if;
+
             return Skip;
 
          elsif Is_Entity_Name (N)
@@ -3891,8 +3899,8 @@ package body Exp_Ch6 is
                if Nkind_In (Expression (N), N_Aggregate, N_Null) then
                   Ret :=
                     Make_Qualified_Expression (Sloc (N),
-                       Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
-                       Expression => Relocate_Node (Expression (N)));
+                      Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
+                      Expression => Relocate_Node (Expression (N)));
                else
                   Ret :=
                     Unchecked_Convert_To
@@ -3902,12 +3910,12 @@ package body Exp_Ch6 is
                if Nkind (Targ) = N_Defining_Identifier then
                   Rewrite (N,
                     Make_Assignment_Statement (Loc,
-                      Name => New_Occurrence_Of (Targ, Loc),
+                      Name       => New_Occurrence_Of (Targ, Loc),
                       Expression => Ret));
                else
                   Rewrite (N,
                     Make_Assignment_Statement (Loc,
-                      Name => New_Copy (Targ),
+                      Name       => New_Copy (Targ),
                       Expression => Ret));
                end if;
 
@@ -3915,19 +3923,17 @@ package body Exp_Ch6 is
 
                if Present (Exit_Lab) then
                   Insert_After (N,
-                    Make_Goto_Statement (Loc,
-                      Name => New_Copy (Lab_Id)));
+                    Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
                end if;
             end if;
 
             return OK;
 
-         elsif Nkind (N) = N_Extended_Return_Statement then
-
-            --  An extended return becomes a block whose first statement is
-            --  the assignment of the initial expression of the return object
-            --  to the target of the call itself.
+         --  An extended return becomes a block whose first statement is the
+         --  assignment of the initial expression of the return object to the
+         --  target of the call itself.
 
+         elsif Nkind (N) = N_Extended_Return_Statement then
             declare
                Return_Decl : constant Entity_Id :=
                                First (Return_Object_Declarations (N));
@@ -3940,12 +3946,12 @@ package body Exp_Ch6 is
                   if Nkind (Targ) = N_Defining_Identifier then
                      Assign :=
                        Make_Assignment_Statement (Loc,
-                         Name => New_Occurrence_Of (Targ, Loc),
+                         Name       => New_Occurrence_Of (Targ, Loc),
                          Expression => Expression (Return_Decl));
                   else
                      Assign :=
                        Make_Assignment_Statement (Loc,
-                         Name => New_Copy (Targ),
+                         Name       => New_Copy (Targ),
                          Expression => Expression (Return_Decl));
                   end if;
 
@@ -4011,7 +4017,6 @@ package body Exp_Ch6 is
            and then Nkind (Fst) = N_Assignment_Statement
            and then No (Next (Fst))
          then
-
             --  The function call may have been rewritten as the temporary
             --  that holds the result of the call, in which case remove the
             --  now useless declaration.
@@ -4080,6 +4085,7 @@ package body Exp_Ch6 is
 
       procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
          HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
+
       begin
          --  If there is a transient scope for N, this will be the scope of the
          --  actions for N, and the statements in Blk need to be within this
@@ -4161,7 +4167,6 @@ package body Exp_Ch6 is
    --  Start of processing for Expand_Inlined_Call
 
    begin
-
       --  Check for an illegal attempt to inline a recursive procedure. If the
       --  subprogram has parameters this is detected when trying to supply a
       --  binding for parameters that already have one. For parameterless
@@ -4219,8 +4224,12 @@ package body Exp_Ch6 is
       --  expansion of an extended return, the left-hand side provides bounds
       --  even if the return type is unconstrained.
 
-      if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement then
-         Targ1 := Defining_Identifier (First (Declarations (Blk)));
+      if Is_Unc then
+         if Nkind (Parent (N)) /= N_Assignment_Statement then
+            Targ1 := Defining_Identifier (First (Declarations (Blk)));
+         else
+            Targ1 := Name (Parent (N));
+         end if;
       end if;
 
       --  If this is a derived function, establish the proper return type
@@ -4250,8 +4259,7 @@ package body Exp_Ch6 is
 
          if Is_Class_Wide_Type (Etype (F))
            or else (Is_Access_Type (Etype (F))
-                      and then
-                    Is_Class_Wide_Type (Designated_Type (Etype (F))))
+                     and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
          then
             Temp_Typ := Etype (F);
 
@@ -4259,7 +4267,6 @@ package body Exp_Ch6 is
            and then Etype (F) /= Base_Type (Etype (F))
          then
             Temp_Typ := Etype (F);
-
          else
             Temp_Typ := Etype (A);
          end if;
@@ -4285,13 +4292,13 @@ package body Exp_Ch6 is
 
            or else
              (Nkind_In (A, N_Real_Literal,
-                            N_Integer_Literal,
-                            N_Character_Literal)
-                and then not Address_Taken (F))
+                           N_Integer_Literal,
+                           N_Character_Literal)
+               and then not Address_Taken (F))
          then
             if Etype (F) /= Etype (A) then
                Set_Renamed_Object
-                (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
+                 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
             else
                Set_Renamed_Object (F, A);
             end if;
@@ -4337,9 +4344,9 @@ package body Exp_Ch6 is
             if Ekind (F) = E_In_Parameter
               and then not Is_By_Reference_Type (Etype (A))
               and then
-               (not Is_Array_Type (Etype (A))
-                 or else not Is_Object_Reference (A)
-                 or else Is_Bit_Packed_Array (Etype (A)))
+                (not Is_Array_Type (Etype (A))
+                  or else not Is_Object_Reference (A)
+                  or else Is_Bit_Packed_Array (Etype (A)))
             then
                Decl :=
                  Make_Object_Declaration (Loc,
@@ -4698,7 +4705,6 @@ package body Exp_Ch6 is
                Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
 
                --  Create the temporary, generate:
-               --
                --    Local_Id : Ptr_Typ;
 
                Local_Id := Make_Temporary (Loc, 'T');
@@ -4710,7 +4716,6 @@ package body Exp_Ch6 is
                      New_Reference_To (Ptr_Typ, Loc)));
 
                --  Allocate the object, generate:
-               --
                --    Local_Id := <Alloc_Expr>;
 
                Append_To (Stmts,
@@ -4758,7 +4763,6 @@ package body Exp_Ch6 is
             end;
 
          --  For all other cases, generate:
-         --
          --    Temp_Id := <Alloc_Expr>;
 
          else
diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb
index 7fc3e5e466e..59e63bde246 100644
--- a/gcc/ada/g-socket.adb
+++ b/gcc/ada/g-socket.adb
@@ -198,7 +198,7 @@ package body GNAT.Sockets is
    procedure Check_For_Fd_Set (Fd : Socket_Type);
    pragma Inline (Check_For_Fd_Set);
    --  Raise Constraint_Error if Fd is less than 0 or greater than or equal to
-   --  FD_SETSIZE.
+   --  FD_SETSIZE, on platforms where fd_set is a bitmap.
 
    --  Types needed for Datagram_Socket_Stream_Type
 
@@ -468,6 +468,32 @@ package body GNAT.Sockets is
       end if;
    end Bind_Socket;
 
+   ----------------------
+   -- Check_For_Fd_Set --
+   ----------------------
+
+   procedure Check_For_Fd_Set (Fd : Socket_Type) is
+      use SOSC;
+   begin
+      --  On Windows, fd_set is a FD_SETSIZE array of socket ids:
+      --  no check required. Warnings suppressed because condition
+      --  is known at compile time.
+
+      pragma Warnings (Off);
+      if Target_OS = Windows then
+         pragma Warnings (On);
+
+         return;
+
+      --  On other platforms, fd_set is an FD_SETSIZE bitmap: check
+      --  that Fd is within range (otherwise behaviour is undefined).
+
+      elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then
+         raise Constraint_Error with "invalid value for socket set: "
+                                       & Image (Fd);
+      end if;
+   end Check_For_Fd_Set;
+
    --------------------
    -- Check_Selector --
    --------------------
@@ -573,18 +599,6 @@ package body GNAT.Sockets is
       Narrow (E_Socket_Set);
    end Check_Selector;
 
-   ----------------------
-   -- Check_For_Fd_Set --
-   ----------------------
-
-   procedure Check_For_Fd_Set (Fd : Socket_Type) is
-   begin
-      if Fd < 0 or else Fd >= SOSC.FD_SETSIZE then
-         raise Constraint_Error with "invalid value for socket set: "
-                                       & Image (Fd);
-      end if;
-   end Check_For_Fd_Set;
-
    -----------
    -- Clear --
    -----------
diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb
index 88f4571f61e..f6e9a64cdc7 100644
--- a/gcc/ada/s-taprop-dummy.adb
+++ b/gcc/ada/s-taprop-dummy.adb
@@ -46,6 +46,13 @@ package body System.Task_Primitives.Operations is
    pragma Warnings (Off);
    --  Turn off warnings since so many unreferenced parameters
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ----------------
    -- Abort_Task --
    ----------------
@@ -252,15 +259,6 @@ package body System.Task_Primitives.Operations is
       return 0.0;
    end Monotonic_Clock;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    ---------------
    -- Read_Lock --
    ---------------
diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb
index 6bc89fc087a..346de43ba05 100644
--- a/gcc/ada/s-taprop-hpux-dce.adb
+++ b/gcc/ada/s-taprop-hpux-dce.adb
@@ -39,7 +39,6 @@ pragma Polling (Off);
 --  operations. It causes infinite loops and other problems.
 
 with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
 
 with Interfaces.C;
 
@@ -130,6 +129,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -696,15 +702,6 @@ package body System.Task_Primitives.Operations is
       Specific.Set (Self_ID);
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -839,12 +836,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : Interfaces.C.int;
-      Tmp     : Task_Id := T;
-      Is_Self : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : Interfaces.C.int;
 
    begin
       if not Single_Lock then
@@ -859,11 +851,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      Free (Tmp);
-
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb
index bfa425e9b45..26469049920 100644
--- a/gcc/ada/s-taprop-irix.adb
+++ b/gcc/ada/s-taprop-irix.adb
@@ -39,7 +39,6 @@ pragma Polling (Off);
 --  operations. It causes infinite loops and other problems.
 
 with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
 
 with Interfaces.C;
 
@@ -127,6 +126,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -699,15 +705,6 @@ package body System.Task_Primitives.Operations is
       end if;
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -901,12 +898,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : Interfaces.C.int;
-      Tmp     : Task_Id := T;
-      Is_Self : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : Interfaces.C.int;
 
    begin
       if not Single_Lock then
@@ -921,11 +913,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      Free (Tmp);
-
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb
index 8d381ab9564..84c663a282a 100644
--- a/gcc/ada/s-taprop-linux.adb
+++ b/gcc/ada/s-taprop-linux.adb
@@ -38,8 +38,6 @@ pragma Polling (Off);
 --  Turn off polling, we do not want ATC polling to take place during tasking
 --  operations. It causes infinite loops and other problems.
 
-with Ada.Unchecked_Deallocation;
-
 with Interfaces.C;
 
 with System.Task_Info;
@@ -137,6 +135,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -731,15 +736,6 @@ package body System.Task_Primitives.Operations is
       end if;
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -978,12 +974,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : Interfaces.C.int;
-      Tmp     : Task_Id := T;
-      Is_Self : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : Interfaces.C.int;
 
    begin
       if not Single_Lock then
@@ -999,11 +990,8 @@ package body System.Task_Primitives.Operations is
       end if;
 
       SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access);
-      Free (Tmp);
 
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb
index ab66a889741..d26568f4522 100644
--- a/gcc/ada/s-taprop-mingw.adb
+++ b/gcc/ada/s-taprop-mingw.adb
@@ -38,8 +38,6 @@ pragma Polling (Off);
 --  Turn off polling, we do not want ATC polling to take place during tasking
 --  operations. It causes infinite loops and other problems.
 
-with Ada.Unchecked_Deallocation;
-
 with Interfaces.C;
 with Interfaces.C.Strings;
 
@@ -176,6 +174,13 @@ package body System.Task_Primitives.Operations is
 
    end Specific;
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -820,15 +825,6 @@ package body System.Task_Primitives.Operations is
          Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -987,13 +983,8 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Self_ID   : Task_Id := T;
       Result    : DWORD;
       Succeeded : BOOL;
-      Is_Self   : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 
    begin
       if not Single_Lock then
@@ -1017,11 +1008,7 @@ package body System.Task_Primitives.Operations is
          pragma Assert (Succeeded = Win32.TRUE);
       end if;
 
-      Free (Self_ID);
-
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb
index 440d94149b9..eb1b77147ec 100644
--- a/gcc/ada/s-taprop-posix.adb
+++ b/gcc/ada/s-taprop-posix.adb
@@ -45,7 +45,6 @@ pragma Polling (Off);
 --  operations. It causes infinite loops and other problems.
 
 with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
 
 with Interfaces.C;
 
@@ -144,6 +143,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -782,15 +788,6 @@ package body System.Task_Primitives.Operations is
       end if;
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -1000,12 +997,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : Interfaces.C.int;
-      Tmp     : Task_Id := T;
-      Is_Self : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : Interfaces.C.int;
 
    begin
       if not Single_Lock then
@@ -1020,11 +1012,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      Free (Tmp);
-
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb
index 421c60e219e..b5fe1ee9d42 100644
--- a/gcc/ada/s-taprop-solaris.adb
+++ b/gcc/ada/s-taprop-solaris.adb
@@ -38,8 +38,6 @@ pragma Polling (Off);
 --  Turn off polling, we do not want ATC polling to take place during tasking
 --  operations. It causes infinite loops and other problems.
 
-with Ada.Unchecked_Deallocation;
-
 with Interfaces.C;
 
 with System.Multiprocessors;
@@ -226,6 +224,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -868,26 +873,15 @@ package body System.Task_Primitives.Operations is
    procedure Enter_Task (Self_ID : Task_Id) is
    begin
       Self_ID.Common.LL.Thread := thr_self;
-
-      Self_ID.Common.LL.LWP := lwp_self;
+      Self_ID.Common.LL.LWP    := lwp_self;
 
       Set_Task_Affinity (Self_ID);
-
       Specific.Set (Self_ID);
 
       --  We need the above code even if we do direct fetch of Task_Id in Self
       --  for the main task on Sun, x86 Solaris and for gcc 2.7.2.
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -1032,12 +1026,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : Interfaces.C.int;
-      Tmp     : Task_Id := T;
-      Is_Self : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : Interfaces.C.int;
 
    begin
       T.Common.LL.Thread := Null_Thread_Id;
@@ -1054,11 +1043,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      Free (Tmp);
-
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb
index 2fe24419f3d..b0b727d9bb1 100644
--- a/gcc/ada/s-taprop-tru64.adb
+++ b/gcc/ada/s-taprop-tru64.adb
@@ -38,8 +38,6 @@ pragma Polling (Off);
 --  Turn off polling, we do not want ATC polling to take place during tasking
 --  operations. It causes infinite loops and other problems.
 
-with Ada.Unchecked_Deallocation;
-
 with Interfaces;
 with Interfaces.C;
 
@@ -127,6 +125,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -695,15 +700,6 @@ package body System.Task_Primitives.Operations is
       Specific.Set (Self_ID);
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -930,12 +926,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : Interfaces.C.int;
-      Tmp     : Task_Id := T;
-      Is_Self : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : Interfaces.C.int;
 
    begin
       if not Single_Lock then
@@ -950,11 +941,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      Free (Tmp);
-
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb
index 1cfafbbb55a..92b6023bdff 100644
--- a/gcc/ada/s-taprop-vms.adb
+++ b/gcc/ada/s-taprop-vms.adb
@@ -39,7 +39,6 @@ pragma Polling (Off);
 --  operations. It causes infinite loops and other problems.
 
 with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
 
 with Interfaces.C;
 
@@ -114,6 +113,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -680,15 +686,6 @@ package body System.Task_Primitives.Operations is
       Specific.Set (Self_ID);
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -839,12 +836,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : Interfaces.C.int;
-      Tmp     : Task_Id := T;
-      Is_Self : constant Boolean := T = Self;
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : Interfaces.C.int;
 
    begin
       if not Single_Lock then
@@ -859,11 +851,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      Free (Tmp);
-
-      if Is_Self then
-         Specific.Set (null);
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb
index ae286498d5c..6b3c35eafe3 100644
--- a/gcc/ada/s-taprop-vxworks.adb
+++ b/gcc/ada/s-taprop-vxworks.adb
@@ -39,7 +39,6 @@ pragma Polling (Off);
 --  operations. It causes infinite loops and other problems.
 
 with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
 
 with Interfaces.C;
 
@@ -140,6 +139,13 @@ package body System.Task_Primitives.Operations is
    package body Specific is separate;
    --  The body of this package is target specific
 
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package body ATCB_Allocation is separate;
+   --  The body of this package is shared across several targets
+
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
@@ -828,15 +834,6 @@ package body System.Task_Primitives.Operations is
       end if;
    end Enter_Task;
 
-   --------------
-   -- New_ATCB --
-   --------------
-
-   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
-   begin
-      return new Ada_Task_Control_Block (Entry_Num);
-   end New_ATCB;
-
    -------------------
    -- Is_Valid_Task --
    -------------------
@@ -986,12 +983,7 @@ package body System.Task_Primitives.Operations is
    ------------------
 
    procedure Finalize_TCB (T : Task_Id) is
-      Result  : int;
-      Tmp     : Task_Id          := T;
-      Is_Self : constant Boolean := (T = Self);
-
-      procedure Free is new
-        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+      Result : int;
 
    begin
       if not Single_Lock then
@@ -1008,11 +1000,7 @@ package body System.Task_Primitives.Operations is
          Known_Tasks (T.Known_Tasks_Index) := null;
       end if;
 
-      Free (Tmp);
-
-      if Is_Self then
-         Specific.Delete;
-      end if;
+      ATCB_Allocation.Free_ATCB (T);
    end Finalize_TCB;
 
    ---------------
diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads
index feb6f558c1f..12fbd71386e 100644
--- a/gcc/ada/s-taprop.ads
+++ b/gcc/ada/s-taprop.ads
@@ -87,9 +87,24 @@ package System.Task_Primitives.Operations is
    --  The effects of further calls to operations defined below on the task
    --  are undefined thereafter.
 
-   function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id;
-   pragma Inline (New_ATCB);
-   --  Allocate a new ATCB with the specified number of entries
+   ----------------------------------
+   -- ATCB allocation/deallocation --
+   ----------------------------------
+
+   package ATCB_Allocation is
+
+      function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id;
+      pragma Inline (New_ATCB);
+      --  Allocate a new ATCB with the specified number of entries
+
+      procedure Free_ATCB (T : ST.Task_Id);
+      pragma Inline (Free_ATCB);
+      --  Deallocate an ATCB previously allocated by New_ATCB
+
+   end ATCB_Allocation;
+
+   function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id
+     renames ATCB_Allocation.New_ATCB;
 
    procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean);
    pragma Inline (Initialize_TCB);
diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads
index 8b4e61a89c1..d31313708f7 100644
--- a/gcc/ada/s-taskin.ads
+++ b/gcc/ada/s-taskin.ads
@@ -1150,6 +1150,12 @@ package System.Tasking is
       --
       --  Protection: Self.L. Once a task has set Self.Stage to Completing, it
       --  has exclusive access to this field.
+
+      Free_On_Termination : Boolean := False;
+      --  Deallocate the ATCB when the task terminates. This flag is normally
+      --  False, and is set True when Unchecked_Deallocation is called on a
+      --  non-terminated task so that the associated storage is automatically
+      --  reclaimed when the task terminates.
    end record;
 
    --------------------
diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb
index bf1cc3570f8..6449bf6b017 100644
--- a/gcc/ada/s-tassta.adb
+++ b/gcc/ada/s-tassta.adb
@@ -969,12 +969,11 @@ package body System.Tasking.Stages is
          Free_Entry_Names (T);
          System.Task_Primitives.Operations.Finalize_TCB (T);
 
-      --  If the task is not terminated, then we simply ignore the call. This
-      --  happens when a user program attempts an unchecked deallocation on
-      --  a non-terminated task.
-
       else
-         null;
+         --  If the task is not terminated, then mark the task as to be freed
+         --  upon termination.
+
+         T.Free_On_Termination := True;
       end if;
    end Free_Task;
 
@@ -1429,6 +1428,7 @@ package body System.Tasking.Stages is
    procedure Terminate_Task (Self_ID : Task_Id) is
       Environment_Task : constant Task_Id := STPO.Environment_Task;
       Master_of_Task   : Integer;
+      Deallocate       : Boolean;
 
    begin
       Debug.Task_Termination_Hook;
@@ -1474,6 +1474,7 @@ package body System.Tasking.Stages is
       Stack_Guard (Self_ID, False);
 
       Utilities.Make_Passive (Self_ID, Task_Completed => True);
+      Deallocate := Self_ID.Free_On_Termination;
 
       if Single_Lock then
          Unlock_RTS;
@@ -1485,7 +1486,12 @@ package body System.Tasking.Stages is
       Initialization.Final_Task_Unlock (Self_ID);
 
       --  WARNING: past this point, this thread must assume that the ATCB has
-      --  been deallocated. It should not be accessed again.
+      --  been deallocated, and can't access it anymore (which is why we have
+      --  saved the Free_On_Termination flag in a temporary variable).
+
+      if Deallocate then
+         Free_Task (Self_ID);
+      end if;
 
       if Master_of_Task > 0 then
          STPO.Exit_Task;
diff --git a/gcc/ada/s-tpoaal.adb b/gcc/ada/s-tpoaal.adb
new file mode 100644
index 00000000000..0e79f457068
--- /dev/null
+++ b/gcc/ada/s-tpoaal.adb
@@ -0,0 +1,79 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--             SYSTEM.TASK_PRIMITIVES.OPERATIONS.ATCB_ALLOCATION            --
+--                                                                          --
+--                                  B o d y                                 --
+--                                                                          --
+--             Copyright (C) 2011, Free Software Foundation, Inc.           --
+--                                                                          --
+-- GNARL 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/>.                                          --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+separate (System.Task_Primitives.Operations)
+package body ATCB_Allocation is
+
+   ---------------
+   -- Free_ATCB --
+   ---------------
+
+   procedure Free_ATCB (T : Task_Id) is
+      Tmp     : Task_Id := T;
+      Is_Self : constant Boolean := T = Self;
+
+      procedure Free is new
+        Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+
+   begin
+      if Is_Self then
+         declare
+            Local_ATCB : aliased Ada_Task_Control_Block (0);
+            --  Create a dummy ATCB and initialize it minimally so that "Free"
+            --  can still call Self and Defer/Undefer_Abort after Tmp is freed
+            --  by the underlying memory management library.
+
+         begin
+            Local_ATCB.Common.LL.Thread        := T.Common.LL.Thread;
+            Local_ATCB.Common.Current_Priority := T.Common.Current_Priority;
+
+            Specific.Set (Local_ATCB'Unchecked_Access);
+            Free (Tmp);
+            Specific.Set (null);
+         end;
+
+      else
+         Free (Tmp);
+      end if;
+   end Free_ATCB;
+
+   --------------
+   -- New_ATCB --
+   --------------
+
+   function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
+   begin
+      return new Ada_Task_Control_Block (Entry_Num);
+   end New_ATCB;
+
+end ATCB_Allocation;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index fe2b82bdf1a..2655b25eddf 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1289,25 +1289,9 @@ package body Sem_Ch13 is
                when Aspect_Invariant      |
                     Aspect_Type_Invariant =>
 
-                  --  Check placement legality: An invariant must apply to a
-                  --  private type, or appear in the private part of a spec.
-                  --  Analysis of the pragma will verify that in the private
-                  --  part it applies to a completion.
-
-                  if Nkind_In (N, N_Private_Type_Declaration,
-                                  N_Private_Extension_Declaration)
-                  then
-                     null;
-
-                  elsif Nkind (N) = N_Full_Type_Declaration
-                    and then In_Private_Part (Current_Scope)
-                  then
-                     null;
-
-                  else
-                     Error_Msg_N
-                       ("invariant aspect must apply to a private type", N);
-                  end if;
+                  --  Analysis of the pragma will verify placement legality:
+                  --  an invariant must apply to a private type, or appear in
+                  --  the private part of a spec and apply to a completion.
 
                   --  Construct the pragma
 
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 796f9b07f71..6c561dafc71 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -1859,9 +1859,12 @@ package body Sem_Ch8 is
               Statements (Handled_Statement_Sequence (New_Body)));
 
             --  The generated body does not freeze. It is analyzed when the
-            --  generated operation is frozen.
+            --  generated operation is frozen. This body is only needed if
+            --  expansion is enabled.
 
-            Append_Freeze_Action (Defining_Entity (New_Decl), New_Body);
+            if Expander_Active then
+               Append_Freeze_Action (Defining_Entity (New_Decl), New_Body);
+            end if;
 
             Result := Defining_Entity (New_Decl);
          end if;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 0c204cd29cb..2ca94177c44 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -29,63 +29,65 @@
 --  to complete the syntax checks. Certain pragmas are handled partially or
 --  completely by the parser (see Par.Prag for further details).
 
-with Atree;    use Atree;
-with Casing;   use Casing;
-with Checks;   use Checks;
-with Csets;    use Csets;
-with Debug;    use Debug;
-with Einfo;    use Einfo;
-with Elists;   use Elists;
-with Errout;   use Errout;
-with Exp_Dist; use Exp_Dist;
-with Exp_Util; use Exp_Util;
-with Freeze;   use Freeze;
-with Lib;      use Lib;
-with Lib.Writ; use Lib.Writ;
-with Lib.Xref; use Lib.Xref;
-with Namet.Sp; use Namet.Sp;
-with Nlists;   use Nlists;
-with Nmake;    use Nmake;
-with Opt;      use Opt;
-with Output;   use Output;
-with Par_SCO;  use Par_SCO;
-with Restrict; use Restrict;
-with Rident;   use Rident;
-with Rtsfind;  use Rtsfind;
-with Sem;      use Sem;
-with Sem_Aux;  use Sem_Aux;
-with Sem_Ch3;  use Sem_Ch3;
-with Sem_Ch6;  use Sem_Ch6;
-with Sem_Ch8;  use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Intr; use Sem_Intr;
-with Sem_Mech; use Sem_Mech;
-with Sem_Res;  use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_VFpt; use Sem_VFpt;
-with Sem_Warn; use Sem_Warn;
-with Stand;    use Stand;
-with Sinfo;    use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Sinput;   use Sinput;
-with Snames;   use Snames;
-with Stringt;  use Stringt;
-with Stylesw;  use Stylesw;
+with System.Case_Util;
+
+with Atree;            use Atree;
+with Casing;           use Casing;
+with Checks;           use Checks;
+with Csets;            use Csets;
+with Debug;            use Debug;
+with Einfo;            use Einfo;
+with Elists;           use Elists;
+with Errout;           use Errout;
+with Exp_Dist;         use Exp_Dist;
+with Exp_Util;         use Exp_Util;
+with Freeze;           use Freeze;
+with Lib;              use Lib;
+with Lib.Writ;         use Lib.Writ;
+with Lib.Xref;         use Lib.Xref;
+with Namet.Sp;         use Namet.Sp;
+with Nlists;           use Nlists;
+with Nmake;            use Nmake;
+with Opt;              use Opt;
+with Output;           use Output;
+with Par_SCO;          use Par_SCO;
+with Restrict;         use Restrict;
+with Rident;           use Rident;
+with Rtsfind;          use Rtsfind;
+with Sem;              use Sem;
+with Sem_Aux;          use Sem_Aux;
+with Sem_Ch3;          use Sem_Ch3;
+with Sem_Ch6;          use Sem_Ch6;
+with Sem_Ch8;          use Sem_Ch8;
+with Sem_Ch12;         use Sem_Ch12;
+with Sem_Ch13;         use Sem_Ch13;
+with Sem_Disp;         use Sem_Disp;
+with Sem_Dist;         use Sem_Dist;
+with Sem_Elim;         use Sem_Elim;
+with Sem_Eval;         use Sem_Eval;
+with Sem_Intr;         use Sem_Intr;
+with Sem_Mech;         use Sem_Mech;
+with Sem_Res;          use Sem_Res;
+with Sem_Type;         use Sem_Type;
+with Sem_Util;         use Sem_Util;
+with Sem_VFpt;         use Sem_VFpt;
+with Sem_Warn;         use Sem_Warn;
+with Stand;            use Stand;
+with Sinfo;            use Sinfo;
+with Sinfo.CN;         use Sinfo.CN;
+with Sinput;           use Sinput;
+with Snames;           use Snames;
+with Stringt;          use Stringt;
+with Stylesw;          use Stylesw;
 with Table;
-with Targparm; use Targparm;
-with Tbuild;   use Tbuild;
+with Targparm;         use Targparm;
+with Tbuild;           use Tbuild;
 with Ttypes;
-with Uintp;    use Uintp;
-with Uname;    use Uname;
-with Urealp;   use Urealp;
-with Validsw;  use Validsw;
-with Warnsw;   use Warnsw;
+with Uintp;            use Uintp;
+with Uname;            use Uname;
+with Urealp;           use Urealp;
+with Validsw;          use Validsw;
+with Warnsw;           use Warnsw;
 
 package body Sem_Prag is
 
@@ -646,6 +648,17 @@ package body Sem_Prag is
       --  Similar to above form of Error_Pragma_Arg except that two messages
       --  are provided, the second is a continuation comment starting with \.
 
+      procedure Error_Pragma_Arg_Alternate_Name
+        (Msg      : String;
+         Arg      : Node_Id;
+         Alt_Name : Name_Id);
+      pragma No_Return (Error_Pragma_Arg_Alternate_Name);
+      --  Outputs error message for current pragma, similar to
+      --  Error_Pragma_Arg, except the source name of the aspect/pragma to use
+      --  in warnings may be equal to Alt_Name (which should be equivalent to
+      --  the name used in pragma). The location for the source name should be
+      --  pointed to by Arg.
+
       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
       pragma No_Return (Error_Pragma_Arg_Ident);
       --  Outputs error message for current pragma. The message may contain
@@ -2427,6 +2440,34 @@ package body Sem_Prag is
          Error_Pragma_Arg (Msg2, Arg);
       end Error_Pragma_Arg;
 
+      -------------------------------------
+      -- Error_Pragma_Arg_Alternate_Name --
+      -------------------------------------
+
+      procedure Error_Pragma_Arg_Alternate_Name
+        (Msg      : String;
+         Arg      : Node_Id;
+         Alt_Name : Name_Id)
+      is
+         MsgF        : String := Msg;
+         Source_Name : String := Exact_Source_Name (Sloc (Arg));
+         Alter_Name  : String := Get_Name_String (Alt_Name);
+
+      begin
+         System.Case_Util.To_Lower (Source_Name);
+         System.Case_Util.To_Lower (Alter_Name);
+
+         if Source_Name = Alter_Name then
+            Error_Msg_Name_1 := Alt_Name;
+         else
+            Error_Msg_Name_1 := Pname;
+         end if;
+
+         Fix_Error (MsgF);
+         Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
+         raise Pragma_Exit;
+      end Error_Pragma_Arg_Alternate_Name;
+
       ----------------------------
       -- Error_Pragma_Arg_Ident --
       ----------------------------
@@ -10140,9 +10181,16 @@ package body Sem_Prag is
             then
                null;
 
+            elsif In_Private_Part (Current_Scope) then
+               Error_Pragma_Arg_Alternate_Name
+                 ("pragma% only allowed for private type " &
+                  "declared in visible part", Arg1,
+                  Alt_Name => Name_Type_Invariant);
+
             else
-               Error_Pragma_Arg
-                 ("pragma% only allowed for private type", Arg1);
+               Error_Pragma_Arg_Alternate_Name
+                 ("pragma% only allowed for private type", Arg1,
+                  Alt_Name => Name_Type_Invariant);
             end if;
 
             --  Note that the type has at least one invariant, and also that