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 --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 7a9045432bbee9b79aace91c56babe91ffb430c9..d2bb758fab1742229cdad2ccff66f54354285520 100644 (file)
--- 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 1030a38c8bd56d6708cfa897acdc8e98672240ec..7de68a10b1861e202a6beddf29a562c62994e3fc 100644 (file)
--- 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 4029b0718aa61d3e87dc0d780b36d4facfcd22c2..f53858f48863df3e6cb0d40af9bd348eb2d14d4f 100644 (file)
--- 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