[multiple changes]

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

	* sem_res.adb (Resolve_Allocator): Implement Ada2012-B052. Detect cases
	where an anonymous access discriminant of a limited designated type
	appears in a non-immutably limited discriminated type and issue an
	error message. Add local variable Desig_T and replace all occurrences
	of Designated_Type.

2011-08-29  Jose Ruiz  <ruiz@adacore.com>

	* a-rttiev.adb (Set_Handler): Update comment to indicate that our
	implementation is compliant to RM D.15(15/2) after the modification
	imposed by AI05-0094-1 (binding interpretation).

From-SVN: r178196

3 files changed, 47 insertions, 9 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 2606c50..d9c3a9f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_res.adb (Resolve_Allocator): Implement Ada2012-B052. Detect cases
+	where an anonymous access discriminant of a limited designated type
+	appears in a non-immutably limited discriminated type and issue an
+	error message. Add local variable Desig_T and replace all occurrences
+	of Designated_Type.
+
+2011-08-29  Jose Ruiz  <ruiz@adacore.com>
+
+	* a-rttiev.adb (Set_Handler): Update comment to indicate that our
+	implementation is compliant to RM D.15(15/2) after the modification
+	imposed by AI05-0094-1 (binding interpretation).
+
 2011-08-29  Robert Dewar  <dewar@adacore.com>
 
 	* exp_ch9.adb, s-tasren.adb, exp_sel.adb, exp_sel.ads, exp_ch11.adb,
diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb
index 1c1fe85..67b81c7 100644
--- a/gcc/ada/a-rttiev.adb
+++ b/gcc/ada/a-rttiev.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---           Copyright (C) 2005-2010, Free Software Foundation, Inc.        --
+--           Copyright (C) 2005-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- --
@@ -281,12 +281,15 @@ package body Ada.Real_Time.Timing_Events is
       Remove_From_Queue (Event'Unchecked_Access);
       Event.Handler := null;
 
-      --  RM D.15(15/2) requires that at this point, we check whether the time
+      --  RM D.15(15/2) required that at this point, we check whether the time
       --  has already passed, and if so, call Handler.all directly from here
-      --  instead of doing the enqueuing below. However, this causes a nasty
+      --  instead of doing the enqueuing below. However, this caused a nasty
       --  race condition and potential deadlock. If the current task has
       --  already locked the protected object of Handler.all, and the time has
-      --  passed, deadlock would occur. Therefore, we ignore the requirement.
+      --  passed, deadlock would occur. It has been fixed by AI05-0094-1, which
+      --  says that the handler should be executed as soon as possible, meaning
+      --  that the timing event will be executed after the protected action
+      --  finishes (Handler.all should not be called directly from here).
       --  The same comment applies to the other Set_Handler below.
 
       if Handler /= null then
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 51e4f43..b0ea74c 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4058,6 +4058,7 @@ package body Sem_Res is
    -----------------------
 
    procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
+      Desig_T  : constant Entity_Id := Designated_Type (Typ);
       E        : constant Node_Id := Expression (N);
       Subtyp   : Entity_Id;
       Discrim  : Entity_Id;
@@ -4160,7 +4161,7 @@ package body Sem_Res is
 
       if Nkind (E) = N_Qualified_Expression then
          if Is_Class_Wide_Type (Etype (E))
-           and then not Is_Class_Wide_Type (Designated_Type (Typ))
+           and then not Is_Class_Wide_Type (Desig_T)
            and then not In_Dispatching_Context
          then
             Error_Msg_N
@@ -4304,7 +4305,7 @@ package body Sem_Res is
       --  Expand_Allocator_Expression).
 
       if Ada_Version >= Ada_2005
-        and then Is_Class_Wide_Type (Designated_Type (Typ))
+        and then Is_Class_Wide_Type (Desig_T)
       then
          declare
             Exp_Typ : Entity_Id;
@@ -4366,7 +4367,7 @@ package body Sem_Res is
       --  type when restriction No_Task_Hierarchy applies.
 
       if not Is_Library_Level_Entity (Base_Type (Typ))
-        and then Has_Task (Base_Type (Designated_Type (Typ)))
+        and then Has_Task (Base_Type (Desig_T))
       then
          Check_Restriction (No_Task_Hierarchy, N);
       end if;
@@ -4383,6 +4384,26 @@ package body Sem_Res is
            and then Nkind (Associated_Node_For_Itype (Typ)) =
                       N_Discriminant_Specification
          then
+            declare
+               Discr : constant Entity_Id :=
+                         Defining_Identifier (Associated_Node_For_Itype (Typ));
+            begin
+               --  Ada2012-B052: If the designated type of the allocator is
+               --  limited, then the allocator shall not be used to define the
+               --  value of an access discriminant, unless the discriminated
+               --  type is immutably limited.
+
+               if Ada_Version >= Ada_2012
+                 and then Is_Limited_Type (Desig_T)
+                 and then not Is_Immutably_Limited_Type (Scope (Discr))
+               then
+                  Error_Msg_N
+                    ("only immutably limited types can have anonymous ", N);
+                  Error_Msg_N
+                    ("\discriminants of limited designated type", N);
+               end if;
+            end;
+
             --  Avoid marking an allocator as a dynamic coextension if it is
             --  within a static construct.
 
@@ -4402,8 +4423,8 @@ package body Sem_Res is
       --  its body has not been seen yet, and its activation will fail
       --  an elaboration check.
 
-      if Is_Task_Type (Designated_Type (Typ))
-        and then Scope (Base_Type (Designated_Type (Typ))) = Current_Scope
+      if Is_Task_Type (Desig_T)
+        and then Scope (Base_Type (Desig_T)) = Current_Scope
         and then Is_Compilation_Unit (Current_Scope)
         and then Ekind (Current_Scope) = E_Package
         and then not In_Package_Body (Current_Scope)