ada: Accessibility code reorganization and bug fixes

This patch performs a large reorganization of accessibility related sources,
and also corrects some latent issues with accessibility checks - namely the
calculation of accessibility levels for expanded iterators and type
conversions.

gcc/ada/
	* accessibility.adb, accessibility.ads
	(Accessibility_Message): Moved from sem_attr.
	(Apply_Accessibility_Check): Moved from checks.
	(Apply_Accessibility_Check_For_Allocator): Moved from exp_ch4 and
	renamed
	(Check_Return_Construct_Accessibility): Moved from sem_ch6.
	(Innermost_Master_Scope_Depth): Moved from sem_util. Add condition
	to detect expanded iterators.
	(Prefix_With_Safe_Accessibility_Level): Moved from sem_attr.
	(Static_Accessibility_Level): Moved from sem_util.
	(Has_Unconstrained_Access_Discriminants): Likewise.
	(Has_Anonymous_Access_Discriminant): Likewise.
	(Is_Anonymous_Access_Actual): Likewise.
	(Is_Special_Aliased_Formal_Access): Likewise.
	(Needs_Result_Accessibility_Level): Likewise.
	(Subprogram_Access_Level): Likewise.
	(Type_Access_Level): Likewise.
	(Deepest_Type_Access_Level): Likewise.
	(Effective_Extra_Accessibility): Likewise.
	(Get_Dynamic_Accessibility): Likewise.
	(Has_Access_Values): Likewise.
	(Accessibility_Level): Likewise.
	* exp_attr.adb (Access_Cases): Obtain the proper enclosing object
	which applies to a given 'Access by looking through type
	conversions.
	* exp_ch4.adb (Apply_Accessibility_Check): Moved to accessibility.
	* exp_ch5.adb: Likewise.
	* exp_ch6.adb: Likewise.
	* exp_ch9.adb: Likewise.
	* exp_disp.adb: Likewise.
	* gen_il-fields.ads: Add new flag Comes_From_Iterator.
	* gen_il-gen-gen_nodes.adb: Add new flag Comes_From_Iterator for
	N_Object_Renaming_Declaration.
	* sem_ch5.adb (Analyze_Iterator_Specification): Mark object
	renamings resulting from iterator expansion with the new flag
	Comes_From_Iterator.
	* sem_aggr.adb (Resolve_Container_Aggregate): Refine test.
	* sem_ch13.adb: Add dependence on the accessibility package.
	* sem_ch3.adb: Likewise.
	* sem_ch4.adb: Likewise.
	* sem_ch9.adb: Likewise.
	* sem_res.adb: Likewise.
	* sem_warn.adb: Likewise.
	* exp_ch3.adb: Likewise.
	* sem_attr.adb (Accessibility_Message): Moved to accessibility.
	(Prefix_With_Safe_Accessibility_Level): Likewise.
	* checks.adb, checks.ads (Apply_Accessibility_Check): Likewise.
	* sem_ch6.adb (Check_Return_Construct_Accessibility): Likewise.
	* sem_util.adb, sem_util.ads
	(Accessibility_Level): Likewise.
	(Deepest_Type_Access_Level): Likewise.
	(Effective_Extra_Accessibility): Likewise.
	(Get_Dynamic_Accessibility): Likewise.
	(Has_Access_Values): Likewise.
	(Has_Anonymous_Access_Discriminant): Likewise.
	(Static_Accessibility_Level): Likewise.
	(Has_Unconstrained_Access_Discriminants): Likewise.
	(Is_Anonymous_Access_Actual): Likewise.
	(Is_Special_Aliased_Formal_Access): Likewise.
	(Needs_Result_Accessibility_Level): Likewise.
	(Subprogram_Access_Level): Likewise.
	(Type_Access_Level): Likewise.
	* sinfo.ads: Document new flag Comes_From_Iterator.
	* gcc-interface/Make-lang.in: Add entry for new Accessibility package.

1 files changed, 3 insertions, 516 deletions

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index cb982b3..d567f79 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Accessibility;  use Accessibility;
 with Aspects;        use Aspects;
 with Atree;          use Atree;
 with Checks;         use Checks;
@@ -745,10 +746,6 @@ package body Sem_Ch6 is
       --  Ada 2022: Check that the return expression in a No_Return function
       --  meets the conditions specified by RM 6.5.1(5.1/5).
 
-      procedure Check_Return_Construct_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).
@@ -781,516 +778,6 @@ package body Sem_Ch6 is
             Return_Expr);
       end Check_No_Return_Expression;
 
