[Ada] Wrong accessibility level under -gnat12

For an anonymous allocator whose type is that of a stand-alone object of
an anonymous access-to-object type, the accessibility level is that of
the declaration of the stand-alone object; however it was incorrectly
computed as being library level compiling under -gnat12 mode.

2019-07-05  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch4.adb (Expand_N_Type_Conversion): Do not apply an
	accessibility check when the conversion is an access to
	class-wide interface type and it is an actual parameter.
	* exp_ch6.adb (Expand_Call_Helper): Add documentation on the
	accessibility level of an anonymous allocator defining the value
	of an access parameter.
	* sem_util.ads, sem_util.adb (Dynamic_Accessibility_Level): Add
	support for an anonymous allocator whose type is that of a
	stand-alone object of an anonymous access to object type.

gcc/testsuite/

	* gnat.dg/access6.adb: New testcase.

From-SVN: r273115

gcc/ada/ChangeLog

+2019-07-05  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch4.adb (Expand_N_Type_Conversion): Do not apply an
+	accessibility check when the conversion is an access to
+	class-wide interface type and it is an actual parameter.
+	* exp_ch6.adb (Expand_Call_Helper): Add documentation on the
+	accessibility level of an anonymous allocator defining the value
+	of an access parameter.
+	* sem_util.ads, sem_util.adb (Dynamic_Accessibility_Level): Add
+	support for an anonymous allocator whose type is that of a
+	stand-alone object of an anonymous access to object type.
+
 2019-07-05  Piotr Trojanek  <trojanek@adacore.com>
 
 	* einfo.ads, sem_res.adb: Typo fixes in comments.

gcc/ada/exp_ch4.adb

@@ -11471,7 +11471,8 @@ package body Exp_Ch4 is
          then
             if not Comes_From_Source (N)
               and then Nkind_In (Parent (N), N_Function_Call,
-                                             N_Procedure_Call_Statement)
+                                             N_Procedure_Call_Statement,
+                                             N_Parameter_Association)
               and then Is_Interface (Designated_Type (Target_Type))
               and then Is_Class_Wide_Type (Designated_Type (Target_Type))
             then

gcc/ada/exp_ch6.adb

@@ -3271,7 +3271,10 @@ package body Exp_Ch6 is
 
                   --  For allocators we pass the level of the execution of the
                   --  called subprogram, which is one greater than the current
-                  --  scope level.
+                  --  scope level. However, according to RM 3.10.2(14/3) this
+                  --  is wrong since for an anonymous allocator defining the
+                  --  value of an access parameter, the accessibility level is
+                  --  that of the innermost master of the call???
 
                   when N_Allocator =>
                      Add_Extra_Actual

gcc/ada/sem_util.adb

@@ -6452,8 +6452,8 @@ package body Sem_Util is
    -- Dynamic_Accessibility_Level --
    ---------------------------------
 
-   function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
-      Loc : constant Source_Ptr := Sloc (Expr);
+   function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id is
+      Loc : constant Source_Ptr := Sloc (N);
 
       function Make_Level_Literal (Level : Uint) return Node_Id;
       --  Construct an integer literal representing an accessibility level
@@ -6473,7 +6473,12 @@ package body Sem_Util is
 
       --  Local variables
 
-      E : Entity_Id;
+      Expr : constant Node_Id := Original_Node (N);
+      --  Expr references the original node because at this stage N may be the
+      --  reference to a variable internally created by the frontend to remove
+      --  side effects of an expression.
+
+      E    : Entity_Id;
 
    --  Start of processing for Dynamic_Accessibility_Level
 
@@ -6530,12 +6535,66 @@ package body Sem_Util is
 
          when N_Allocator =>
 
