ada: Fix infinite loop with multiple limited with clauses

This occurs when one of the types has an incomplete declaration in addition
to its full declaration in its package. In this case AI05-129 says that the
incomplete type is not part of the limited view of the package, i.e. only
the full view is. Now, in the GNAT implementation, it's the opposite in the
regular view of the package, i.e. the incomplete type is the visible one.

That's why the implementation needs to also swap the types on the visibility
chain while it is swapping the views when the clauses are either installed
or removed. This works correctly for the installation, but does not for the
removal, so this change rewrites the code doing the latter.

gcc/ada/
	PR ada/111434
	* sem_ch10.adb (Replace): New procedure to replace an entity with
	another on the homonym chain.
	(Install_Limited_With_Clause): Rename Non_Lim_View to Typ for the
	sake of consistency.  Call Replace to do the replacements and split
	the code into the regular and the special cases.  Add debuggging
	output controlled by -gnatdi.
	(Install_With_Clause): Print the Parent_With and Implicit_With flags
	in the debugging output controlled by -gnatdi.
	(Remove_Limited_With_Unit.Restore_Chain_For_Shadow (Shadow)): Rewrite
	using a direct replacement of E4 by E2.   Call Replace to do the
	replacements.  Add debuggging output controlled by -gnatdi.

diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index a6cbe466b75e9dd938e372728a2f6555ad7b65b7..ba4beae285160c40f3aa0371d92eefff993277d8 100644 (file)
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -238,6 +238,9 @@ package body Sem_Ch10 is
    --  Reset all visibility flags on unit after compiling it, either as a main
    --  unit or as a unit in the context.
 
+   procedure Replace (Old_E, New_E : Entity_Id);
+   --  Replace Old_E by New_E on visibility list
+
    procedure Unchain (E : Entity_Id);
    --  Remove single entity from visibility list
 
@@ -5310,15 +5313,12 @@ package body Sem_Ch10 is
               and then not Is_Child_Unit (Lim_Typ)
             then
                declare
-                  Non_Lim_View : constant Entity_Id :=
-                                   Non_Limited_View (Lim_Typ);
+                  Typ : constant Entity_Id := Non_Limited_View (Lim_Typ);
 
                   Prev : Entity_Id;
 
                begin
-                  Prev := Current_Entity (Lim_Typ);
-
-                  --  Replace Non_Lim_View in the homonyms list, so that the
+                  --  Replace Typ by Lim_Typ in the homonyms list, so that the
                   --  limited view becomes available.
 
                   --  If the nonlimited view is a record with an anonymous
@@ -5350,38 +5350,47 @@ package body Sem_Ch10 is
                   --
                   --  [*] denotes the visible entity (Current_Entity)
 
-                  if Prev = Non_Lim_View
-                    or else
-                      (Ekind (Prev) = E_Incomplete_Type
-                        and then Full_View (Prev) = Non_Lim_View)
-                    or else
-                      (Ekind (Prev) = E_Incomplete_Type
-                        and then From_Limited_With (Prev)
-                        and then
-                          Ekind (Non_Limited_View (Prev)) = E_Incomplete_Type
-                        and then
-                          Full_View (Non_Limited_View (Prev)) = Non_Lim_View)
-                  then
-                     Set_Current_Entity (Lim_Typ);
+                  Prev := Current_Entity (Lim_Typ);
 
-                  else
-                     while Present (Homonym (Prev))
-                       and then Homonym (Prev) /= Non_Lim_View
-                     loop
-                        Prev := Homonym (Prev);
-                     end loop;
+                  while Present (Prev) loop
+                     --  This is a regular replacement
 
-                     Set_Homonym (Prev, Lim_Typ);
-                  end if;
+                     if Prev = Typ
+                       or else (Ekind (Prev) = E_Incomplete_Type
+                                 and then Full_View (Prev) = Typ)
+                     then
+                        Replace (Prev, Lim_Typ);
 
-                  Set_Homonym (Lim_Typ, Homonym (Non_Lim_View));
-               end;
+                        if Debug_Flag_I then
+                           Write_Str ("   (homonym) replace ");
+                           Write_Name (Chars (Typ));
+                           Write_Eol;
+                        end if;
 
-               if Debug_Flag_I then
-                  Write_Str ("   (homonym) chain ");
-                  Write_Name (Chars (Lim_Typ));
-                  Write_Eol;
-               end if;
+                        exit;
+
+                     --  This is where E1 is replaced with E4
+
+                     elsif Ekind (Prev) = E_Incomplete_Type
+                       and then From_Limited_With (Prev)
+                       and then
+                         Ekind (Non_Limited_View (Prev)) = E_Incomplete_Type
+                       and then Full_View (Non_Limited_View (Prev)) = Typ
+                     then
+                        Replace (Prev, Lim_Typ);
+
+                        if Debug_Flag_I then
+                           Write_Str ("   (homonym) E1 -> E4 ");
+                           Write_Name (Chars (Typ));
+                           Write_Eol;
+                        end if;
+
+                        exit;
+                     end if;
+
+                     Prev := Homonym (Prev);
+                  end loop;
+               end;
             end if;
 
             Next_Entity (Lim_Typ);
