[multiple changes]

2012-10-04  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Set_CPP_Constructors_Old): Removed.
	(Set_CPP_Constructors): Code cleanup.

2012-10-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Is_Ancestor_Unit): Make global, for use elsewhere.
	(Install_Private_with_Clauses): if clause is private and limited,
	do not install the limited view if the library unit is an ancestor
	of the unit being compiled.  This unusual configuration occurs
	when compiling a unit DDP, when an ancestor P of DDP has a
	private limited with clause on a descendant of P that is itself
	an ancestor of DDP.

From-SVN: r192069

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index db728dd1694bbb3aec1c61a2dc2cc319002a0909..bb4f042b923c4535a1951fb90351c29f1b607b95 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2012-10-04  Javier Miranda  <miranda@adacore.com>
+
+       * exp_disp.adb (Set_CPP_Constructors_Old): Removed.
+       (Set_CPP_Constructors): Code cleanup.
+
+2012-10-04  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch10.adb (Is_Ancestor_Unit): Make global, for use elsewhere.
+       (Install_Private_with_Clauses): if clause is private and limited,
+       do not install the limited view if the library unit is an ancestor
+       of the unit being compiled.  This unusual configuration occurs
+       when compiling a unit DDP, when an ancestor P of DDP has a
+       private limited with clause on a descendant of P that is itself
+       an ancestor of DDP.
+
 2012-10-04  Vincent Celier  <celier@adacore.com>
 
        * prj-proc.adb (Process_Package_Declaration): Use project

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 6db86e14ef0e51abecf7569d90877c892674f1c8..9b5cb5716ea69a77b96b4d6030ebf0ec2ca11480 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -8447,152 +8447,49 @@ package body Exp_Disp is
 
    procedure Set_CPP_Constructors (Typ : Entity_Id) is
 
-      procedure Set_CPP_Constructors_Old (Typ : Entity_Id);
-      --  For backward compatibility this routine handles CPP constructors
-      --  of non-tagged types.
-
-      procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is
-         Loc   : Source_Ptr;
-         Init  : Entity_Id;
-         E     : Entity_Id;
-         Found : Boolean := False;
-         P     : Node_Id;
-         Parms : List_Id;
+      function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
+      --  Duplicate the parameters profile of the imported C++ constructor
+      --  adding an access to the object as an additional parameter.
 
-         Covers_Default_Constructor : Entity_Id := Empty;
+      function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
+         Loc   : constant Source_Ptr := Sloc (E);
+         Parms : List_Id;
+         P     : Node_Id;
 
       begin
-         --  Look for the constructor entities
-
-         E := Next_Entity (Typ);
-         while Present (E) loop
-            if Ekind (E) = E_Function
-              and then Is_Constructor (E)
-            then
-               --  Create the init procedure
-
-               Found := True;
-               Loc   := Sloc (E);
-               Init  := Make_Defining_Identifier (Loc,
-                          Make_Init_Proc_Name (Typ));
-               Parms :=
-                 New_List (
-                   Make_Parameter_Specification (Loc,
-                     Defining_Identifier =>
-                       Make_Defining_Identifier (Loc, Name_X),
-                     Parameter_Type =>
-                       New_Reference_To (Typ, Loc)));
-
-               if Present (Parameter_Specifications (Parent (E))) then
-                  P := First (Parameter_Specifications (Parent (E)));
-                  while Present (P) loop
-                     Append_To (Parms,
-                       Make_Parameter_Specification (Loc,
-                         Defining_Identifier =>
-                           Make_Defining_Identifier (Loc,
-                             Chars (Defining_Identifier (P))),
-                         Parameter_Type =>
-                           New_Copy_Tree (Parameter_Type (P)),
-                         Expression => New_Copy_Tree (Expression (P))));
-                     Next (P);
-                  end loop;
-               end if;
-
-               Discard_Node (
-                 Make_Subprogram_Declaration (Loc,
-                   Make_Procedure_Specification (Loc,
-                     Defining_Unit_Name => Init,
-                     Parameter_Specifications => Parms)));
-
-               Set_Init_Proc (Typ, Init);
-               Set_Is_Imported    (Init);
-               Set_Is_Constructor (Init);
-               Set_Interface_Name (Init, Interface_Name (E));
-               Set_Convention     (Init, Convention_CPP);
-               Set_Is_Public      (Init);
-               Set_Has_Completion (Init);
-
-               --  If this constructor has parameters and all its parameters
-               --  have defaults then it covers the default constructor. The
-               --  semantic analyzer ensures that only one constructor with
-               --  defaults covers the default constructor.
-
-               if Present (Parameter_Specifications (Parent (E)))
-                 and then Needs_No_Actuals (E)
-               then
-                  Covers_Default_Constructor := Init;
-               end if;
-            end if;
-
-            Next_Entity (E);
-         end loop;
-
-         --  If there are no constructors, mark the type as abstract since we
-         --  won't be able to declare objects of that type.
-
-         if not Found then
-            Set_Is_Abstract_Type (Typ);
+         Parms :=
+           New_List (
+             Make_Parameter_Specification (Loc,
+               Defining_Identifier =>
+                 Make_Defining_Identifier (Loc, Name_uInit),
+               Parameter_Type      => New_Reference_To (Typ, Loc)));
+
+         if Present (Parameter_Specifications (Parent (E))) then
+            P := First (Parameter_Specifications (Parent (E)));
+            while Present (P) loop
+               Append_To (Parms,
+                 Make_Parameter_Specification (Loc,
+                   Defining_Identifier =>
+                     Make_Defining_Identifier (Loc,
+                       Chars => Chars (Defining_Identifier (P))),
+                   Parameter_Type      => New_Copy_Tree (Parameter_Type (P)),
+                   Expression          => New_Copy_Tree (Expression (P))));
+               Next (P);
+            end loop;
          end if;
 
