diff mbox series

[Ada] Missing accessibility checks on conditionals

Message ID 20191213095501.GA13899@adacore.com
State New
Headers show
Series [Ada] Missing accessibility checks on conditionals | expand

Commit Message

Pierre-Marie de Rodat Dec. 13, 2019, 9:55 a.m. UTC 
This is an incremental patch which fixes a compiler error whereby
accessbility checks on if and case expressions used to set access
discriminants within allocators were not performed. It also corrects an
issue where dynamic accessibility levels are not passed correctly when a
conditional expression is used as an actual of an anonymous access
formal in the limited case that it is constant folded.

Further work is needed for the general case of dynamic accessbility.

Tested on x86_64-pc-linux-gnu, committed on trunk

2019-12-13  Justin Squirek  <squirek@adacore.com>

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.
diff mbox series

Patch

--- gcc/ada/sem_res.adb
+++ 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);

--- gcc/ada/sem_util.adb
+++ 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