ada: Accessibility code reorganization and bug fixes

This patch performs a large reorganization of accessibility related sources,
and also corrects some latent issues with accessibility checks - namely the
calculation of accessibility levels for expanded iterators and type
conversions.

gcc/ada/
	* accessibility.adb, accessibility.ads
	(Accessibility_Message): Moved from sem_attr.
	(Apply_Accessibility_Check): Moved from checks.
	(Apply_Accessibility_Check_For_Allocator): Moved from exp_ch4 and
	renamed
	(Check_Return_Construct_Accessibility): Moved from sem_ch6.
	(Innermost_Master_Scope_Depth): Moved from sem_util. Add condition
	to detect expanded iterators.
	(Prefix_With_Safe_Accessibility_Level): Moved from sem_attr.
	(Static_Accessibility_Level): Moved from sem_util.
	(Has_Unconstrained_Access_Discriminants): Likewise.
	(Has_Anonymous_Access_Discriminant): Likewise.
	(Is_Anonymous_Access_Actual): Likewise.
	(Is_Special_Aliased_Formal_Access): Likewise.
	(Needs_Result_Accessibility_Level): Likewise.
	(Subprogram_Access_Level): Likewise.
	(Type_Access_Level): Likewise.
	(Deepest_Type_Access_Level): Likewise.
	(Effective_Extra_Accessibility): Likewise.
	(Get_Dynamic_Accessibility): Likewise.
	(Has_Access_Values): Likewise.
	(Accessibility_Level): Likewise.
	* exp_attr.adb (Access_Cases): Obtain the proper enclosing object
	which applies to a given 'Access by looking through type
	conversions.
	* exp_ch4.adb (Apply_Accessibility_Check): Moved to accessibility.
	* exp_ch5.adb: Likewise.
	* exp_ch6.adb: Likewise.
	* exp_ch9.adb: Likewise.
	* exp_disp.adb: Likewise.
	* gen_il-fields.ads: Add new flag Comes_From_Iterator.
	* gen_il-gen-gen_nodes.adb: Add new flag Comes_From_Iterator for
	N_Object_Renaming_Declaration.
	* sem_ch5.adb (Analyze_Iterator_Specification): Mark object
	renamings resulting from iterator expansion with the new flag
	Comes_From_Iterator.
	* sem_aggr.adb (Resolve_Container_Aggregate): Refine test.
	* sem_ch13.adb: Add dependence on the accessibility package.
	* sem_ch3.adb: Likewise.
	* sem_ch4.adb: Likewise.
	* sem_ch9.adb: Likewise.
	* sem_res.adb: Likewise.
	* sem_warn.adb: Likewise.
	* exp_ch3.adb: Likewise.
	* sem_attr.adb (Accessibility_Message): Moved to accessibility.
	(Prefix_With_Safe_Accessibility_Level): Likewise.
	* checks.adb, checks.ads (Apply_Accessibility_Check): Likewise.
	* sem_ch6.adb (Check_Return_Construct_Accessibility): Likewise.
	* sem_util.adb, sem_util.ads
	(Accessibility_Level): Likewise.
	(Deepest_Type_Access_Level): Likewise.
	(Effective_Extra_Accessibility): Likewise.
	(Get_Dynamic_Accessibility): Likewise.
	(Has_Access_Values): Likewise.
	(Has_Anonymous_Access_Discriminant): Likewise.
	(Static_Accessibility_Level): Likewise.
	(Has_Unconstrained_Access_Discriminants): Likewise.
	(Is_Anonymous_Access_Actual): Likewise.
	(Is_Special_Aliased_Formal_Access): Likewise.
	(Needs_Result_Accessibility_Level): Likewise.
	(Subprogram_Access_Level): Likewise.
	(Type_Access_Level): Likewise.
	* sinfo.ads: Document new flag Comes_From_Iterator.
	* gcc-interface/Make-lang.in: Add entry for new Accessibility package.

1 files changed, 5 insertions, 128 deletions

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index cca6f6f..7c76f0f 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -25,6 +25,7 @@
 
 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
 
+with Accessibility;  use Accessibility;
 with Aspects;        use Aspects;
 with Atree;          use Atree;
 with Casing;         use Casing;
@@ -10936,72 +10937,12 @@ package body Sem_Attr is
       It       : Interp;
       Nom_Subt : Entity_Id;
 
-      procedure Accessibility_Message;
-      --  Error, or warning within an instance, if the static accessibility
-      --  rules of 3.10.2 are violated.
-
       function Declared_Within_Generic_Unit
         (Entity       : Entity_Id;
          Generic_Unit : Node_Id) return Boolean;
       --  Returns True if Declared_Entity is declared within the declarative
       --  region of Generic_Unit; otherwise returns False.
 