-         --  Handle constructor that has all its parameters with defaults and
-         --  hence it covers the default constructor. We generate a wrapper IP
-         --  which calls the covering constructor.
-
-         if Present (Covers_Default_Constructor) then
-            declare
-               Body_Stmts        : List_Id;
-               Wrapper_Id        : Entity_Id;
-               Wrapper_Body_Node : Node_Id;
-            begin
-               Loc := Sloc (Covers_Default_Constructor);
-
-               Body_Stmts := New_List (
-                 Make_Procedure_Call_Statement (Loc,
-                   Name => New_Reference_To (Covers_Default_Constructor, Loc),
-                   Parameter_Associations => New_List (
-                     Make_Identifier (Loc, Name_uInit))));
-
-               Wrapper_Id := Make_Defining_Identifier (Loc,
-                 Make_Init_Proc_Name (Typ));
-
-               Wrapper_Body_Node :=
-                 Make_Subprogram_Body (Loc,
-                   Specification =>
-                     Make_Procedure_Specification (Loc,
-                       Defining_Unit_Name => Wrapper_Id,
-                       Parameter_Specifications => New_List (
-                         Make_Parameter_Specification (Loc,
-                           Defining_Identifier =>
-                             Make_Defining_Identifier (Loc, Name_uInit),
-                           Parameter_Type =>
-                             New_Reference_To (Typ, Loc)))),
-                   Declarations => No_List,
-                   Handled_Statement_Sequence =>
-                     Make_Handled_Sequence_Of_Statements (Loc,
-                       Statements => Body_Stmts,
-                       Exception_Handlers => No_List));
-
-               Discard_Node (Wrapper_Body_Node);
-               Set_Init_Proc (Typ, Wrapper_Id);
-            end;
-         end if;
-      end Set_CPP_Constructors_Old;
+         return Parms;
+      end Gen_Parameters_Profile;
 
       --  Local variables
 
-      Loc   : Source_Ptr;
-      E     : Entity_Id;
-      Found : Boolean := False;
-      P     : Node_Id;
-      Parms : List_Id;
-
-      Constructor_Decl_Node : Node_Id;
-      Constructor_Id        : Entity_Id;
-      Wrapper_Id            : Entity_Id;
-      Wrapper_Body_Node     : Node_Id;
-      Actuals               : List_Id;
-      Body_Stmts            : List_Id;
-      Init_Tags_List        : List_Id;
+      Loc     : Source_Ptr;
+      E       : Entity_Id;
+      Found   : Boolean := False;
+      IP      : Entity_Id;
+      IP_Body : Node_Id;
+      P       : Node_Id;
+      Parms   : List_Id;
 
       Covers_Default_Constructor : Entity_Id := Empty;
 
