From 948590aa2838a8b77dc8e48eb225312865303ce9 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 4 Mar 2020 05:32:57 -0500 Subject: [PATCH] [Ada] Incorrect accessibility checks on functions calls 2020-06-10 Justin Squirek gcc/ada/ * exp_ch3.adb (Expand_N_Object_Declaration): Add condition to handle processing of objects initialized by a call to a function return an anonymous access type. * exp_ch6.adb, exp_ch6.ads (Has_Unconstrained_Access_Discriminants): Moved to sem_util.adb (Needs_Result_Accessibility_Level): Moved to sem_util.adb * sem_util.adb, sem_util.ads (Has_Unconstrained_Access_Discriminants): Moved from exp_ch6.adb (Needs_Result_Accessibility_Level): Moved from exp_ch6.adb * sem_res.adb (Valid_Conversion): Add condition for the special case where the operand of a conversion is the result of an anonymous access type --- gcc/ada/exp_ch3.adb | 19 ++++-- gcc/ada/exp_ch6.adb | 169 --------------------------------------------------- gcc/ada/exp_ch6.ads | 6 -- gcc/ada/sem_res.adb | 8 +++ gcc/ada/sem_util.adb | 166 +++++++++++++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_util.ads | 19 ++++-- 6 files changed, 203 insertions(+), 184 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 381e4f1..cf53100 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7178,21 +7178,32 @@ package body Exp_Ch3 is Chars => New_External_Name (Chars (Def_Id), Suffix => "L")); - Level_Expr : Node_Id; Level_Decl : Node_Id; + Level_Expr : Node_Id; begin Set_Ekind (Level, Ekind (Def_Id)); Set_Etype (Level, Standard_Natural); Set_Scope (Level, Scope (Def_Id)); - if No (Expr) then - - -- Set accessibility level of null + -- Set accessibility level of null + if No (Expr) then Level_Expr := Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); + -- When the expression of the object is a function which returns + -- an anonymous access type the master of the call is the object + -- being initialized instead of the type. + + elsif Nkind (Expr) = N_Function_Call + and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type + then + Level_Expr := Make_Integer_Literal (Loc, + Object_Access_Level (Def_Id)); + + -- General case + else Level_Expr := Dynamic_Accessibility_Level (Expr); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index db96fb7..7e6f77a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -244,11 +244,6 @@ package body Exp_Ch6 is -- Expand simple return from function. In the case where we are returning -- from a function body this is called by Expand_N_Simple_Return_Statement. - function Has_Unconstrained_Access_Discriminants - (Subtyp : Entity_Id) return Boolean; - -- Returns True if the given subtype is unconstrained and has one or more - -- access discriminants. - procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id); -- Insert the Post_Call list previously produced by routine Expand_Actuals -- or Expand_Call_Helper into the tree. @@ -7772,32 +7767,6 @@ package body Exp_Ch6 is end if; end Freeze_Subprogram; - -------------------------------------------- - -- Has_Unconstrained_Access_Discriminants -- - -------------------------------------------- - - function Has_Unconstrained_Access_Discriminants - (Subtyp : Entity_Id) return Boolean - is - Discr : Entity_Id; - - begin - if Has_Discriminants (Subtyp) - and then not Is_Constrained (Subtyp) - then - Discr := First_Discriminant (Subtyp); - while Present (Discr) loop - if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then - return True; - end if; - - Next_Discriminant (Discr); - end loop; - end if; - - return False; - end Has_Unconstrained_Access_Discriminants; - ------------------------------ -- Insert_Post_Call_Actions -- ------------------------------ @@ -9431,144 +9400,6 @@ package body Exp_Ch6 is return Requires_Transient_Scope (Func_Typ); end Needs_BIP_Alloc_Form; - -------------------------------------- - -- Needs_Result_Accessibility_Level -- - -------------------------------------- - - function Needs_Result_Accessibility_Level - (Func_Id : Entity_Id) return Boolean - is - Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); - - function Has_Unconstrained_Access_Discriminant_Component - (Comp_Typ : Entity_Id) return Boolean; - -- Returns True if any component of the type has an unconstrained access - -- discriminant. - - ----------------------------------------------------- - -- Has_Unconstrained_Access_Discriminant_Component -- - ----------------------------------------------------- - - function Has_Unconstrained_Access_Discriminant_Component - (Comp_Typ : Entity_Id) return Boolean - is - begin - if not Is_Limited_Type (Comp_Typ) then - return False; - - -- Only limited types can have access discriminants with - -- defaults. - - elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then - return True; - - elsif Is_Array_Type (Comp_Typ) then - return Has_Unconstrained_Access_Discriminant_Component - (Underlying_Type (Component_Type (Comp_Typ))); - - elsif Is_Record_Type (Comp_Typ) then - declare - Comp : Entity_Id; - - begin - Comp := First_Component (Comp_Typ); - while Present (Comp) loop - if Has_Unconstrained_Access_Discriminant_Component - (Underlying_Type (Etype (Comp))) - then - return True; - end if; - - Next_Component (Comp); - end loop; - end; - end if; - - return False; - end Has_Unconstrained_Access_Discriminant_Component; - - 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 - - begin - -- False if completion unavailable (how does this happen???) - - if not Present (Func_Typ) then - return False; - - -- False if not a function, also handle enum-lit renames case - - elsif Func_Typ = Standard_Void_Type - or else Is_Scalar_Type (Func_Typ) - then - return False; - - -- Handle a corner case, a cross-dialect subp renaming. For example, - -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when - -- an Ada 2005 (or earlier) unit references predefined run-time units. - - elsif Present (Alias (Func_Id)) then - - -- Unimplemented: a cross-dialect subp renaming which does not set - -- the Alias attribute (e.g., a rename of a dereference of an access - -- to subprogram value). ??? - - return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); - - -- Remaining cases require Ada 2012 mode - - elsif Ada_Version < Ada_2012 then - return False; - - -- 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 - return True; - - elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then - return True; - - -- False for all other cases - - else - return False; - end if; - end Needs_Result_Accessibility_Level; - ------------------------------------- -- Replace_Renaming_Declaration_Id -- ------------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 7b977f2..b3dae14 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -247,12 +247,6 @@ package Exp_Ch6 is function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean; -- Return True if the function returns an object of a type that has tasks. - function Needs_Result_Accessibility_Level - (Func_Id : Entity_Id) return Boolean; - -- Ada 2012 (AI05-0234): Return True if the function needs an implicit - -- parameter to identify the accessibility level of the function result - -- "determined by the point of call". - function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id; -- Return the inner BIP function call removing any qualification from Expr -- including qualified expressions, type conversions, references, unchecked diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 15d08fe..fdcef21 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -13086,8 +13086,16 @@ package body Sem_Res is end if; end if; + -- Check if the operand is deeper than the target type, taking + -- care to avoid the case where we are converting a result of a + -- function returning an anonymous access type since the "master + -- of the call" would be target type of the conversion in all + -- cases - see RM 10.3/3. + elsif Type_Access_Level (Opnd_Type) > Deepest_Type_Access_Level (Target_Type) + and then not (Nkind (Associated_Node_For_Itype (Opnd_Type)) = + N_Function_Specification) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index cd7ac1e..5f3dc9e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12326,6 +12326,32 @@ package body Sem_Util is end if; end Has_Tagged_Component; + -------------------------------------------- + -- Has_Unconstrained_Access_Discriminants -- + -------------------------------------------- + + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean + is + Discr : Entity_Id; + + begin + if Has_Discriminants (Subtyp) + and then not Is_Constrained (Subtyp) + then + Discr := First_Discriminant (Subtyp); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + + return False; + end Has_Unconstrained_Access_Discriminants; + ----------------------------- -- Has_Undefined_Reference -- ----------------------------- @@ -17804,7 +17830,7 @@ package body Sem_Util is and then Ekind_In (Scop, E_Function, E_Operator, E_Subprogram_Type) - and then Present (Extra_Accessibility_Of_Result (Scop)); + and then Needs_Result_Accessibility_Level (Scop); end; end Is_Special_Aliased_Formal_Access; @@ -19903,6 +19929,144 @@ package body Sem_Util is end if; end Needs_One_Actual; + -------------------------------------- + -- Needs_Result_Accessibility_Level -- + -------------------------------------- + + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean + is + Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); + + function Has_Unconstrained_Access_Discriminant_Component + (Comp_Typ : Entity_Id) return Boolean; + -- Returns True if any component of the type has an unconstrained access + -- discriminant. + + ----------------------------------------------------- + -- Has_Unconstrained_Access_Discriminant_Component -- + ----------------------------------------------------- + + function Has_Unconstrained_Access_Discriminant_Component + (Comp_Typ : Entity_Id) return Boolean + is + begin + if not Is_Limited_Type (Comp_Typ) then + return False; + + -- Only limited types can have access discriminants with + -- defaults. + + elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then + return True; + + elsif Is_Array_Type (Comp_Typ) then + return Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Component_Type (Comp_Typ))); + + elsif Is_Record_Type (Comp_Typ) then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (Comp_Typ); + while Present (Comp) loop + if Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Etype (Comp))) + then + return True; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + return False; + end Has_Unconstrained_Access_Discriminant_Component; + + 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 + + begin + -- False if completion unavailable (how does this happen???) + + if not Present (Func_Typ) then + return False; + + -- False if not a function, also handle enum-lit renames case + + elsif Func_Typ = Standard_Void_Type + or else Is_Scalar_Type (Func_Typ) + then + return False; + + -- Handle a corner case, a cross-dialect subp renaming. For example, + -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when + -- an Ada 2005 (or earlier) unit references predefined run-time units. + + elsif Present (Alias (Func_Id)) then + + -- Unimplemented: a cross-dialect subp renaming which does not set + -- the Alias attribute (e.g., a rename of a dereference of an access + -- to subprogram value). ??? + + return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); + + -- Remaining cases require Ada 2012 mode + + elsif Ada_Version < Ada_2012 then + return False; + + -- 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 + return True; + + elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then + return True; + + -- False for all other cases + + else + return False; + end if; + end Needs_Result_Accessibility_Level; + --------------------------------- -- Needs_Simple_Initialization -- --------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 5ca8ca3..6be77dd 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1367,6 +1367,11 @@ package Sem_Util is -- function is used to check if "=" has to be expanded into a bunch -- component comparisons. + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean; + -- Returns True if the given subtype is unconstrained and has one or more + -- access discriminants. + function Has_Undefined_Reference (Expr : Node_Id) return Boolean; -- Given arbitrary expression Expr, determine whether it contains at -- least one name whose entity is Any_Id. @@ -2251,6 +2256,12 @@ package Sem_Util is -- syntactic ambiguity that results from an indexing of a function call -- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y). + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean; + -- Ada 2012 (AI05-0234): Return True if the function needs an implicit + -- parameter to identify the accessibility level of the function result + -- "determined by the point of call". + function Needs_Simple_Initialization (Typ : Entity_Id; Consider_IS : Boolean := True) return Boolean; @@ -2713,6 +2724,10 @@ package Sem_Util is -- Establish the entity E as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name). + procedure Set_Debug_Info_Defining_Id (N : Node_Id); + -- Call Set_Debug_Info_Needed on Defining_Identifier (N) if it comes + -- from source. + procedure Set_Debug_Info_Needed (T : Entity_Id); -- Sets the Debug_Info_Needed flag on entity T , and also on any entities -- that are needed by T (for an object, the type of the object is needed, @@ -2721,10 +2736,6 @@ package Sem_Util is -- This routine should always be used instead of Set_Needs_Debug_Info to -- ensure that subsidiary entities are properly handled. - procedure Set_Debug_Info_Defining_Id (N : Node_Id); - -- Call Set_Debug_Info_Needed on Defining_Identifier (N) if it comes - -- from source. - procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id); -- This procedure has the same calling sequence as Set_Entity, but it -- performs additional checks as follows: -- 2.7.4