@@ -5474,6 +5483,10 @@ package body Sem_Ch10 is
       if Debug_Flag_I then
          if Private_Present (With_Clause) then
             Write_Str ("install private withed unit ");
+         elsif Parent_With (With_Clause) then
+            Write_Str ("install parent withed unit ");
+         elsif Implicit_With (With_Clause) then
+            Write_Str ("install implicit withed unit ");
          else
             Write_Str ("install withed unit ");
          end if;
@@ -6816,9 +6829,10 @@ package body Sem_Ch10 is
          ------------------------------
 
          procedure Restore_Chain_For_Shadow (Shadow : Entity_Id) is
-            Is_E3 : Boolean;
+            Typ : constant Entity_Id := Non_Limited_View (Shadow);
+            pragma Assert (not In_Chain (Typ));
+
             Prev  : Entity_Id;
-            Typ   : Entity_Id;
 
          begin
             --  If the package has incomplete types, the limited view of the
@@ -6827,9 +6841,8 @@ package body Sem_Ch10 is
             --  the incomplete type at stake. This in turn has a full view
             --  E3 that is the full declaration, with a corresponding
             --  shadow entity E4. When reinstalling the nonlimited view,
-            --  the nonvisible entity E1 is first replaced with E2, but then
-            --  E3 must *not* become the visible entity as it is replacing E4
-            --  in the homonyms list and simply be ignored.
+            --  the visible entity E4 is replaced directly with E2 in the
+            --  the homonyms list and E3 is simply ignored.
             --
             --           regular views          limited views
             --
@@ -6842,40 +6855,42 @@ package body Sem_Ch10 is
             --
             --  [*] denotes the visible entity (Current_Entity)
 
-            Typ := Non_Limited_View (Shadow);
-            pragma Assert (not In_Chain (Typ));
+            Prev := Current_Entity (Shadow);
 
-            Is_E3 := Nkind (Parent (Typ)) = N_Full_Type_Declaration
-              and then Present (Incomplete_View (Parent (Typ)));
+            while Present (Prev) loop
+               --  This is a regular replacement
 
-            Prev := Current_Entity (Shadow);
+               if Prev = Shadow then
+                  Replace (Prev, Typ);
 
-            if Prev = Shadow then
-               if Is_E3 then
-                  Set_Name_Entity_Id (Chars (Prev), Homonym (Prev));
-                  return;
+                  if Debug_Flag_I then
+                     Write_Str ("   (homonym) replace ");
+                     Write_Name (Chars (Typ));
+                     Write_Eol;
+                  end if;
 
-               else
-                  Set_Current_Entity (Typ);
-               end if;
+                  exit;
 
-            else
-               while Present (Homonym (Prev))
-                 and then Homonym (Prev) /= Shadow
-               loop
-                  Prev := Homonym (Prev);
-               end loop;
+               --  This is where E4 is replaced with E2
 
-               if Is_E3 then
-                  Set_Homonym (Prev, Homonym (Shadow));
-                  return;
+               elsif Ekind (Prev) = E_Incomplete_Type
+                 and then From_Limited_With (Prev)
+                 and then Ekind (Typ) = E_Incomplete_Type
+                 and then Full_View (Typ) = Non_Limited_View (Prev)
+               then
+                  Replace (Prev, Typ);
 
-               else
-                  Set_Homonym (Prev, Typ);
+                  if Debug_Flag_I then
+                     Write_Str ("   (homonym) E4 -> E2 ");
+                     Write_Name (Chars (Typ));
+                     Write_Eol;
+                  end if;
+
+                  exit;
                end if;
-            end if;
 
-            Set_Homonym (Typ, Homonym (Shadow));
+               Prev := Homonym (Prev);
+            end loop;
          end Restore_Chain_For_Shadow;
 
          --------------------
@@ -7177,6 +7192,35 @@ package body Sem_Ch10 is
       null;
    end sm;
 
+   -------------
+   -- Replace --
+   -------------
+
+   procedure Replace (Old_E, New_E : Entity_Id) is
+      Prev : Entity_Id;
+
+   begin
+      Prev := Current_Entity (Old_E);
+
+      if No (Prev) then
+         return;
+
+      elsif Prev = Old_E then
+         Set_Current_Entity (New_E);
+         Set_Homonym (New_E, Homonym (Old_E));
+
+      else
+         while Present (Prev) and then Homonym (Prev) /= Old_E loop
+            Prev := Homonym (Prev);
+         end loop;
+
+         if Present (Prev) then
+            Set_Homonym (Prev, New_E);
+            Set_Homonym (New_E, Homonym (Old_E));
+         end if;
+      end if;
+   end Replace;
+
    -------------
    -- Unchain --
    -------------