[Ada] Missing accessibility check on access discriminants

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

gcc/ada/

	* sem_ch6.adb (Analyze_Function_Return): Modify handling of
	extended return statements to check accessibility of access
	discriminants.
	(Check_Aggregate_Accessibility): Removed.
	(Check_Return_Obj_Accessibility): Added to centralize checking
	of return aggregates and subtype indications in the case of an
	extended return statement.

From-SVN: r279518

2 files changed, 186 insertions, 46 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 465f5a9..aa37e62 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2019-12-18  Justin Squirek  <squirek@adacore.com>
+
+	* sem_ch6.adb (Analyze_Function_Return): Modify handling of
+	extended return statements to check accessibility of access
+	discriminants.
+	(Check_Aggregate_Accessibility): Removed.
+	(Check_Return_Obj_Accessibility): Added to centralize checking
+	of return aggregates and subtype indications in the case of an
+	extended return statement.
+
 2019-12-18  Arnaud Charlet  <charlet@adacore.com>
 
 	* libgnat/s-regpat.adb (Parse_Literal, Parse_Piece): Ensure
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 4afcf01..eca0557 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -694,69 +694,199 @@ package body Sem_Ch6 is
       R_Type : constant Entity_Id := Etype (Scope_Id);
       --  Function result subtype
 
-      procedure Check_Aggregate_Accessibility (Aggr : Node_Id);
-      --  Apply legality rule of 6.5 (5.8) to the access discriminants of an
+      procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id);
+      --  Apply legality rule of 6.5 (5.9) to the access discriminants of an
       --  aggregate in a return statement.
 
       procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
       --  Check that the return_subtype_indication properly matches the result
       --  subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
 
-      -----------------------------------
-      -- Check_Aggregate_Accessibility --
-      -----------------------------------
+      ------------------------------------
+      -- Check_Return_Obj_Accessibility --
+      ------------------------------------
 
-      procedure Check_Aggregate_Accessibility (Aggr : Node_Id) is
-         Typ   : constant Entity_Id := Etype (Aggr);
-         Assoc : Node_Id;
-         Discr : Entity_Id;
-         Expr  : Node_Id;
-         Obj   : Node_Id;
+      procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id) is
+         Assoc         : Node_Id;
+         Agg           : Node_Id := Empty;
+         Discr         : Entity_Id;
+         Expr          : Node_Id;
+         Obj           : Node_Id;
+         Process_Exprs : Boolean := False;
+         Return_Obj    : Node_Id;
 
       begin
-         if Is_Record_Type (Typ) and then Has_Discriminants (Typ) then
-            Discr := First_Discriminant (Typ);
-            Assoc := First (Component_Associations (Aggr));
-            while Present (Discr) loop
-               if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+         --  Only perform checks on record types with access discriminants
+
+         if not Is_Record_Type (R_Type)
+           or else not Has_Discriminants (R_Type)
+         then
+            return;
+         end if;
+
+         --  We are only interested in return statements
+
+         if not Nkind_In (Return_Stmt, N_Extended_Return_Statement,
+                                       N_Simple_Return_Statement)
+         then
+            return;
+         end if;
+
+         --  Fetch the object from the return statement, in the case of a
+         --  simple return statement the expression is part of the node.
+
+         if Nkind (Return_Stmt) = N_Extended_Return_Statement then
+            Return_Obj := Last (Return_Object_Declarations (Return_Stmt));
+
+            --  We could be looking at something that's been expanded with
+            --  an initialzation procedure which we can safely ignore.
+
+            if Nkind (Return_Obj) /= N_Object_Declaration then
+               return;
+            end if;
+         else
+            Return_Obj := Return_Stmt;
+         end if;
+
+         --  We may need to check an aggregate or a subtype indication
+         --  depending on how the discriminants were specified and whether
+         --  we are looking at an extended return statement.
+
+         if Nkind (Return_Obj) = N_Object_Declaration
+           and then Nkind (Object_Definition (Return_Obj))
+                      = N_Subtype_Indication
+         then
+            Assoc := First (Constraints
+                             (Constraint (Object_Definition (Return_Obj))));
+         else
+            --  Qualified expressions may be nested
+
+            Agg := Original_Node (Expression (Return_Obj));
+            while Nkind (Agg) = N_Qualified_Expression loop
+               Agg := Original_Node (Expression (Agg));
+            end loop;
+
+            --  If we are looking at an aggregate instead of a function call we
+            --  can continue checking accessibility for the supplied
+            --  discriminant associations.
+
+            if Nkind (Agg) = N_Aggregate then
+               if Present (Expressions (Agg)) then
+                  Assoc         := First (Expressions (Agg));
+                  Process_Exprs := True;
+               else
+                  Assoc := First (Component_Associations (Agg));
+               end if;
+
+            --  Otherwise the expression is not of interest ???
+
+            else
+               return;
+            end if;
+         end if;
+
+         --  Move through the discriminants checking the accessibility level
+         --  of each co-extension's associated expression.
+
+         Discr := First_Discriminant (R_Type);
+         while Present (Discr) loop
+            if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+
+               if Nkind (Assoc) = N_Attribute_Reference then
+                  Expr := Assoc;
+               elsif Nkind_In (Assoc, N_Component_Association,
+                                      N_Discriminant_Association)
+               then
                   Expr := Expression (Assoc);
