diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 9 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 19 | ||||
| -rw-r--r-- | 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 <squirek@adacore.com> + + * 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 <schonberg@adacore.com> * 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 |