@@ -8601,22 +8498,6 @@ package body Exp_Disp is
    begin
       pragma Assert (Is_CPP_Class (Typ));
 
-      --  For backward compatibility the compiler accepts C++ classes
-      --  imported through non-tagged record types. In such case the
-      --  wrapper of the C++ constructor is useless because the _tag
-      --  component is not available.
-
-      --  Example:
-      --     type Root is limited record ...
-      --     pragma Import (CPP, Root);
-      --     function New_Root return Root;
-      --     pragma CPP_Constructor (New_Root, ... );
-
-      if not Is_Tagged_Type (Typ) then
-         Set_CPP_Constructors_Old (Typ);
-         return;
-      end if;
-
       --  Look for the constructor entities
 
       E := Next_Entity (Typ);
@@ -8626,156 +8507,167 @@ package body Exp_Disp is
          then
             Found := True;
             Loc   := Sloc (E);
+            Parms := Gen_Parameters_Profile (E);
+            IP    :=
+              Make_Defining_Identifier (Loc,
+                Chars => Make_Init_Proc_Name (Typ));
+
+            --  Case 1: Constructor of non-tagged type
+
+            --  If the C++ class has no virtual methods then the matching Ada
+            --  type is a non-tagged record type. In such case there is no need
+            --  to generate a wrapper of the C++ constructor because the _tag
+            --  component is not available.
+
+            if not Is_Tagged_Type (Typ) then
+               Discard_Node
+                 (Make_Subprogram_Declaration (Loc,
+                    Specification =>
+                      Make_Procedure_Specification (Loc,
+                        Defining_Unit_Name       => IP,
+                        Parameter_Specifications => Parms)));
+
+               Set_Init_Proc (Typ, IP);
+               Set_Is_Imported    (IP);
+               Set_Is_Constructor (IP);
+               Set_Interface_Name (IP, Interface_Name (E));
+               Set_Convention     (IP, Convention_CPP);
+               Set_Is_Public      (IP);
+               Set_Has_Completion (IP);
+
+            --  Case 2: Constructor of a tagged type
+
+            --  In this case we generate the IP as a wrapper of the the
+            --  C++ constructor because IP must also save copy of the _tag
+            --  generated in the C++ side. The copy of the _tag is used by
+            --  Build_CPP_Init_Procedure to elaborate derivations of C++ types.
 
