From 8daf00dd4a654c807618b01f92aac75e7842be13 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Fri, 13 Dec 2019 09:03:28 +0000 Subject: [PATCH] [Ada] Missing accessibility checks on conditionals 2019-12-13 Justin Squirek gcc/ada/ * sem_res.adb (Resolve_Allocator): Add calls to Check_Cond_Expr_Accessibility when a conditional expression is found. (Check_Allocator_Discrim_Accessibility_Exprs): Created to recursively traverse a potentially compound conditional expression and perform accessibility checks for each alternative. * sem_util.adb (Dynamic_Accessibility_Level): Avoid use of original node of the expression in question so we can handle dynamic accessibility in the limited case of a constant folded conditional expression. From-SVN: r279342 --- gcc/ada/ChangeLog | 14 ++++++++++ gcc/ada/sem_res.adb | 72 +++++++++++++++++++++++++++++++++++++++++++++++++--- gcc/ada/sem_util.adb | 7 +++++ 3 files changed, 89 insertions(+), 4 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 402933b..40c8bf32 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2019-12-13 Justin Squirek + + * sem_res.adb (Resolve_Allocator): Add calls to + Check_Cond_Expr_Accessibility when a conditional expression is + found. + (Check_Allocator_Discrim_Accessibility_Exprs): Created to + recursively traverse a potentially compound conditional + expression and perform accessibility checks for each + alternative. + * sem_util.adb (Dynamic_Accessibility_Level): Avoid use of + original node of the expression in question so we can handle + dynamic accessibility in the limited case of a constant folded + conditional expression. + 2019-12-13 Steve Baird * exp_ch4.adb (Expand_N_Op_Eq.Is_Equality): Move this function diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 22d89a3..0bdbc25 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4965,6 +4965,12 @@ package body Sem_Res is -- the cases of a constraint expression which is an access attribute or -- an access discriminant. + procedure Check_Allocator_Discrim_Accessibility_Exprs + (Curr_Exp : Node_Id; + Alloc_Typ : Entity_Id); + -- Dispatch checks performed by Check_Allocator_Discrim_Accessibility + -- across all expressions within a given conditional expression. + function In_Dispatching_Context return Boolean; -- If the allocator is an actual in a call, it is allowed to be class- -- wide when the context is not because it is a controlling actual. @@ -5016,6 +5022,62 @@ package body Sem_Res is end if; end Check_Allocator_Discrim_Accessibility; + ------------------------------------------------- + -- Check_Allocator_Discrim_Accessibility_Exprs -- + ------------------------------------------------- + + procedure Check_Allocator_Discrim_Accessibility_Exprs + (Curr_Exp : Node_Id; + Alloc_Typ : Entity_Id) + is + Alt : Node_Id; + Expr : Node_Id; + Disc_Exp : constant Node_Id := Original_Node (Curr_Exp); + begin + -- When conditional expressions are constant folded we know at + -- compile time which expression to check - so don't bother with + -- the rest of the cases. + + if Nkind (Curr_Exp) = N_Attribute_Reference then + Check_Allocator_Discrim_Accessibility (Curr_Exp, Alloc_Typ); + + -- Non-constant-folded if expressions + + elsif Nkind (Disc_Exp) = N_If_Expression then + -- Check both expressions if they are still present in the face + -- of expansion. + + Expr := Next (First (Expressions (Disc_Exp))); + if Present (Expr) then + Check_Allocator_Discrim_Accessibility_Exprs (Expr, Alloc_Typ); + Expr := Next (Expr); + if Present (Expr) then + Check_Allocator_Discrim_Accessibility_Exprs + (Expr, Alloc_Typ); + end if; + end if; + + -- Non-constant-folded case expressions + + elsif Nkind (Disc_Exp) = N_Case_Expression then + -- Check all alternatives + + Alt := First (Alternatives (Disc_Exp)); + while Present (Alt) loop + Check_Allocator_Discrim_Accessibility_Exprs + (Expression (Alt), Alloc_Typ); + + Next (Alt); + end loop; + + -- Base case, check the accessibility of the original node of the + -- expression. + + else + Check_Allocator_Discrim_Accessibility (Disc_Exp, Alloc_Typ); + end if; + end Check_Allocator_Discrim_Accessibility_Exprs; + ---------------------------- -- In_Dispatching_Context -- ---------------------------- @@ -5167,7 +5229,8 @@ package body Sem_Res is while Present (Discrim) and then Present (Disc_Exp) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + Check_Allocator_Discrim_Accessibility_Exprs + (Disc_Exp, Typ); end if; Next_Discriminant (Discrim); @@ -5225,12 +5288,13 @@ package body Sem_Res is while Present (Discrim) and then Present (Constr) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then if Nkind (Constr) = N_Discriminant_Association then - Disc_Exp := Original_Node (Expression (Constr)); + Disc_Exp := Expression (Constr); else - Disc_Exp := Original_Node (Constr); + Disc_Exp := Constr; end if; - Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); + Check_Allocator_Discrim_Accessibility_Exprs + (Disc_Exp, Typ); end if; Next_Discriminant (Discrim); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 22ecf21..91137ad 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6612,6 +6612,13 @@ package body Sem_Util is end if; end if; + -- Handle a constant-folded conditional expression by avoiding use of + -- the original node. + + if Nkind_In (Expr, N_Case_Expression, N_If_Expression) then + Expr := N; + end if; + -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? case Nkind (Expr) is -- 2.7.4