-            --  Unimplemented: depends on context. As an actual parameter where
-            --  formal type is anonymous, use
-            --    Scope_Depth (Current_Scope) + 1.
-            --  For other cases, see 3.10.2(14/3) and following. ???
+            --  This is not fully implemented since it depends on context (see
+            --  3.10.2(14/3-14.2/3). More work is needed in the following cases
+            --
+            --  1) For an anonymous allocator defining the value of an access
+            --     parameter, the accessibility level is that of the innermost
+            --     master of the call; however currently we pass the level of
+            --     execution of the called subprogram, which is one greater
+            --     than the current scope level (see Expand_Call_Helper).
+            --
+            --     For example, a statement is a master and a declaration is
+            --     not a master; so we should not pass in the same level for
+            --     the following cases:
+            --
+            --         function F (X : access Integer) return T is ... ;
+            --         Decl : T := F (new Integer); -- level is off by one
+            --      begin
+            --         Decl := F (new Integer); -- we get this case right
+            --
+            --  2) For an anonymous allocator that defines the result of a
+            --     function with an access result, the accessibility level is
+            --     determined as though the allocator were in place of the call
+            --     of the function. In the special case of a call that is the
+            --     operand of a type conversion the level is that of the target
+            --     access type of the conversion.
+            --
+            --  3) For an anonymous allocator defining an access discriminant
+            --     the accessibility level is determined as follows:
+            --       * for an allocator used to define the discriminant of an
+            --         object, the level of the object
+            --       * for an allocator used to define the constraint in a
+            --         subtype_indication in any other context, the level of
+            --         the master that elaborates the subtype_indication.
+
+            case Nkind (Parent (N)) is
+               when N_Object_Declaration =>
+
+                  --  For an anonymous allocator whose type is that of a
+                  --  stand-alone object of an anonymous access-to-object type,
+                  --  the accessibility level is that of the declaration of the
+                  --  stand-alone object.
 
-            null;
+                  return Make_Level_Literal
+                           (Object_Access_Level
+                              (Defining_Identifier (Parent (N))));
+
+               when N_Assignment_Statement =>
+                  return Make_Level_Literal
+                           (Object_Access_Level (Name (Parent (N))));
+
+               when others =>
+                  declare
+                     S : constant String :=
+                           Node_Kind'Image (Nkind (Parent (N)));
+                  begin
+                     Error_Msg_Strlen := S'Length;
+                     Error_Msg_String (1 .. Error_Msg_Strlen) := S;
+                     Error_Msg_N ("unsupported context for anonymous " &
+                                  "allocator (~)", Parent (N));
+                  end;
+            end case;
 
          when N_Type_Conversion =>
             if not Is_Local_Anonymous_Access (Etype (Expr)) then

gcc/ada/sem_util.ads

@@ -622,11 +622,11 @@ package Sem_Util is
    --  private components of protected objects, but is generally useful when
    --  restriction No_Implicit_Heap_Allocation is active.
 
-   function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id;
-   --  Expr should be an expression of an access type. Builds an integer
-   --  literal except in cases involving anonymous access types, where
-   --  accessibility levels are tracked at run time (access parameters and
-   --  Ada 2012 stand-alone objects).
+   function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id;
+   --  N should be an expression of an access type. Builds an integer literal
+   --  except in cases involving anonymous access types, where accessibility
+   --  levels are tracked at run time (access parameters and Ada 2012 stand-
+   --  alone objects).
 
    function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
    --  Same as Einfo.Extra_Accessibility except thtat object renames

gcc/testsuite/ChangeLog

+2019-07-05  Javier Miranda  <miranda@adacore.com>
+
+	* gnat.dg/access6.adb: New testcase.
+
 2019-07-05  Bob Duff  <duff@adacore.com>
 
 	* gnat.dg/bip_export.adb, gnat.dg/bip_export.ads: New testcase.

gcc/testsuite/gnat.dg/access6.adb

+--  { dg-do run }
+--  { dg-options "-gnat12" }
+
+procedure Access6 is
+   type Int_Ref is access all Integer;
+   Ptr : Int_Ref;
+
+   procedure update_ptr (X : access integer) is
+   begin
+      --  Failed accessibility test: supposed to raise a Program_Error
+      Ptr := Int_Ref (X);
+   end;
+
+   procedure bar is
+      ref : access integer := new integer;
+   begin
+      update_ptr (ref);
+   end;
+begin
+   bar;
+
+   --  As the call to bar must raise a Program_Error, the following is not supposed to be executed:
+   raise Constraint_Error;
+
+exception
+   when Program_Error =>
+      null;
+end;