[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

1 files changed, 17 insertions, 2 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index ec4e96f..601b932 100644
--- 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.