[gcc r13-7860] ada: Fix internal error on quantified expression with predicated type

[Eric Botcazou]

https://gcc.gnu.org/g:dce277e3410c348d23dffe2403ddd5fac689e26c

commit r13-7860-gdce277e3410c348d23dffe2403ddd5fac689e26c
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Wed Feb 15 15:52:00 2023 +0100

    ada: Fix internal error on quantified expression with predicated type
    
    The problem is that the special function created by the compiler to check
    the predicate does not inherit the public status of the type, because it
    is generated as part of the freezing of the quantified expression, which
    occurs from within a couple of intermediate internal scopes.
    
    gcc/ada/
    
            * sem_ch13.adb (Build_Predicate_Function_Declaration): Adjust the
            commentary to the current implementation.
            * sem_util.ads (Current_Scope_No_Loops): Move around.
            (Current_Scope_No_Loops_No_Blocks): New declaration.
            (Add_Block_Identifier): Fix formatting.
            * sem_util.adb (Add_Block_Identifier): Likewise.
            (Current_Scope_No_Loops_No_Blocks): New function.
            (Set_Public_Status): Call Current_Scope_No_Loops_No_Blocks instead
            of Current_Scope to get the current scope.

Diff:
---
 gcc/ada/sem_ch13.adb |  4 +---
 gcc/ada/sem_util.adb | 35 ++++++++++++++++++++++++++++++-----
 gcc/ada/sem_util.ads | 15 +++++++++------
 3 files changed, 40 insertions(+), 14 deletions(-)

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 7a9045432bb..d2bb758fab1 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -133,9 +133,7 @@ package body Sem_Ch13 is
    function Build_Predicate_Function_Declaration
       (Typ : Entity_Id) return Node_Id;
    --  Build the declaration for a predicate function. The declaration is built
-   --  at the end of the declarative part containing the type definition, which
-   --  may be before the freeze point of the type. The predicate expression is
-   --  preanalyzed at this point, to catch visibility errors.
+   --  at the same time as the body but inserted before, as explained below.
 
    procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
    --  If Typ has predicates (indicated by Has_Predicates being set for Typ),
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 1030a38c8bd..7de68a10b18 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -309,11 +309,12 @@ package body Sem_Util is
    --------------------------
 
    procedure Add_Block_Identifier
-       (N : Node_Id;
-        Id : out Entity_Id;
-        Scope : Entity_Id := Current_Scope)
+     (N     : Node_Id;
+      Id    : out Entity_Id;
+      Scope : Entity_Id := Current_Scope)
    is
       Loc : constant Source_Ptr := Sloc (N);
+
    begin
       pragma Assert (Nkind (N) = N_Block_Statement);
 
@@ -328,7 +329,6 @@ package body Sem_Util is
          Id := New_Internal_Entity (E_Block, Scope, Loc, 'B');
          Set_Etype  (Id, Standard_Void_Type);
          Set_Parent (Id, N);
-
          Set_Identifier (N, New_Occurrence_Of (Id, Loc));
          Set_Block_Node (Id, Identifier (N));
       end if;
@@ -6705,6 +6705,31 @@ package body Sem_Util is
       return S;
    end Current_Scope_No_Loops;
 
+   --------------------------------------
+   -- Current_Scope_No_Loops_No_Blocks --
+   --------------------------------------
+
+   function Current_Scope_No_Loops_No_Blocks return Entity_Id is
+      S : Entity_Id;
+
+   begin
+      --  Examine the scope stack starting from the current scope and skip any
+      --  internally generated loops and blocks.
+
+      S := Current_Scope;
+      while Present (S) and then S /= Standard_Standard loop
+         if Ekind (S) in E_Loop | E_Block
+           and then not Comes_From_Source (S)
+         then
+            S := Scope (S);
+         else
+            exit;
+         end if;
+      end loop;
+
+      return S;
+   end Current_Scope_No_Loops_No_Blocks;
+
    ------------------------
    -- Current_Subprogram --
    ------------------------
@@ -27670,7 +27695,7 @@ package body Sem_Util is
    -----------------------
 
    procedure Set_Public_Status (Id : Entity_Id) is
-      S : constant Entity_Id := Current_Scope;
+      S : constant Entity_Id := Current_Scope_No_Loops_No_Blocks;
 
       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
       --  Determines if E is defined within handled statement sequence or
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 4029b0718aa..f53858f4886 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -639,18 +639,21 @@ package Sem_Util is
    function Current_Scope return Entity_Id;
    --  Get entity representing current scope
 
+   function Current_Scope_No_Loops return Entity_Id;
+   --  Return the current scope ignoring internally generated loops
+
+   function Current_Scope_No_Loops_No_Blocks return Entity_Id;
+   --  Return the current scope ignoring internally generated loops and blocks
+
    procedure Add_Block_Identifier
-       (N : Node_Id;
-        Id : out Entity_Id;
-        Scope : Entity_Id := Current_Scope);
+     (N     : Node_Id;
+      Id    : out Entity_Id;
+      Scope : Entity_Id := Current_Scope);
    --  Given a block statement N, generate an internal E_Block label and make
    --  it the identifier of the block. Scope denotes the scope in which the
    --  generated entity Id is created and defaults to the current scope. If the
    --  block already has an identifier, Id returns the entity of its label.
 
-   function Current_Scope_No_Loops return Entity_Id;
-   --  Return the current scope ignoring internally generated loops
-
    function Current_Subprogram return Entity_Id;
    --  Returns current enclosing subprogram. If Current_Scope is a subprogram,
    --  then that is what is returned, otherwise the Enclosing_Subprogram of the