[Ada] Incremental patch for restriction No_Dynamic_Accessibility_Checks

gcc/ada/

	* sem_util.ads (Type_Access_Level): Add new optional parameter
	Assoc_Ent.
	* sem_util.adb (Accessibility_Level): Treat access discriminants
	the same as components when the restriction
	No_Dynamic_Accessibility_Checks is enabled.
	(Deepest_Type_Access_Level): Remove exception for
	Debug_Flag_Underscore_B when returning the result of
	Type_Access_Level in the case where
	No_Dynamic_Accessibility_Checks is active.
	(Function_Call_Or_Allocator_Level): Correctly calculate the
	level of Expr based on its containing subprogram instead of
	using Current_Subprogram.
	* sem_res.adb (Valid_Conversion): Add actual for new parameter
	Assoc_Ent in call to Type_Access_Level, and add test of
	No_Dynamic_Accessibility_Checks_Enabled to ensure that static
	accessibility checks are performed for all anonymous access type
	conversions.

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index e2c069c..03d747e 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -13734,11 +13734,16 @@ package body Sem_Res is
             --  the target type is anonymous access as well - see RM 3.10.2
             --  (10.3/3).
 
-            elsif Type_Access_Level (Opnd_Type) >
-                    Deepest_Type_Access_Level (Target_Type)
-              and then (Nkind (Associated_Node_For_Itype (Opnd_Type)) /=
-                         N_Function_Specification
-                        or else Ekind (Target_Type) in Anonymous_Access_Kind)
+            --  Note that when the restriction No_Dynamic_Accessibility_Checks
+            --  is in effect wei also want to proceed with the conversion check
+            --  described above.
+
+            elsif Type_Access_Level (Opnd_Type, Assoc_Ent => Operand)
+                    > Deepest_Type_Access_Level (Target_Type)
+              and then (Nkind (Associated_Node_For_Itype (Opnd_Type))
+                          /= N_Function_Specification
+                        or else Ekind (Target_Type) in Anonymous_Access_Kind
+                        or else No_Dynamic_Accessibility_Checks_Enabled (N))
 
               --  Check we are not in a return value ???
 

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 9cd5d14..5d0aa49 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -420,7 +420,7 @@ package body Sem_Util is
 
                else
                   return Make_Level_Literal
-                           (Subprogram_Access_Level (Current_Subprogram));
+                           (Subprogram_Access_Level (Entity (Name (N))));
                end if;
             end if;
 
@@ -791,12 +791,22 @@ package body Sem_Util is
             --  is an anonymous access type means that its associated
             --  level is that of the containing type - see RM 3.10.2 (16).
 
+            --  Note that when restriction No_Dynamic_Accessibility_Checks is
+            --  in effect we treat discriminant components as regular
+            --  components.
+
             elsif Nkind (E) = N_Selected_Component
               and then Ekind (Etype (E))   =  E_Anonymous_Access_Type
               and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type
-              and then not (Nkind (Selector_Name (E)) in N_Has_Entity
-                             and then Ekind (Entity (Selector_Name (E)))
-                                        = E_Discriminant)
+              and then (not (Nkind (Selector_Name (E)) in N_Has_Entity
+                              and then Ekind (Entity (Selector_Name (E)))
+                                         = E_Discriminant)
+
+                        --  The alternative accessibility models both treat
+                        --  discriminants as regular components.
+
+                        or else (No_Dynamic_Accessibility_Checks_Enabled (E)
+                                  and then Allow_Alt_Model))
             then
                --  When restriction No_Dynamic_Accessibility_Checks is active
                --  and -gnatd_b set, the level is that of the designated type.
@@ -7215,7 +7225,6 @@ package body Sem_Util is
 
          if Allow_Alt_Model
            and then No_Dynamic_Accessibility_Checks_Enabled (Typ)
-           and then not Debug_Flag_Underscore_B
          then
             return Type_Access_Level (Typ, Allow_Alt_Model);
          end if;
@@ -29157,7 +29166,8 @@ package body Sem_Util is
 
    function Type_Access_Level
      (Typ             : Entity_Id;
-      Allow_Alt_Model : Boolean := True) return Uint
+      Allow_Alt_Model : Boolean   := True;
+      Assoc_Ent       : Entity_Id := Empty) return Uint
    is
       Btyp    : Entity_Id := Base_Type (Typ);
       Def_Ent : Entity_Id;
@@ -29187,6 +29197,18 @@ package body Sem_Util is
                            (Designated_Type (Btyp), Allow_Alt_Model);
                end if;
 
+               --  When an anonymous access type's Assoc_Ent is specifiedi,
+               --  calculate the result based on the general accessibility
+               --  level routine.
+
+               --  We would like to use Associated_Node_For_Itype here instead,
+               --  but in some cases it is not fine grained enough ???
+
+               if Present (Assoc_Ent) then
+                  return Static_Accessibility_Level
+                           (Assoc_Ent, Object_Decl_Level);
+               end if;
+
                --  Otherwise take the context of the anonymous access type into
                --  account.
 

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 440ac80..b0d6a2a 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -3267,12 +3267,17 @@ package Sem_Util is
 
    function Type_Access_Level
      (Typ             : Entity_Id;
-      Allow_Alt_Model : Boolean := True) return Uint;
+      Allow_Alt_Model : Boolean   := True;
+      Assoc_Ent       : Entity_Id := Empty) return Uint;
    --  Return the accessibility level of Typ
 
    --  The Allow_Alt_Model parameter allows the alternative level calculation
    --  under the restriction No_Dynamic_Accessibility_Checks to be performed.
 
+   --  Assoc_Ent allows for the optional specification of the entity associated
+   --  with Typ. This gets utilized mostly for anonymous access type
+   --  processing, where context matters in interpreting Typ's level.
+
    function Type_Without_Stream_Operation
      (T  : Entity_Id;
       Op : TSS_Name_Type := TSS_Null) return Entity_Id;