-      function Prefix_With_Safe_Accessibility_Level return Boolean;
-      --  Return True if the prefix does not have a value conversion of an
-      --  array because a value conversion is like an aggregate with respect
-      --  to determining accessibility level (RM 3.10.2); even if evaluation
-      --  of a value conversion is guaranteed to not create a new object,
-      --  accessibility rules are defined as if it might.
-
-      ---------------------------
-      -- Accessibility_Message --
-      ---------------------------
-
-      procedure Accessibility_Message is
-         Indic : Node_Id := Parent (Parent (N));
-
-      begin
-         --  In an instance, this is a runtime check, but one we
-         --  know will fail, so generate an appropriate warning.
-
-         if In_Instance_Body then
-            Error_Msg_Warn := SPARK_Mode /= On;
-            Error_Msg_F
-              ("non-local pointer cannot point to local object<<", P);
-            Error_Msg_F ("\Program_Error [<<", P);
-            Rewrite (N,
-              Make_Raise_Program_Error (Loc,
-                Reason => PE_Accessibility_Check_Failed));
-            Set_Etype (N, Typ);
-            return;
-
-         else
-            Error_Msg_F ("non-local pointer cannot point to local object", P);
-
-            --  Check for case where we have a missing access definition
-
-            if Is_Record_Type (Current_Scope)
-              and then
-                Nkind (Parent (N)) in N_Discriminant_Association
-                                    | N_Index_Or_Discriminant_Constraint
-            then
-               Indic := Parent (Parent (N));
-               while Present (Indic)
-                 and then Nkind (Indic) /= N_Subtype_Indication
-               loop
-                  Indic := Parent (Indic);
-               end loop;
-
-               if Present (Indic) then
-                  Error_Msg_NE
-                    ("\use an access definition for" &
-                     " the access discriminant of&",
-                     N, Entity (Subtype_Mark (Indic)));
-               end if;
-            end if;
-         end if;
-      end Accessibility_Message;
-
       ----------------------------------
       -- Declared_Within_Generic_Unit --
       ----------------------------------
@@ -11029,70 +10970,6 @@ package body Sem_Attr is
          return False;
       end Declared_Within_Generic_Unit;
 
-      ------------------------------------------
-      -- Prefix_With_Safe_Accessibility_Level --
-      ------------------------------------------
-
-      function Prefix_With_Safe_Accessibility_Level return Boolean is
-         function Safe_Value_Conversions return Boolean;
-         --  Return False if the prefix has a value conversion of an array type
-
-         ----------------------------
-         -- Safe_Value_Conversions --
-         ----------------------------
-
-         function Safe_Value_Conversions return Boolean is
-            PP : Node_Id := P;
-
-         begin
-            loop
-               if Nkind (PP) in N_Selected_Component | N_Indexed_Component then
-                  PP := Prefix (PP);
-
-               elsif Comes_From_Source (PP)
-                 and then Nkind (PP) in N_Type_Conversion
-                                      | N_Unchecked_Type_Conversion
-                 and then Is_Array_Type (Etype (PP))
-               then
-                  return False;
-
-               elsif Comes_From_Source (PP)
-                 and then Nkind (PP) = N_Qualified_Expression
-                 and then Is_Array_Type (Etype (PP))
-                 and then Nkind (Original_Node (Expression (PP))) in
-                            N_Aggregate | N_Extension_Aggregate
-               then
-                  return False;
-
-               else
-                  exit;
-               end if;
-            end loop;
-
-            return True;
-         end Safe_Value_Conversions;
-
-      --  Start of processing for Prefix_With_Safe_Accessibility_Level
-
-      begin
-         --  No check required for unchecked and unrestricted access
-
-         if Attr_Id = Attribute_Unchecked_Access
-           or else Attr_Id = Attribute_Unrestricted_Access
-         then
-            return True;
-
-         --  Check value conversions
-
-         elsif Ekind (Btyp) = E_General_Access_Type
-           and then not Safe_Value_Conversions
-         then
-            return False;
-         end if;
-
-         return True;
-      end Prefix_With_Safe_Accessibility_Level;
-
    --  Start of processing for Resolve_Attribute
 
    begin
@@ -11778,7 +11655,7 @@ package body Sem_Attr is
                       Intval (Accessibility_Level (P, Dynamic_Level))
                         > Deepest_Type_Access_Level (Btyp)
                   then
-                     Accessibility_Message;
+                     Accessibility_Message (N, Typ);
                      return;
                   end if;
                end;
@@ -11804,7 +11681,7 @@ package body Sem_Attr is
                  and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
                  and then Attr_Id /= Attribute_Unrestricted_Access
                then
-                  Accessibility_Message;
+                  Accessibility_Message (N, Typ);
                   return;
 
                --  AI05-0225: If the context is not an access to protected
@@ -11963,8 +11840,8 @@ package body Sem_Attr is
             --  array type since a value conversion is like an aggregate with
             --  respect to determining accessibility level (RM 3.10.2).
 
-            if not Prefix_With_Safe_Accessibility_Level then
-               Accessibility_Message;
+            if not Prefix_With_Safe_Accessibility_Level (N, Typ) then
+               Accessibility_Message (N, Typ);
                return;
             end if;