-            --  Generate the declaration of the imported C++ constructor
-
-            Parms :=
-              New_List (
-                Make_Parameter_Specification (Loc,
-                  Defining_Identifier =>
-                    Make_Defining_Identifier (Loc, Name_uInit),
-                  Parameter_Type =>
-                    New_Reference_To (Typ, Loc)));
-
-            if Present (Parameter_Specifications (Parent (E))) then
-               P := First (Parameter_Specifications (Parent (E)));
-               while Present (P) loop
-                  Append_To (Parms,
-                    Make_Parameter_Specification (Loc,
-                      Defining_Identifier =>
-                        Make_Defining_Identifier (Loc,
-                          Chars (Defining_Identifier (P))),
-                      Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
-                  Next (P);
-               end loop;
-            end if;
-
-            Constructor_Id := Make_Temporary (Loc, 'P');
+            --  Generate:
+            --     procedure IP (_init : Typ; ...) is
+            --        procedure ConstructorP (_init : Typ; ...);
+            --        pragma Import (ConstructorP);
+            --     begin
+            --        ConstructorP (_init, ...);
+            --        if Typ._tag = null then
+            --           Typ._tag := _init._tag;
+            --        end if;
+            --     end IP;
 
-            Constructor_Decl_Node :=
-              Make_Subprogram_Declaration (Loc,
-                Make_Procedure_Specification (Loc,
-                  Defining_Unit_Name => Constructor_Id,
-                  Parameter_Specifications => Parms));
+            else
+               declare
+                  Body_Stmts            : constant List_Id := New_List;
+                  Constructor_Id        : Entity_Id;
+                  Constructor_Decl_Node : Node_Id;
+                  Init_Tags_List        : List_Id;
 
-            Set_Is_Imported    (Constructor_Id);
-            Set_Is_Constructor (Constructor_Id);
-            Set_Interface_Name (Constructor_Id, Interface_Name (E));
-            Set_Convention     (Constructor_Id, Convention_CPP);
-            Set_Is_Public      (Constructor_Id);
-            Set_Has_Completion (Constructor_Id);
+               begin
+                  Constructor_Id := Make_Temporary (Loc, 'P');
 
-            --  Build the wrapper of this constructor
+                  Constructor_Decl_Node :=
+                    Make_Subprogram_Declaration (Loc,
+                      Make_Procedure_Specification (Loc,
+                        Defining_Unit_Name => Constructor_Id,
+                        Parameter_Specifications => Parms));
 
-            Parms :=
-              New_List (
-                Make_Parameter_Specification (Loc,
-                  Defining_Identifier =>
-                    Make_Defining_Identifier (Loc, Name_uInit),
-                  Parameter_Type =>
-                    New_Reference_To (Typ, Loc)));
-
-            if Present (Parameter_Specifications (Parent (E))) then
-               P := First (Parameter_Specifications (Parent (E)));
-               while Present (P) loop
-                  Append_To (Parms,
-                    Make_Parameter_Specification (Loc,
-                      Defining_Identifier =>
-                        Make_Defining_Identifier (Loc,
-                          Chars (Defining_Identifier (P))),
-                      Parameter_Type      =>
-                        New_Copy_Tree (Parameter_Type (P)),
-                      Expression          => New_Copy_Tree (Expression (P))));
-                  Next (P);
-               end loop;
-            end if;
+                  Set_Is_Imported    (Constructor_Id);
+                  Set_Is_Constructor (Constructor_Id);
+                  Set_Interface_Name (Constructor_Id, Interface_Name (E));
+                  Set_Convention     (Constructor_Id, Convention_CPP);
+                  Set_Is_Public      (Constructor_Id);
+                  Set_Has_Completion (Constructor_Id);
 
-            Body_Stmts := New_List;
+                  --  Build the init procedure as a wrapper of this constructor
 
-            --  Invoke the C++ constructor
+                  Parms := Gen_Parameters_Profile (E);
 
-            Actuals := New_List;
+                  --  Invoke the C++ constructor
 
-            P := First (Parms);
-            while Present (P) loop
-               Append_To (Actuals,
-                 New_Reference_To (Defining_Identifier (P), Loc));
-               Next (P);
-            end loop;
+                  declare
+                     Actuals : constant List_Id := New_List;
 
-            Append_To (Body_Stmts,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (Constructor_Id, Loc),
-                Parameter_Associations => Actuals));
-
-            --  Initialize copies of C++ primary and secondary tags
-
-            Init_Tags_List := New_List;
-
-            declare
-               Tag_Elmt : Elmt_Id;
-               Tag_Comp : Node_Id;
-
-            begin
-               Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
-               Tag_Comp := First_Tag_Component (Typ);
+                  begin
+                     P := First (Parms);
+                     while Present (P) loop
+                        Append_To (Actuals,
+                          New_Reference_To (Defining_Identifier (P), Loc));
+                        Next (P);
+                     end loop;
 
-               while Present (Tag_Elmt)
-                 and then Is_Tag (Node (Tag_Elmt))
-               loop
-                  --  Skip the following assertion with primary tags because
-                  --  Related_Type is not set on primary tag components
+                     Append_To (Body_Stmts,
+                       Make_Procedure_Call_Statement (Loc,
+                         Name => New_Reference_To (Constructor_Id, Loc),
+                         Parameter_Associations => Actuals));
+                  end;
 
-                  pragma Assert (Tag_Comp = First_Tag_Component (Typ)
-                    or else Related_Type (Node (Tag_Elmt))
-                              = Related_Type (Tag_Comp));
+                  --  Initialize copies of C++ primary and secondary tags
 
-                  Append_To (Init_Tags_List,
-                    Make_Assignment_Statement (Loc,
-                      Name =>
-                        New_Reference_To (Node (Tag_Elmt), Loc),
-                      Expression =>
-                        Make_Selected_Component (Loc,
-                          Prefix        =>
-                            Make_Identifier (Loc, Name_uInit),
-                          Selector_Name =>
-                            New_Reference_To (Tag_Comp, Loc))));
+                  Init_Tags_List := New_List;
 
-                     Tag_Comp := Next_Tag_Component (Tag_Comp);
-                  Next_Elmt (Tag_Elmt);
-               end loop;
-            end;
+                  declare
+                     Tag_Elmt : Elmt_Id;
+                     Tag_Comp : Node_Id;
 
-            Append_To (Body_Stmts,
-              Make_If_Statement (Loc,
-                Condition =>
-                  Make_Op_Eq (Loc,
-                    Left_Opnd =>
-                      New_Reference_To
-                        (Node (First_Elmt (Access_Disp_Table (Typ))),
-                         Loc),
-                    Right_Opnd =>
-                      Unchecked_Convert_To (RTE (RE_Tag),
-                        New_Reference_To (RTE (RE_Null_Address), Loc))),
-                Then_Statements => Init_Tags_List));
+                  begin
+                     Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
+                     Tag_Comp := First_Tag_Component (Typ);
 
-            Wrapper_Id := Make_Defining_Identifier (Loc,
-                            Make_Init_Proc_Name (Typ));
+                     while Present (Tag_Elmt)
+                       and then Is_Tag (Node (Tag_Elmt))
+                     loop
+                        --  Skip the following assertion with primary tags
+                        --  because Related_Type is not set on primary tag
+                        --  components
+
+                        pragma Assert
+                          (Tag_Comp = First_Tag_Component (Typ)
+                             or else Related_Type (Node (Tag_Elmt))
+                                       = Related_Type (Tag_Comp));
+
+                        Append_To (Init_Tags_List,
+                          Make_Assignment_Statement (Loc,
+                            Name =>
+                              New_Reference_To (Node (Tag_Elmt), Loc),
+                            Expression =>
+                              Make_Selected_Component (Loc,
+                                Prefix        =>
+                                  Make_Identifier (Loc, Name_uInit),
+                                Selector_Name =>
+                                  New_Reference_To (Tag_Comp, Loc))));
 
-            Wrapper_Body_Node :=
-              Make_Subprogram_Body (Loc,
-                Specification =>
-                  Make_Procedure_Specification (Loc,
-                    Defining_Unit_Name => Wrapper_Id,
-                    Parameter_Specifications => Parms),
-                Declarations => New_List (Constructor_Decl_Node),
-                Handled_Statement_Sequence =>
-                  Make_Handled_Sequence_Of_Statements (Loc,
-                    Statements => Body_Stmts,
-                    Exception_Handlers => No_List));
+                        Tag_Comp := Next_Tag_Component (Tag_Comp);
+                        Next_Elmt (Tag_Elmt);
+                     end loop;
+                  end;
 
-            Discard_Node (Wrapper_Body_Node);
-            Set_Init_Proc (Typ, Wrapper_Id);
+                  Append_To (Body_Stmts,
+                    Make_If_Statement (Loc,
+                      Condition =>
+                        Make_Op_Eq (Loc,
+                          Left_Opnd =>
+                            New_Reference_To
+                              (Node (First_Elmt (Access_Disp_Table (Typ))),
+                               Loc),
+                          Right_Opnd =>
+                            Unchecked_Convert_To (RTE (RE_Tag),
+                              New_Reference_To (RTE (RE_Null_Address), Loc))),
+                      Then_Statements => Init_Tags_List));
+
+                  IP_Body :=
+                    Make_Subprogram_Body (Loc,
+                      Specification =>
+                        Make_Procedure_Specification (Loc,
+                          Defining_Unit_Name => IP,
+                          Parameter_Specifications => Parms),
+                      Declarations => New_List (Constructor_Decl_Node),
+                      Handled_Statement_Sequence =>
+                        Make_Handled_Sequence_Of_Statements (Loc,
+                          Statements => Body_Stmts,
+                          Exception_Handlers => No_List));
+
+                  Discard_Node (IP_Body);
+                  Set_Init_Proc (Typ, IP);
+               end;
+            end if;
 
             --  If this constructor has parameters and all its parameters
             --  have defaults then it covers the default constructor. The
@@ -8785,7 +8677,7 @@ package body Exp_Disp is
             if Present (Parameter_Specifications (Parent (E)))
               and then Needs_No_Actuals (E)
             then
-               Covers_Default_Constructor := Wrapper_Id;
+               Covers_Default_Constructor := IP;
             end if;
          end if;
 
@@ -8804,39 +8696,42 @@ package body Exp_Disp is
       --  which calls the covering constructor.
 
       if Present (Covers_Default_Constructor) then
-         Loc := Sloc (Covers_Default_Constructor);
+         declare
+            Body_Stmts : List_Id;
 
-         Body_Stmts := New_List (
-           Make_Procedure_Call_Statement (Loc,
-             Name                   =>
-               New_Reference_To (Covers_Default_Constructor, Loc),
-             Parameter_Associations => New_List (
-               Make_Identifier (Loc, Name_uInit))));
+         begin
+            Loc := Sloc (Covers_Default_Constructor);
 
-         Wrapper_Id :=
-           Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+            Body_Stmts := New_List (
+              Make_Procedure_Call_Statement (Loc,
+                Name                   =>
+                  New_Reference_To (Covers_Default_Constructor, Loc),
+                Parameter_Associations => New_List (
+                  Make_Identifier (Loc, Name_uInit))));
 
-         Wrapper_Body_Node :=
-           Make_Subprogram_Body (Loc,
-             Specification              =>
-               Make_Procedure_Specification (Loc,
-                 Defining_Unit_Name       => Wrapper_Id,
-                 Parameter_Specifications => New_List (
-                   Make_Parameter_Specification (Loc,
-                     Defining_Identifier =>
-                       Make_Defining_Identifier (Loc, Name_uInit),
-                     Parameter_Type      =>
-                       New_Reference_To (Typ, Loc)))),
-
-             Declarations               => No_List,
+            IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
 
-             Handled_Statement_Sequence =>
-               Make_Handled_Sequence_Of_Statements (Loc,
-                 Statements         => Body_Stmts,
-                 Exception_Handlers => No_List));
+            IP_Body :=
+              Make_Subprogram_Body (Loc,
+                Specification              =>
+                  Make_Procedure_Specification (Loc,
+                    Defining_Unit_Name       => IP,
+                    Parameter_Specifications => New_List (
+                      Make_Parameter_Specification (Loc,
+                        Defining_Identifier =>
+                          Make_Defining_Identifier (Loc, Name_uInit),
+                        Parameter_Type      => New_Reference_To (Typ, Loc)))),
 
-         Discard_Node (Wrapper_Body_Node);
-         Set_Init_Proc (Typ, Wrapper_Id);
+                Declarations               => No_List,
+
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc,
+                    Statements         => Body_Stmts,
+                    Exception_Handlers => No_List));
+
+            Discard_Node (IP_Body);
+            Set_Init_Proc (Typ, IP);
+         end;
       end if;
 
       --  If the CPP type has constructors then it must import also the default

diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index ded081fc3e1ed50d31a87c6873956b6975b748f7..0a90eb2e80ad148a1cef1d647f6847abf7baca1e 100644 (file)
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -164,6 +164,11 @@ package body Sem_Ch10 is
    --  an enclosing scope. Iterate over context to find child units of U_Name
    --  or of some ancestor of it.
 
+   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.
+
    function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean;
    --  Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec
    --  returns True if Lib_Unit is a library spec which is a child spec, i.e.
@@ -3521,11 +3526,6 @@ 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 --
       ---------------------
@@ -3794,22 +3794,6 @@ package body Sem_Ch10 is
          end if;
       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
@@ -4061,8 +4045,17 @@ package body Sem_Ch10 is
             if Nkind (Item) = N_With_Clause
               and then Private_Present (Item)
             then
+               --  If the unit is an ancestor of the current one, it is the
+               --  case of a private limited with clause on a child unit, and
+               --  the compilation of one of its descendants, In that case the
+               --  limited view is errelevant.
+
                if Limited_Present (Item) then
-                  if not Limited_View_Installed (Item) then
+                  if not Limited_View_Installed (Item)
+                    and then
+                      not Is_Ancestor_Unit (Library_Unit (Item),
+                                            Cunit (Current_Sem_Unit))
+                  then
                      Install_Limited_Withed_Unit (Item);
                   end if;
                else
@@ -5269,6 +5262,22 @@ package body Sem_Ch10 is
             (C_Unit, Cunit_Entity (Get_Source_Unit (Non_Limited_View (T))));
    end Is_Legal_Shadow_Entity_In_Body;
 
+   ----------------------
+   -- 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;
+
    -----------------------
    -- Load_Needed_Body --
    -----------------------