[Ada] INOX: prototype alternative accessibility model

gcc/ada/

	* checks.adb (Accessibility_Checks_Suppressed): Add check
	against restriction No_Dynamic_Accessibility_Checks.
	(Apply_Accessibility_Check): Add assertion to check restriction
	No_Dynamic_Accessibility_Checks is not active.
	* debug.adb: Add documentation for new debugging switch to
	control which accessibility model gets employed under
	restriction No_Dynamic_Accessibility_Checks.
	* exp_attr.adb (Expand_N_Attribute_Reference): Disable dynamic
	accessibility check generation when
	No_Dynamic_Accessibility_Checks is active.
	* exp_ch4.adb (Apply_Accessibility_Check): Skip check generation
	when restriction No_Dynamic_Accessibility_Checks is active.
	(Expand_N_Allocator): Disable dynamic accessibility checks when
	No_Dynamic_Accessibility_Checks is active.
	(Expand_N_In): Disable dynamic accessibility checks when
	No_Dynamic_Accessibility_Checks is active.
	(Expand_N_Type_Conversion): Disable dynamic accessibility checks
	when No_Dynamic_Accessibility_Checks is active.
	* exp_ch5.adb (Expand_N_Assignment_Statement): Disable
	alternative accessibility model calculations when computing a
	dynamic level for a SAOAAT.
	* exp_ch6.adb (Add_Call_By_Copy_Code): Disable dynamic
	accessibility check generation when
	No_Dynamic_Accessibility_Checks is active.
	(Expand_Branch): Disable alternative accessibility model
	calculations.
	(Expand_Call_Helper): Disable alternative accessibility model
	calculations.
	* restrict.adb, restrict.ads: Add new restriction
	No_Dynamic_Accessibility_Checks.
	(No_Dynamic_Accessibility_Checks_Enabled): Created to test when
	experimental features (which are generally incompatible with
	standard Ada) can be enabled.
	* sem_attr.adb (Safe_Value_Conversions): Add handling of new
	accessibility model under the restriction
	No_Dynamic_Accessibility_Checks.
	* sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
	Disallow new restriction No_Dynamic_Accessibility_Checks from
	being exclusively specified within a body or subunit without
	being present in a specification.
	* sem_res.adb (Check_Fully_Declared_Prefix): Minor comment
	fixup.
	(Valid_Conversion): Omit implicit conversion checks on anonymous
	access types and perform static checking instead when
	No_Dynamic_Accessibility_Checks is active.
	* sem_util.adb, sem_util.ads (Accessibility_Level): Add special
	handling of anonymous access objects, formal parameters,
	anonymous access components, and function return objects.
	(Deepest_Type_Access_Level): When
	No_Dynamic_Accessibility_Checks is active employ an alternative
	model. Add paramter Allow_Alt_Model to override the new behavior
	in certain cases.
	(Type_Access_Level): When No_Dynamic_Accessibility_Checks is
	active employ an alternative model. Add parameter
	Allow_Alt_Model to override the new behavior in certain cases.
	(Typ_Access_Level): Created within Accessibility_Level for
	convenience.
	* libgnat/s-rident.ads, snames.ads-tmpl: Add handing for
	No_Dynamic_Accessibility_Checks.

1 files changed, 19 insertions, 4 deletions

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 0894d03..a49272e 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -65,15 +65,19 @@ package Sem_Util is
    function Accessibility_Level
      (Expr              : Node_Id;
       Level             : Accessibility_Level_Kind;
-      In_Return_Context : Boolean := False) return Node_Id;
+      In_Return_Context : Boolean := False;
+      Allow_Alt_Model   : Boolean := True) return Node_Id;
    --  Centralized accessibility level calculation routine for finding the
    --  accessibility level of a given expression Expr.
 
-   --  In_Return_Context forcing the Accessibility_Level calculations to be
+   --  In_Return_Context forces the Accessibility_Level calculations to be
    --  carried out "as if" Expr existed in a return value. This is useful for
    --  calculating the accessibility levels for discriminant associations
    --  and return aggregates.
 
+   --  The Allow_Alt_Model parameter allows the alternative level calculation
+   --  under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
    function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String;
    --  Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get
    --  the given string argument, adding leading and trailing asterisks if they
@@ -662,7 +666,10 @@ package Sem_Util is
    --  when pragma Restrictions (No_Finalization) applies, in which case we
    --  know that class-wide objects do not contain controlled parts.
 
-   function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint;
+   function Deepest_Type_Access_Level
+     (Typ             : Entity_Id;
+      Allow_Alt_Model : Boolean := True) return Uint;
+
    --  Same as Type_Access_Level, except that if the type is the type of an Ada
    --  2012 stand-alone object of an anonymous access type, then return the
    --  static accessibility level of the object. In that case, the dynamic
@@ -672,6 +679,9 @@ package Sem_Util is
    --  in the case of a descendant of a generic formal type (returns Int'Last
    --  instead of 0).
 
+   --  The Allow_Alt_Model parameter allows the alternative level calculation
+   --  under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
    function Defining_Entity (N : Node_Id) return Entity_Id;
    --  Given a declaration N, returns the associated defining entity. If the
    --  declaration has a specification, the entity is obtained from the
@@ -3246,9 +3256,14 @@ package Sem_Util is
    --  returned, i.e. Traverse_More_Func is called and the result is simply
    --  discarded.
 
-   function Type_Access_Level (Typ : Entity_Id) return Uint;
+   function Type_Access_Level
+     (Typ             : Entity_Id;
+      Allow_Alt_Model : Boolean := True) 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.
+
    function Type_Without_Stream_Operation
      (T  : Entity_Id;
       Op : TSS_Name_Type := TSS_Null) return Entity_Id;