[Ada] Incorrect accessibility check

This patch fixes an issue whereby anonymous access result types were
treated as having the same accessibility level as typed results instead
of having the level determined by the "master of the call" as per RM
3.10.2 (10).

------------
-- Source --
------------

--  main.adb

with Pack_12; use Pack_12;
with Pack_05; use Pack_05;

procedure Main is
   Obj : aliased Integer;
begin
   Test_Alloc
     (new Rec_T'(Disc => Id_A (Obj'Access))); --  OK

   Id_A (Obj'Access).all := 0;                --  OK
   Id_B (Obj'Access).all := 0;                --  OK
   Id_C (Obj'Access).all := 0;                --  ERROR
end Main;

--  pack_12.ads

pragma Ada_2012;

with Ada.Unchecked_Conversion;

package Pack_12 is
   function Id_A (I : access Integer)
     return access Integer
     is (I);

   type Obj_Ptr is access all Integer;

   function Id_C (I : access Integer)
     return Obj_Ptr
     is (I.all'Access);

   type Rec_T (Disc : access Integer) is null record;

   procedure Test_Alloc (Access_Param : access Rec_T);
end Pack_12;

--  pack_12.adb

package body Pack_12 is
   Dummy : Integer;

   procedure Test_Alloc (Access_Param : access Rec_T) is
   begin
      Dummy := Access_Param.Disc.all;
   end Test_Alloc;
end Pack_12;

--  pack_05.ads

pragma Ada_2005;

with Pack_12; use Pack_12;

package Pack_05 is
   function Id_B (I : access Integer)
     return access Integer
     renames Id_A;
end Pack_05;

-----------------
-- Compilation --
-----------------

$ gnatmake -q main.adb
$ main
raised PROGRAM_ERROR : pack_12.ads:14 accessibility check failed

2019-07-05  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* checks.adb (Apply_Accessibility_Check): Add logic to fetch the
	function result accessibility level if one is required within
	the generated check.
	* exp_ch6.adb (Needs_Result_Accessibility_Level): Modify
	controlling elsif block to handle more cases such as anonymous
	access results and disable checking for coextensions.

From-SVN: r273130

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c875ac3b2c108bc4c2edf63faa3ff2e42ac1f531..8a729d1e1a5fbaf56d4de5b75432cc4e215cb243 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2019-07-05  Justin Squirek  <squirek@adacore.com>
+
+       * checks.adb (Apply_Accessibility_Check): Add logic to fetch the
+       function result accessibility level if one is required within
+       the generated check.
+       * exp_ch6.adb (Needs_Result_Accessibility_Level): Modify
+       controlling elsif block to handle more cases such as anonymous
+       access results and disable checking for coextensions.
+
 2019-07-05  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_ch9.adb (Analyze_Accept_Statement): If this is an illegal

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index ec4e96ff6132d1a61463eb2ffba62c23bc56641e..601b932a1f391d422a2f61b30b5f8a0cf437ab2c 100644 (file)
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -617,8 +617,23 @@ package body Checks is
          Param_Level :=
            New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
 
-         Type_Level :=
-           Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
+         --  Use the dynamic accessibility parameter for the function's result
+         --  when one has been created instead of statically referring to the
+         --  deepest type level so as to appropriatly handle the rules for
+         --  RM 3.10.2 (10.1/3).
+
+         if Ekind_In (Scope (Param_Ent), E_Function,
+                                         E_Operator,
+                                         E_Subprogram_Type)
+           and then Present (Extra_Accessibility_Of_Result (Scope (Param_Ent)))
+         then
+            Type_Level :=
+              New_Occurrence_Of
+                (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc);
+         else
+            Type_Level :=
+              Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
+         end if;
 
          --  Raise Program_Error if the accessibility level of the access
          --  parameter is deeper than the level of the target access type.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 6e7299a336318be336cd11d966414235f390680c..ae17a5bd68f26aa0e54e46b0dfc6df1c0a0bf6d4 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9236,8 +9236,9 @@ package body Exp_Ch6 is
          return False;
       end Has_Unconstrained_Access_Discriminant_Component;
 
-      Feature_Disabled : constant Boolean := True;
-      --  Temporary
+      Disable_Coextension_Cases : constant Boolean := True;
+      --  Flag used to temporarily disable a "True" result for types with
+      --  access discriminants and related coextension cases.
 
    --  Start of processing for Needs_Result_Accessibility_Level
 
@@ -9247,9 +9248,6 @@ package body Exp_Ch6 is
       if not Present (Func_Typ) then
          return False;
 
-      elsif Feature_Disabled then
-         return False;
-
       --  False if not a function, also handle enum-lit renames case
 
       elsif Func_Typ = Standard_Void_Type
@@ -9274,23 +9272,37 @@ package body Exp_Ch6 is
       elsif Ada_Version < Ada_2012 then
          return False;
 
-      elsif Ekind (Func_Typ) = E_Anonymous_Access_Type
-        or else Is_Tagged_Type (Func_Typ)
-      then
-         --  In the case of, say, a null tagged record result type, the need
-         --  for this extra parameter might not be obvious. This function
-         --  returns True for all tagged types for compatibility reasons.
-         --  A function with, say, a tagged null controlling result type might
-         --  be overridden by a primitive of an extension having an access
-         --  discriminant and the overrider and overridden must have compatible
-         --  calling conventions (including implicitly declared parameters).
-         --  Similarly, values of one access-to-subprogram type might designate
-         --  both a primitive subprogram of a given type and a function
-         --  which is, for example, not a primitive subprogram of any type.
-         --  Again, this requires calling convention compatibility.
-         --  It might be possible to solve these issues by introducing
-         --  wrappers, but that is not the approach that was chosen.
+      --  Handle the situation where a result is an anonymous access type
+      --  RM 3.10.2 (10.3/3).
+
+      elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then
+         return True;
+
+      --  The following cases are related to coextensions and do not fully
+      --  cover everything mentioned in RM 3.10.2 (12) ???
+
+      --  Temporarily disabled ???
+
+      elsif Disable_Coextension_Cases then
+         return False;
+
+      --  In the case of, say, a null tagged record result type, the need for
+      --  this extra parameter might not be obvious so this function returns
+      --  True for all tagged types for compatibility reasons.
+
+      --  A function with, say, a tagged null controlling result type might
+      --  be overridden by a primitive of an extension having an access
+      --  discriminant and the overrider and overridden must have compatible
+      --  calling conventions (including implicitly declared parameters).
+
+      --  Similarly, values of one access-to-subprogram type might designate
+      --  both a primitive subprogram of a given type and a function which is,
+      --  for example, not a primitive subprogram of any type. Again, this
+      --  requires calling convention compatibility. It might be possible to
+      --  solve these issues by introducing wrappers, but that is not the
+      --  approach that was chosen.
 
+      elsif Is_Tagged_Type (Func_Typ) then
          return True;
 
       elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then