+               end if;
 
-                  if Nkind (Expr) = N_Attribute_Reference
-                    and then Attribute_Name (Expr) /= Name_Unrestricted_Access
-                  then
-                     Obj := Prefix (Expr);
-                     while Nkind_In (Obj, N_Indexed_Component,
-                                          N_Selected_Component)
-                     loop
+               --  This anonymous access discriminant has an associated
+               --  expression which needs checking.
+
+               if Nkind (Expr) = N_Attribute_Reference
+                 and then Attribute_Name (Expr) /= Name_Unrestricted_Access
+               then
+                  --  Obtain the object to perform static checks on by moving
+                  --  up the prefixes in the expression taking into account
+                  --  named access types.
+
+                  Obj := Prefix (Expr);
+                  while Nkind_In (Obj, N_Indexed_Component,
+                                       N_Selected_Component)
+                  loop
+                     --  When we encounter a named access type then we can
+                     --  ignore accessibility checks on the dereference.
+
+                     if Ekind (Etype (Prefix (Obj)))
+                          in E_Access_Type ..
+                             E_Access_Protected_Subprogram_Type
+                     then
+                        if Nkind (Obj) = N_Selected_Component then
+                           Obj := Selector_Name (Obj);
+                        end if;
+                        exit;
+                     end if;
+
+                     --  Skip over the explicit dereference
+
+                     if Nkind (Prefix (Obj)) = N_Explicit_Dereference then
+                        Obj := Prefix (Prefix (Obj));
+
+                     --  Otherwise move up to the next prefix
+
+                     else
                         Obj := Prefix (Obj);
-                     end loop;
+                     end if;
+                  end loop;
 
-                     --  Do not check aliased formals or function calls. A
-                     --  run-time check may still be needed ???
+                  --  Do not check aliased formals or function calls. A
+                  --  run-time check may still be needed ???
 
-                     if Is_Entity_Name (Obj)
-                       and then Comes_From_Source (Obj)
+                  if Is_Entity_Name (Obj)
+                    and then Comes_From_Source (Obj)
+                  then
+                     --  Explicitly aliased formals are allowed
+
+                     if Is_Formal (Entity (Obj))
+                       and then Is_Aliased (Entity (Obj))
                      then
-                        if Is_Formal (Entity (Obj))
-                           and then Is_Aliased (Entity (Obj))
-                        then
-                           null;
+                        null;
 
-                        elsif Object_Access_Level (Obj) >
-                                Scope_Depth (Scope (Scope_Id))
-                        then
-                           Error_Msg_N
-                             ("access discriminant in return aggregate would "
-                              & "be a dangling reference", Obj);
-                        end if;
+                     elsif Object_Access_Level (Obj) >
+                             Scope_Depth (Scope (Scope_Id))
+                     then
+                        Error_Msg_N
+                          ("access discriminant in return aggregate would "
+                           & "be a dangling reference", Obj);
                      end if;
                   end if;
                end if;
+            end if;
 
-               Next_Discriminant (Discr);
-            end loop;
-         end if;
-      end Check_Aggregate_Accessibility;
+            Next_Discriminant (Discr);
+
+            if not Is_List_Member (Assoc) then
+               Assoc := Empty;
+            else
+               Nlists.Next (Assoc);
+            end if;
+
+            --  After aggregate expressions, examine component associations if
+            --  present.
+
+            if No (Assoc) then
+               if Present (Agg)
+                 and then Process_Exprs
+                 and then Present (Component_Associations (Agg))
+               then
+                  Assoc         := First (Component_Associations (Agg));
+                  Process_Exprs := False;
+               else
+                  exit;
+               end if;
+            end if;
+         end loop;
+      end Check_Return_Obj_Accessibility;
 
       -------------------------------------
       -- Check_Return_Subtype_Indication --
@@ -963,9 +1093,7 @@ package body Sem_Ch6 is
             Resolve (Expr, R_Type);
             Check_Limited_Return (N, Expr, R_Type);
 
-            if Present (Expr) and then Nkind (Expr) = N_Aggregate then
-               Check_Aggregate_Accessibility (Expr);
-            end if;
+            Check_Return_Obj_Accessibility (N);
          end if;
 
          --  RETURN only allowed in SPARK as the last statement in function
@@ -1021,6 +1149,8 @@ package body Sem_Ch6 is
 
             Check_References (Stm_Entity);
 
+            Check_Return_Obj_Accessibility (N);
+
             --  Check RM 6.5 (5.9/3)
 
             if Has_Aliased then