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

	* exp_ch3.adb (Freeze_Type): Generate an accessibility check which
	ensures that the level of the subpool access type is not deeper than
	that of the pool object.
	* sem_util.adb (Object_Access_Level): Expand to handle defining
	identifiers.
	* sem_res.adb (Resolve_Allocator): Add a guard to avoid examining the
	subpool handle name of a rewritten allocator.

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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b2f77e1..acc215b 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_ch3.adb (Freeze_Type): Generate an accessibility check which
+       ensures that the level of the subpool access type is not deeper than
+       that of the pool object.
+       * sem_util.adb (Object_Access_Level): Expand to handle defining
+       identifiers.
+       * sem_res.adb (Resolve_Allocator): Add a guard to avoid examining the
+       subpool handle name of a rewritten allocator.
+
 2011-08-29  Robert Dewar  <dewar@adacore.com>
 
        * impunit.adb, exp_ch4.adb, s-finmas.adb: Minor reformatting.

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 8186530..c0112b1 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6605,12 +6605,65 @@ package body Exp_Ch3 is
             --    Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object"
             --    ---> Storage Pool is the specified one
 
-            elsif Present (Associated_Storage_Pool (Def_Id)) then
+            --  When compiling in Ada 2012 mode, ensure that the accessibility
+            --  level of the subpool access type is not deeper than that of the
+            --  pool_with_subpools.
 
-               --  Nothing to do the associated storage pool has been attached
-               --  when analyzing the representation clause.
+            elsif Ada_Version >= Ada_2012
+              and then Present (Associated_Storage_Pool (Def_Id))
+            then
+               declare
+                  Loc   : constant Source_Ptr := Sloc (Def_Id);
+                  Pool  : constant Entity_Id :=
+                            Associated_Storage_Pool (Def_Id);
+                  RSPWS : constant Entity_Id :=
+                            RTE (RE_Root_Storage_Pool_With_Subpools);
 
-               null;
+               begin
+                  --  It is known that the accessibility level of the access
+                  --  type is deeper than that of the pool.
+
+                  if Type_Access_Level (Def_Id) > Object_Access_Level (Pool)
+                    and then not Accessibility_Checks_Suppressed (Def_Id)
+                    and then not Accessibility_Checks_Suppressed (Pool)
+                  then
+                     --  Static case: the pool is known to be a descendant of
+                     --  Root_Storage_Pool_With_Subpools.
+
+                     if Is_Ancestor (RSPWS, Etype (Pool)) then
+                        Error_Msg_N
+                          ("?subpool access type has deeper accessibility " &
+                           "level than pool", Def_Id);
+
+                        Append_Freeze_Action (Def_Id,
+                          Make_Raise_Program_Error (Loc,
+                            Reason => PE_Accessibility_Check_Failed));
+
+                     --  Dynamic case: when the pool is of a class-wide type,
+                     --  it may or may not support subpools depending on the
+                     --  path of derivation. Generate:
+                     --
+                     --    if Def_Id in RSPWS'Class then
+                     --       raise Program_Error;
+                     --    end if;
+
+                     elsif Is_Class_Wide_Type (Etype (Pool)) then
+                        Append_Freeze_Action (Def_Id,
+                          Make_If_Statement (Loc,
+                            Condition =>
+                              Make_In (Loc,
+                                Left_Opnd =>
+                                  New_Reference_To (Pool, Loc),
+                                Right_Opnd =>
+                                  New_Reference_To
+                                    (Class_Wide_Type (RSPWS), Loc)),
+
+                            Then_Statements => New_List (
+                              Make_Raise_Program_Error (Loc,
+                                Reason => PE_Accessibility_Check_Failed))));
+                     end if;
+                  end if;
+               end;
             end if;
 
             --  For access-to-controlled types (including class-wide types and

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 0b04142..3670221 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4397,9 +4397,12 @@ package body Sem_Res is
 
       --  Ada 2012 (AI05-0111-3): Issue a warning whenever allocating a task
       --  or a type containing tasks on a subpool since the deallocation of
-      --  the subpool may lead to undefined task behavior.
+      --  the subpool may lead to undefined task behavior. Perform the check
+      --  only when the allocator has not been converted into a Program_Error
+      --  due to a previous error.
 
       if Ada_Version >= Ada_2012
+        and then Nkind (N) = N_Allocator
         and then Present (Subpool_Handle_Name (N))
         and then Has_Task (Desig_T)
       then

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index eab20bf..6f2ac14 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10696,8 +10696,14 @@ package body Sem_Util is
    --  Start of processing for Object_Access_Level
 
    begin
-      if Is_Entity_Name (Obj) then
-         E := Entity (Obj);
+      if Nkind (Obj) = N_Defining_Identifier
+        or else Is_Entity_Name (Obj)
+      then
+         if Nkind (Obj) = N_Defining_Identifier then
+            E := Obj;
+         else
+            E := Entity (Obj);
+         end if;
 
          if Is_Prival (E) then
             E := Prival_Link (E);