[COMMITTED] ada: Fix internal error on quantified expression with predicated type

[COMMITTED] ada: Fix internal error on quantified expression with predicated type

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

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.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 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 9ece773304a..d1458f58784 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 391cade9eac..c8599d47593 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -312,11 +312,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);
 
@@ -331,7 +332,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;
@@ -6721,6 +6721,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 --
    ------------------------
@@ -27724,7 +27749,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 7bb8cdbe3f3..3edc158c749 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
-- 
2.40.0