diff mbox series

[COMMITTED] ada: Rework fix for internal error on quantified expression with predicated type

Message ID 20230523080925.1875043-1-poulhies@adacore.com
State New
Headers show
Series [COMMITTED] ada: Rework fix for internal error on quantified expression with predicated type | expand

Commit Message

Marc Poulhiès May 23, 2023, 8:09 a.m. UTC 
From: Eric Botcazou <ebotcazou@adacore.com>

It turns out that skipping compiler-generated block scopes is problematic
when computing the public status of a subprogram, because this subprogram
may end up being nested in the elaboration procedure of a package spec or
body, in which case it may not be public.

This replaces the original fix with a pair of Push_Scope/Pop_Scope in the
Build_Predicate_Function procedure, as done elsewhere in similar cases.

gcc/ada/

	* sem_ch13.adb (Build_Predicate_Functions): If the current scope
	is not that of the type, push this scope and pop it at the end.
	* sem_util.ads (Current_Scope_No_Loops_No_Blocks): Delete.
	* sem_util.adb (Current_Scope_No_Loops_No_Blocks): Likewise.
	(Set_Public_Status): Call again Current_Scope.

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

---
 gcc/ada/sem_ch13.adb | 26 ++++++++++++++++++++------
 gcc/ada/sem_util.adb | 27 +--------------------------
 gcc/ada/sem_util.ads |  3 ---
 3 files changed, 21 insertions(+), 35 deletions(-)
diff mbox series

Patch

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index d1458f58784..983f877e001 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -9921,6 +9921,10 @@  package body Sem_Ch13 is
    procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (Typ);
 
+      Saved_GM  : constant Ghost_Mode_Type := Ghost_Mode;
+      Saved_IGR : constant Node_Id         := Ignored_Ghost_Region;
+      --  Save the Ghost-related attributes to restore on exit
+
       Expr : Node_Id;
       --  This is the expression for the result of the function. It is
       --  is build by connecting the component predicates with AND THEN.
@@ -9939,6 +9943,9 @@  package body Sem_Ch13 is
       SId : Entity_Id;
       --  Its entity
 
+      Restore_Scope : Boolean;
+      --  True if the current scope must be restored on exit
+
       Ancestor_Predicate_Function_Called : Boolean := False;
       --  Does this predicate function include a call to the
       --  predication function of an ancestor subtype?
@@ -10190,12 +10197,6 @@  package body Sem_Ch13 is
          Replace_Type_References (N, Typ);
       end Replace_Current_Instance_References;
 
-      --  Local variables
-
-      Saved_GM  : constant Ghost_Mode_Type := Ghost_Mode;
-      Saved_IGR : constant Node_Id         := Ignored_Ghost_Region;
-      --  Save the Ghost-related attributes to restore on exit
-
    --  Start of processing for Build_Predicate_Function
 
    begin
@@ -10234,6 +10235,15 @@  package body Sem_Ch13 is
          return;
       end if;
 
+      --  Ensure that the declarations are added to the scope of the type
+
+      if Scope (Typ) /= Current_Scope then
+         Push_Scope (Scope (Typ));
+         Restore_Scope := True;
+      else
+         Restore_Scope := False;
+      end if;
+
       --  The related type may be subject to pragma Ghost. Set the mode now to
       --  ensure that the predicate functions are properly marked as Ghost.
 
@@ -10652,6 +10662,10 @@  package body Sem_Ch13 is
       end if;
 
       Restore_Ghost_Region (Saved_GM, Saved_IGR);
+
+      if Restore_Scope then
+         Pop_Scope;
+      end if;
    end Build_Predicate_Function;
 
    ------------------------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 22dc9376b92..9a0197cb45c 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6722,31 +6722,6 @@  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 --
    ------------------------
@@ -27763,7 +27738,7 @@  package body Sem_Util is
    -----------------------
 
    procedure Set_Public_Status (Id : Entity_Id) is
-      S : constant Entity_Id := Current_Scope_No_Loops_No_Blocks;
+      S : constant Entity_Id := Current_Scope;
 
       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 3edc158c749..253d1dadeee 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -642,9 +642,6 @@  package Sem_Util is
    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;