-      ------------------------------------------
-      -- Check_Return_Construct_Accessibility --
-      ------------------------------------------
-
-      procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) 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 --
-         --------------------
-
-         function First_Selector (Assoc : Node_Id) return Node_Id is
-         begin
-            if Nkind (Assoc) = N_Component_Association then
-               return First (Choices (Assoc));
-
-            elsif Nkind (Assoc) = N_Discriminant_Association then
-               return (First (Selector_Names (Assoc)));
-
-            else
-               raise Program_Error;
-            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;
-         --  Assoc should perhaps be renamed and declared as a
-         --  Node_Or_Entity_Id since it encompasses not only component and
-         --  discriminant associations, but also discriminant components within
-         --  a type declaration or subtype indication ???
-
-         Assoc_Expr    : Node_Id;
-         Assoc_Present : Boolean := False;
-
-         Check_Cond        : Node_Id;
-         Unseen_Disc_Count : Nat := 0;
-         Seen_Discs        : Elist_Id;
-         Disc              : Entity_Id;
-         First_Disc        : Entity_Id;
-
-         Obj_Decl   : Node_Id;
-         Return_Con : Node_Id;
-         Unqual     : Node_Id;
-
-      --  Start of processing for Check_Return_Construct_Accessibility
-
-      begin
-         --  Only perform checks on record types with access discriminants and
-         --  non-internally generated functions.
-
-         if not Is_Record_Type (R_Type)
-           or else not Has_Anonymous_Access_Discriminant (R_Type)
-           or else not Comes_From_Source (Return_Stmt)
-         then
-            return;
-         end if;
-
-         --  We are only interested in return statements
-
-         if Nkind (Return_Stmt) not in
-              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
-            --  Obtain the object definition from the expanded extended return
-
-            Return_Con := First (Return_Object_Declarations (Return_Stmt));
-            while Present (Return_Con) loop
-               --  Inspect the original node to avoid object declarations
-               --  expanded into renamings.
-
-               if Nkind (Original_Node (Return_Con)) = N_Object_Declaration
-                 and then Comes_From_Source (Original_Node (Return_Con))
-               then
-                  exit;
-               end if;
-
-               Nlists.Next (Return_Con);
-            end loop;
-
-            pragma Assert (Present (Return_Con));
-
-            --  Could be dealing with a renaming
-
-            Return_Con := Original_Node (Return_Con);
-         else
-            Return_Con := Expression (Return_Stmt);
-         end if;
-
-         --  Obtain the accessibility levels of the expressions associated
-         --  with all anonymous access discriminants, then generate a
-         --  dynamic check or static error when relevant.
-
-         --  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.
-
-         if Nkind (Unqual) = N_Identifier
-           and then Nkind (Parent (Entity (Unqual)))
-                      in N_Object_Declaration
-                       | N_Object_Renaming_Declaration
-         then
-            Obj_Decl := Original_Node (Parent (Entity (Unqual)));
-
-         --  We were passed the object declaration directly, so use it
-
-         elsif Nkind (Unqual) in N_Object_Declaration
-                               | N_Object_Renaming_Declaration
-         then
-            Obj_Decl := Unqual;
-
-         --  Otherwise, we are looking at something else
-
-         else
-            Obj_Decl := Empty;
-
-         end if;
-
-         --  Hop up object renamings when present
-
-         if Present (Obj_Decl)
-           and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration
-         then
-            while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop
-
-               if Nkind (Name (Obj_Decl)) not in N_Entity then
-                  --  We may be looking at the expansion of iterators or
-                  --  some other internally generated construct, so it is safe
-                  --  to ignore checks ???
-
-                  if not Comes_From_Source (Obj_Decl) then
-                     return;
-                  end if;
-
-                  Obj_Decl := Original_Node
-                                (Declaration_Node
-                                  (Ultimate_Prefix (Name (Obj_Decl))));
-
-               --  Move up to the next declaration based on the object's name
-
-               else
-                  Obj_Decl := Original_Node
-                                (Declaration_Node (Name (Obj_Decl)));
-               end if;
-            end loop;
-         end if;
-
-         --  Obtain the discriminant values from the return aggregate
-
-         --  Do we cover extension aggregates correctly ???
-
-         if Nkind (Unqual) = N_Aggregate then
-            if Present (Expressions (Unqual)) then
-               Assoc := First (Expressions (Unqual));
-            else
-               Assoc := First (Component_Associations (Unqual));
-            end if;
-
-         --  There is an object declaration for the return object
-
-         elsif Present (Obj_Decl) then
-            --  When a subtype indication is present in an object declaration
-            --  it must contain the object's discriminants.
-
-            if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then
-               Assoc := First
-                          (Constraints
-                            (Constraint
-                              (Object_Definition (Obj_Decl))));
-
-            --  The object declaration contains an aggregate
-
-            elsif Present (Expression (Obj_Decl)) then
-
-               if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then
-                  --  Grab the first associated discriminant expresion
-
-                  if Present
-                       (Expressions (Unqualify (Expression (Obj_Decl))))
-                  then
-                     Assoc := First
-                                (Expressions
-                                  (Unqualify (Expression (Obj_Decl))));
-                  else
-                     Assoc := First
-                                (Component_Associations
-                                  (Unqualify (Expression (Obj_Decl))));
-                  end if;
-
-               --  Otherwise, this is something else
-
-               else
-                  return;
-               end if;
-
-            --  There are no supplied discriminants in the object declaration,
-            --  so get them from the type definition since they must be default
-            --  initialized.
-
-            --  Do we handle constrained subtypes correctly ???
-
-            elsif Nkind (Unqual) = N_Object_Declaration then
-               Assoc := First_Discriminant
-                          (Etype (Object_Definition (Obj_Decl)));
-
-            else
-               Assoc := First_Discriminant (Etype (Unqual));
-            end if;
-
-         --  When we are not looking at an aggregate or an identifier, return
-         --  since any other construct (like a function call) is not
-         --  applicable since checks will be performed on the side of the
-         --  callee.
-
-         else
-            return;
-         end if;
-
-         --  Obtain the discriminants so we know the actual type in case the
-         --  value of their associated expression gets implicitly converted.
-
-         if No (Obj_Decl) then
-            pragma Assert (Nkind (Unqual) = N_Aggregate);
-
-            Disc := First_Discriminant (Etype (Unqual));
-
-         else
-            Disc := First_Discriminant
-                      (Etype (Defining_Identifier (Obj_Decl)));
-         end if;
-
-         --  Preserve the first discriminant for checking named associations
-
-         First_Disc := Disc;
-
-         --  Count the number of discriminants for processing an aggregate
-         --  which includes an others.
-
-         Disc := First_Disc;
-         while Present (Disc) loop
-            Unseen_Disc_Count := Unseen_Disc_Count + 1;
-
-            Next_Discriminant (Disc);
-         end loop;
-
-         Seen_Discs := New_Elmt_List;
-
-         --  Loop through each of the discriminants and check each expression
-         --  associated with an anonymous access discriminant.
-
-         --  When named associations occur in the return aggregate then
-         --  discriminants can be in any order, so we need to ensure we do
-         --  not continue to loop when all discriminants have been seen.
-
-         Disc := First_Disc;
-         while Present (Assoc)
-           and then (Present (Disc) or else Assoc_Present)
-           and then Unseen_Disc_Count > 0
-         loop
-            --  Handle named associations by searching through the names of
-            --  the relevant discriminant components.
-
-            if Nkind (Assoc)
-                 in N_Component_Association | N_Discriminant_Association
-            then
-               Assoc_Expr    := Expression (Assoc);
-               Assoc_Present := True;
-
-               --  We currently don't handle box initialized discriminants,
-               --  however, since default initialized anonymous access
-               --  discriminants are a corner case, this is ok for now ???
-
-               if Nkind (Assoc) = N_Component_Association
-                 and then Box_Present (Assoc)
-               then
-                  if Nkind (First_Selector (Assoc)) = N_Others_Choice then
-                     Unseen_Disc_Count := 0;
-                  end if;
-
-               --  When others is present we must identify a discriminant we
-               --  haven't already seen so as to get the appropriate type for
-               --  the static accessibility check.
-
-               --  This works because all components within an others clause
-               --  must have the same type.
-
-               elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then
-
-                  Disc := First_Disc;
-                  Outer : while Present (Disc) loop
-                     declare
-                        Current_Seen_Disc : Elmt_Id;
-                     begin
-                        --  Move through the list of identified discriminants
-
-                        Current_Seen_Disc := First_Elmt (Seen_Discs);
-                        while Present (Current_Seen_Disc) loop
-                           --  Exit the loop when we found a match
-
-                           exit when
-                             Chars (Node (Current_Seen_Disc)) = Chars (Disc);
-
-                           Next_Elmt (Current_Seen_Disc);
-                        end loop;
-
-                        --  When we have exited the above loop without finding
-                        --  a match then we know that Disc has not been seen.
-
-                        exit Outer when No (Current_Seen_Disc);
-                     end;
-
-                     Next_Discriminant (Disc);
-                  end loop Outer;
-
-                  --  If we got to an others clause with a non-zero
-                  --  discriminant count there must be a discriminant left to
-                  --  check.
-
-                  pragma Assert (Present (Disc));
-
-                  --  Set the unseen discriminant count to zero because we know
-                  --  an others clause sets all remaining components of an
-                  --  aggregate.
-
-                  Unseen_Disc_Count := 0;
-
-               --  Move through each of the selectors in the named association
-               --  and obtain a discriminant for accessibility checking if one
-               --  is referenced in the list. Also track which discriminants
-               --  are referenced for the purpose of handling an others clause.
-
-               else
-                  declare
-                     Assoc_Choice : Node_Id;
-                     Curr_Disc    : Node_Id;
-                  begin
-
-                     Disc      := Empty;
-                     Curr_Disc := First_Disc;
-                     while Present (Curr_Disc) loop
-                        --  Check each of the choices in the associations for a
-                        --  match to the name of the current discriminant.
-
-                        Assoc_Choice := First_Selector (Assoc);
-                        while Present (Assoc_Choice) loop
-                           --  When the name matches we track that we have seen
-                           --  the discriminant, but instead of exiting the
-                           --  loop we continue iterating to make sure all the
-                           --  discriminants within the named association get
-                           --  tracked.
-
-                           if Chars (Assoc_Choice) = Chars (Curr_Disc) then
-                              Append_Elmt (Curr_Disc, Seen_Discs);
-
-                              Disc              := Curr_Disc;
-                              Unseen_Disc_Count := Unseen_Disc_Count - 1;
-                           end if;
-
-                           Next (Assoc_Choice);
-                        end loop;
-
-                        Next_Discriminant (Curr_Disc);
-                     end loop;
-                  end;
-               end if;
-
-            --  Unwrap the associated expression if we are looking at a default
-            --  initialized type declaration. In this case Assoc is not really
-            --  an association, but a component declaration. Should Assoc be
-            --  renamed in some way to be more clear ???
-
-            --  This occurs when the return object does not initialize
-            --  discriminant and instead relies on the type declaration for
-            --  their supplied values.
-
-            elsif Nkind (Assoc) in N_Entity
-              and then Ekind (Assoc) = E_Discriminant
-            then
-               Append_Elmt (Disc, Seen_Discs);
-
-               Assoc_Expr        := Discriminant_Default_Value (Assoc);
-               Unseen_Disc_Count := Unseen_Disc_Count - 1;
-
-            --  Otherwise, there is nothing to do because Assoc is an
-            --  expression within the return aggregate itself.
-
-            else
-               Append_Elmt (Disc, Seen_Discs);
-
-               Assoc_Expr        := Assoc;
-               Unseen_Disc_Count := Unseen_Disc_Count - 1;
-            end if;
-
-            --  Check the accessibility level of the expression when the
-            --  discriminant is of an anonymous access type.
-
-            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 of the current function.
-
-               Check_Cond :=
-                 Make_Op_Gt (Loc,
-                   Left_Opnd  => Accessibility_Level
-                                   (Expr              => Assoc_Expr,
-                                    Level             => Dynamic_Level,
-                                    In_Return_Context => True),
-                   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,
-                   Condition => Check_Cond,
-                   Reason    => PE_Accessibility_Check_Failed));
-
-               --  If constant folding has happened on the condition for the
-               --  generated error, then warn about it being unconditional when
-               --  we know an error will be raised.
-
-               if Nkind (Check_Cond) = N_Identifier
-                 and then Entity (Check_Cond) = Standard_True
-               then
-                  Error_Msg_N
-                    ("access discriminant in return object would be a dangling"
-                     & " reference", Return_Stmt);
-               end if;
-            end if;
-
-            --  Iterate over the discriminants, except when we have encountered
-            --  a named association since the discriminant order becomes
-            --  irrelevant in that case.
-
-            if not Assoc_Present then
-               Next_Discriminant (Disc);
-            end if;
-
-            --  Iterate over associations
-
-            if not Is_List_Member (Assoc) then
-               exit;
-            else
-               Nlists.Next (Assoc);
-            end if;
-         end loop;
-      end Check_Return_Construct_Accessibility;
-
       -------------------------------------
       -- Check_Return_Subtype_Indication --
       -------------------------------------
@@ -1495,7 +982,7 @@ package body Sem_Ch6 is
             Resolve (Expr, R_Type);
             Check_Limited_Return (N, Expr, R_Type);
 
-            Check_Return_Construct_Accessibility (N);
+            Check_Return_Construct_Accessibility (N, Stm_Entity);
 
             --  Ada 2022 (AI12-0269): Any return statement that applies to a
             --  nonreturning function shall be a simple_return_statement with
@@ -1551,7 +1038,7 @@ package body Sem_Ch6 is
 
             Check_References (Stm_Entity);
 
-            Check_Return_Construct_Accessibility (N);
+            Check_Return_Construct_Accessibility (N, Stm_Entity);
 
             --  Check RM 6.5 (5.9/3)