From: Justin Squirek Date: Wed, 15 Dec 2021 14:27:23 +0000 (+0000) Subject: [Ada] Spurious access error in function returning type with access discriminant X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=fa45988cc0129f95d1c8b1d386342b6351233ef5;p=platform%2Fupstream%2Fgcc.git [Ada] Spurious access error in function returning type with access discriminant This patch fixes an issue in the compiler whereby incorrect accessibility checks were generated in functions returning types with unconstrained access discriminants when the value supplied for the discriminant is a formal parameter. More specifically, accessibility checks for return statements featuring a result type having access discriminants were incorrectly being performed against the level of the function declaration instead of the level of the master of the call. gcc/ada/ * sem_ch6.adb (Check_Return_Construct_Accessibility): Modify generation of run-time accessibility checks to account for cases where Extra_Accessibility_Of_Result should be used versus the level of the enclosing subprogram. Use original node to avoid checking against expanded code. Disable check generation for tagged type case. (Is_Formal_Of_Current_Function): Added to encompass a predicate used within Check_Return_Construct_Accessibility to test if an associated expression is related to a relevant formal. * sem_util.adb, sem_util.ads (Enclosing_Subprogram): Modified to accept Node_Or_Entity_Id. (Innermost_Master_Scope_Depth): Calculate level based on the subprogram of a return statement instead of the one returned by Current_Subprogram. (Needs_Result_Accessibility_Level): Remove Disable_Coextension_Cases constant, and disable the tagged type case for performance reasons. --- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 92e48fa..17e7d26 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -777,6 +777,12 @@ package body Sem_Ch6 is function First_Selector (Assoc : Node_Id) return Node_Id; -- Obtain the first selector or choice from a given association + function Is_Formal_Of_Current_Function + (Assoc_Expr : Entity_Id) return Boolean; + -- Predicate to test if a given expression associated with a + -- discriminant is a formal parameter to the function in which the + -- return construct we checking applies to. + -------------------- -- First_Selector -- -------------------- @@ -794,6 +800,19 @@ package body Sem_Ch6 is end if; end First_Selector; + ----------------------------------- + -- Is_Formal_Of_Current_Function -- + ----------------------------------- + + function Is_Formal_Of_Current_Function + (Assoc_Expr : Entity_Id) return Boolean is + begin + return Is_Entity_Name (Assoc_Expr) + and then Enclosing_Subprogram + (Entity (Assoc_Expr)) = Scope_Id + and then Is_Formal (Entity (Assoc_Expr)); + end Is_Formal_Of_Current_Function; + -- Local declarations Assoc : Node_Id := Empty; @@ -869,7 +888,10 @@ package body Sem_Ch6 is -- with all anonymous access discriminants, then generate a -- dynamic check or static error when relevant. - Unqual := Unqualify (Original_Node (Return_Con)); + -- Note the repeated use of Original_Node to avoid checking + -- expanded code. + + Unqual := Original_Node (Unqualify (Original_Node (Return_Con))); -- Get the corresponding declaration based on the return object's -- identifier. @@ -1052,8 +1074,6 @@ package body Sem_Ch6 is if Nkind (Assoc) = N_Component_Association and then Box_Present (Assoc) then - Assoc_Present := False; - if Nkind (First_Selector (Assoc)) = N_Others_Choice then Unseen_Disc_Count := 0; end if; @@ -1178,9 +1198,24 @@ package body Sem_Ch6 is if Present (Assoc_Expr) and then Present (Disc) and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type + + -- We disable the check when we have a tagged return type and + -- the associated expression for the discriminant is a formal + -- parameter since the check would require us to compare the + -- accessibility level of Assoc_Expr to the level of the + -- Extra_Accessibility_Of_Result of the function - which is + -- currently disabled for functions with tagged return types. + -- This may change in the future ??? + + -- See Needs_Result_Accessibility_Level for details. + + and then not + (No (Extra_Accessibility_Of_Result (Scope_Id)) + and then Is_Formal_Of_Current_Function (Assoc_Expr) + and then Is_Tagged_Type (Etype (Scope_Id))) then -- Generate a dynamic check based on the extra accessibility of - -- the result or the scope. + -- the result or the scope of the current function. Check_Cond := Make_Op_Gt (Loc, @@ -1188,14 +1223,24 @@ package body Sem_Ch6 is (Expr => Assoc_Expr, Level => Dynamic_Level, In_Return_Context => True), - Right_Opnd => (if Present - (Extra_Accessibility_Of_Result - (Scope_Id)) - then - Extra_Accessibility_Of_Result (Scope_Id) - else - Make_Integer_Literal - (Loc, Scope_Depth (Scope (Scope_Id))))); + Right_Opnd => + (if Present (Extra_Accessibility_Of_Result (Scope_Id)) + + -- When Assoc_Expr is a formal we have to look at the + -- extra accessibility-level formal associated with + -- the result. + + and then Is_Formal_Of_Current_Function (Assoc_Expr) + then + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Scope_Id), Loc) + + -- Otherwise, we compare the level of Assoc_Expr to the + -- scope of the current function. + + else + Make_Integer_Literal + (Loc, Scope_Depth (Scope (Scope_Id))))); Insert_Before_And_Analyze (Return_Stmt, Make_Raise_Program_Error (Loc, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f12dbc7..e2a4963 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -327,9 +327,8 @@ package body Sem_Util is elsif Nkind (Node_Par) in N_Extended_Return_Statement | N_Simple_Return_Statement - and then Ekind (Current_Scope) = E_Function then - return Scope_Depth (Current_Scope); + return Scope_Depth (Enclosing_Subprogram (Node_Par)); -- Statements are counted as masters @@ -8356,10 +8355,29 @@ package body Sem_Util is -- Enclosing_Subprogram -- -------------------------- - function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is - Dyn_Scop : constant Entity_Id := Enclosing_Dynamic_Scope (E); + function Enclosing_Subprogram (N : Node_Or_Entity_Id) return Entity_Id is + Dyn_Scop : Entity_Id; + Encl_Scop : Entity_Id; begin + -- Obtain the enclosing scope when N is a Node_Id - taking care to + -- handle the case when the enclosing scope is already a subprogram. + + if Nkind (N) not in N_Entity then + Encl_Scop := Find_Enclosing_Scope (N); + + if No (Encl_Scop) then + return Empty; + elsif Ekind (Encl_Scop) in Subprogram_Kind then + return Encl_Scop; + end if; + + return Enclosing_Subprogram (Encl_Scop); + end if; + + -- When N is already an Entity_Id proceed + + Dyn_Scop := Enclosing_Dynamic_Scope (N); if Dyn_Scop = Standard_Standard then return Empty; @@ -23091,8 +23109,8 @@ package body Sem_Util is if not Is_Limited_Type (Comp_Typ) then return False; - -- Only limited types can have access discriminants with - -- defaults. + -- Only limited types can have access discriminants with + -- defaults. elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then return True; @@ -23122,16 +23140,18 @@ package body Sem_Util is 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. + Disable_Tagged_Cases : constant Boolean := True; + -- Flag used to temporarily disable a "True" result for tagged types. + -- See comments further below for details. -- Start of processing for Needs_Result_Accessibility_Level begin - -- False if completion unavailable (how does this happen???) + -- False if completion unavailable, which can happen when we are + -- analyzing an abstract subprogram or if the subprogram has + -- delayed freezing. - if not Present (Func_Typ) then + if No (Func_Typ) then return False; -- False if not a function, also handle enum-lit renames case @@ -23164,14 +23184,6 @@ package body Sem_Util is 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. @@ -23188,8 +23200,11 @@ package body Sem_Util is -- solve these issues by introducing wrappers, but that is not the -- approach that was chosen. + -- Note: Despite the reasoning noted above, the extra accessibility + -- parameter for tagged types is disabled for performance reasons. + elsif Is_Tagged_Type (Func_Typ) then - return True; + return not Disable_Tagged_Cases; elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then return True; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 4ab4016..e5e1d01 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -824,9 +824,9 @@ package Sem_Util is -- Returns the entity of the package or subprogram enclosing E, if any. -- Returns Empty if no enclosing package or subprogram. - function Enclosing_Subprogram (E : Entity_Id) return Entity_Id; + function Enclosing_Subprogram (N : Node_Or_Entity_Id) return Entity_Id; -- Utility function to return the Ada entity of the subprogram enclosing - -- the entity E, if any. Returns Empty if no enclosing subprogram. + -- N, if any. Returns Empty if no enclosing subprogram. function End_Keyword_Location (N : Node_Id) return Source_Ptr; -- Given block statement, entry body, package body, package declaration,