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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-07-05 Javier Miranda <mira...@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.--- gcc/ada/exp_ch4.adb
+++ 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
+++ 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
+++ 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
+++ 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
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/access6.adb
@@ -0,0 +1,28 @@
+-- { 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;
