From 8d21ff6025652fa67085d94d5101cd699c57cf0b Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Fri, 5 Jul 2019 07:03:58 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/checks.adb | 19 +++++++++++++++++-- gcc/ada/exp_ch6.adb | 54 ++++++++++++++++++++++++++++++++--------------------- 3 files changed, 59 insertions(+), 23 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c875ac3..8a729d1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2019-07-05 Justin Squirek + + * 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 * sem_ch9.adb (Analyze_Accept_Statement): If this is an illegal 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. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6e7299a..ae17a5b 100644 --- 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 -- 2.7.4