[multiple changes]

[platform/upstream/gcc.git] / gcc / ada / sem_ch10.adb

diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 170f261..6b61a87 100644 (file)
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -3373,6 +3373,11 @@ package body Sem_Ch10 is
       --  units. The shadow entities are created when the inserted clause is
       --  analyzed. Implements Ada 2005 (AI-50217).
 
+      function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
+      --  When compiling a unit Q descended from some parent unit P, a limited
+      --  with_clause in the context of P that names some other ancestor of Q
+      --  must not be installed because the ancestor is immediately visible.
+
       ---------------------
       -- Check_Renamings --
       ---------------------
@@ -3645,6 +3650,22 @@ package body Sem_Ch10 is
          New_Nodes_OK := New_Nodes_OK - 1;
       end Expand_Limited_With_Clause;
 
+      ----------------------
+      -- Is_Ancestor_Unit --
+      ----------------------
+
+      function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is
+         E1 : constant Entity_Id := Defining_Entity (Unit (U1));
+         E2 : Entity_Id;
+      begin
+         if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then
+            E2 := Defining_Entity (Unit (Library_Unit (U2)));
+            return Is_Ancestor_Package (E1, E2);
+         else
+            return False;
+         end if;
+      end Is_Ancestor_Unit;
+
    --  Start of processing for Install_Limited_Context_Clauses
 
    begin
@@ -3678,6 +3699,9 @@ package body Sem_Ch10 is
 
             if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
               and then not Limited_View_Installed (Item)
+              and then
+                not Is_Ancestor_Unit
+                      (Library_Unit (Item), Cunit (Current_Sem_Unit))
             then
                if not Private_Present (Item)
                  or else Private_Present (N)
@@ -4000,13 +4024,54 @@ package body Sem_Ch10 is
 
          --  If the item is a private with-clause on a child unit, the parent
          --  may have been installed already, but the child unit must remain
-         --  invisible until installed in a private part or body.
+         --  invisible until installed in a private part or body, unless there
+         --  is already a regular with_clause for it in the current unit.
 
          elsif Private_Present (Item) then
             Id := Entity (Name (Item));
 
             if Is_Child_Unit (Id) then
-               Set_Is_Visible_Child_Unit (Id, False);
+               declare
+                  Clause : Node_Id;
+
+                  function In_Context return Boolean;
+                  --  Scan context of current unit, to check whether there is
+                  --  a with_clause on the same unit as a private with-clause
+                  --  on a parent, in which case child unit is visible. If the
+                  --  unit is a grand-child, the same applies to its parent.
+
+                  ----------------
+                  -- In_Context --
+                  ----------------
+
+                  function In_Context return Boolean is
+                  begin
+                     Clause :=
+                       First (Context_Items (Cunit (Current_Sem_Unit)));
+                     while Present (Clause) loop
+                        if Nkind (Clause) = N_With_Clause
+                          and then Comes_From_Source (Clause)
+                          and then Is_Entity_Name (Name (Clause))
+                          and then not Private_Present (Clause)
+                        then
+                           if Entity (Name (Clause)) = Id
+                             or else
+                               (Nkind (Name (Clause)) = N_Expanded_Name
+                                 and then Entity (Prefix (Name (Clause))) = Id)
+                           then
+                              return True;
+                           end if;
+                        end if;
+
+                        Next (Clause);
+                     end loop;
+
+                     return False;
+                  end In_Context;
+
+               begin
+                  Set_Is_Visible_Child_Unit (Id, In_Context);
+               end;
             end if;
          end if;
 
@@ -5311,7 +5376,7 @@ package body Sem_Ch10 is
          --  and the full-view.
 
          if No (Class_Wide_Type (T)) then
-            CW := Make_Defining_Identifier (Loc,  New_Internal_Name ('S'));
+            CW := Make_Temporary (Loc, 'S');
 
             --  Set parent to be the same as the parent of the tagged type.
             --  We need a parent field set, and it is supposed to point to
@@ -5363,9 +5428,7 @@ package body Sem_Ch10 is
          Sloc_Value : Source_Ptr;
          Id_Char    : Character) return Entity_Id
       is
-         E : constant Entity_Id :=
-               Make_Defining_Identifier (Sloc_Value,
-                 Chars => New_Internal_Name (Id_Char));
+         E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
 
       begin
          Set_Ekind       (E, Kind);
@@ -5440,9 +5503,7 @@ package body Sem_Ch10 is
 
       --  Build the header of the limited_view
 
-      Lim_Header :=
-        Make_Defining_Identifier (Sloc (N),
-          Chars => New_Internal_Name (Id_Char => 'Z'));
+      Lim_Header := Make_Temporary (Sloc (N), 'Z');
       Set_Ekind (Lim_Header, E_Package);
       Set_Is_Internal (Lim_Header);
       Set_Limited_View (P, Lim_Header);
@@ -5500,9 +5561,7 @@ package body Sem_Ch10 is
          then
             return True;
 
-         elsif Ekind (E) = E_Generic_Function
-           or else Ekind (E) = E_Generic_Procedure
-         then
+         elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
             return True;
 
          elsif Ekind (E) = E_Generic_Package
@@ -5543,10 +5602,7 @@ package body Sem_Ch10 is
       then
          Set_Body_Needed_For_SAL (Unit_Name);
 
-      elsif Ekind (Unit_Name) = E_Generic_Procedure
-              or else
-            Ekind (Unit_Name) = E_Generic_Function
-      then
+      elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then
          Set_Body_Needed_For_SAL (Unit_Name);
 
       elsif Is_Subprogram (Unit_Name)