From 43fa58c26a05f206ac36ab7d0340744c2769424f Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Fri, 5 Jul 2019 07:02:46 +0000 Subject: [PATCH] [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 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 | 12 +++++++ gcc/ada/exp_ch4.adb | 3 +- gcc/ada/exp_ch6.adb | 5 ++- gcc/ada/sem_util.adb | 75 ++++++++++++++++++++++++++++++++++----- gcc/ada/sem_util.ads | 10 +++--- gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gnat.dg/access6.adb | 28 +++++++++++++++ 7 files changed, 122 insertions(+), 15 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/access6.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0d90861..d07b468 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2019-07-05 Javier Miranda + + * 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 * einfo.ads, sem_res.adb: Typo fixes in comments. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0d4c294..7a048c6 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index db9484f..6e7299a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5c33694..48822e2 100644 --- a/gcc/ada/sem_util.adb +++ b/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 diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 43c0bc5..3eb9d57 100644 --- a/gcc/ada/sem_util.ads +++ b/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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3bd1aab..08d8695 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-05 Javier Miranda + + * gnat.dg/access6.adb: New testcase. + 2019-07-05 Bob Duff * gnat.dg/bip_export.adb, gnat.dg/bip_export.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/access6.adb b/gcc/testsuite/gnat.dg/access6.adb new file mode 100644 index 0000000..3956061 --- /dev/null +++ b/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; -- 2.7.4