[multiple changes]

2009-12-01  Ed Schonberg  <schonberg@adacore.com>

	* einfo.ads: Clarify use of Is_Private_Primitive.
	* sem_ch6.adb (Analyze_Subprogram_Declaration): An operation is a
	private primitive operation only if it is declared in the scope of the
	private controlling type.
	* exp_ch9.adb (Build_Wrapper_Spec): Build wrappers for private
	protected operations as well.

2009-12-01  Arnaud Charlet  <charlet@adacore.com>

	* gnat1drv.adb (Adjust_Global_Switches): Disable front-end
	optimizations in CodePeer mode, to keep the tree as close to the source
	code as possible, and also to avoid inconsistencies between trees when
	using different optimization switches.

2009-12-01  Thomas Quinot  <quinot@adacore.com>

	* scos.ads: Updated specification of source coverage obligation
	information.

2009-12-01  Thomas Quinot  <quinot@adacore.com>

	* g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb,
	a-ststio.adb, s-commun.adb, s-commun.ads, g-socket.adb,
	g-socket.ads (System.Communications.Last_Index): For the case where no
	element has been transferred and Item'First =
	Stream_Element_Offset'First, raise CONSTRAINT_ERROR.

2009-12-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Install_Siblings): A private with_clause on some child
	unit U in an ancestor of the current unit must be ignored if the
	current unit has a regular with_clause on U.

From-SVN: r154868

gcc/ada/ChangeLog

+2009-12-01  Ed Schonberg  <schonberg@adacore.com>
+
+	* einfo.ads: Clarify use of Is_Private_Primitive.
+	* sem_ch6.adb (Analyze_Subprogram_Declaration): An operation is a
+	private primitive operation only if it is declared in the scope of the
+	private controlling type.
+	* exp_ch9.adb (Build_Wrapper_Spec): Build wrappers for private
+	protected operations as well.
+
+2009-12-01  Arnaud Charlet  <charlet@adacore.com>
+
+	* gnat1drv.adb (Adjust_Global_Switches): Disable front-end
+	optimizations in CodePeer mode, to keep the tree as close to the source
+	code as possible, and also to avoid inconsistencies between trees when
+	using different optimization switches.
+
+2009-12-01  Thomas Quinot  <quinot@adacore.com>
+
+	* scos.ads: Updated specification of source coverage obligation
+	information.
+
+2009-12-01  Thomas Quinot  <quinot@adacore.com>
+
+	* g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb,
+	a-ststio.adb, s-commun.adb, s-commun.ads, g-socket.adb,
+	g-socket.ads (System.Communications.Last_Index): For the case where no
+	element has been transferred and Item'First =
+	Stream_Element_Offset'First, raise CONSTRAINT_ERROR.
+
+2009-12-01  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch10.adb (Install_Siblings): A private with_clause on some child
+	unit U in an ancestor of the current unit must be ignored if the
+	current unit has a regular with_clause on U.
+
 2009-11-30  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
 	* s-oscons-tmplt.c [__mips && __sgi]: Only define _XOPEN5, IOV_MAX

gcc/ada/a-ststio.adb

@@ -29,9 +29,10 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Interfaces.C_Streams; use Interfaces.C_Streams;
+with Interfaces.C_Streams;  use Interfaces.C_Streams;
 
 with System;               use System;
+with System.Communication; use System.Communication;
 with System.File_IO;
 with System.Soft_Links;
 with System.CRTL;
@@ -293,8 +294,8 @@ package body Ada.Streams.Stream_IO is
       end if;
 
       File.Index := File.Index + Count (Nread);
-      Last := Item'First + Stream_Element_Offset (Nread) - 1;
       File.Last_Op := Op_Read;
+      Last := Last_Index (Item'First, Nread);
    end Read;
 
    --  This version of Read is the primitive operation on the underlying

gcc/ada/einfo.ads

@@ -2098,7 +2098,11 @@ package Einfo is
 --       Present in all entities. Set true for all entities declared in the
 --       private part or body of a package. Also marks generic formals of a
 --       formal package declared without a box. For library level entities,
---       this flag is set if the entity is not publicly visible.
+--       this flag is set if the entity is not publicly visible. This flag
+--       is reset when compiling the body of the package where the entity
+--       is declared, when compiling the private part or body of a public
+--       child unit, and when compiling a private child unit (see Install_
+--       Private_Declaration in sem_ch7).
 
 --    Is_Hidden_Open_Scope (Flag171)
 --       Present in all entities. Set true for a scope that contains the
@@ -2451,8 +2455,12 @@ package Einfo is
 --       child unit, or if it is the descendent of a private child unit.
 
 --    Is_Private_Primitive (Flag245)
---       Present in subprograms. Set if the first parameter of the subprogram
---       is of concurrent tagged type with a private view.
+--       Present in subprograms. Set if the operation is a primitive of a
+--       tagged type (procedure or function dispatching on result) whose
+--       full view has not been seen. Used in particular for primitive
+--       subprograms of a synchronized type declared between the two views
+--       of the type, so that the wrapper built for such a subprogram can
+--       be given the proper signature.
 
 --    Is_Private_Type (synthesized)
 --       Applies to all entities, true for private types and subtypes,

gcc/ada/exp_ch9.adb

@@ -2180,6 +2180,58 @@ package body Exp_Ch9 is
    is
       Def     : Node_Id;
       Rec_Typ : Entity_Id;
+      procedure Scan_Declarations (L : List_Id);
+      --  Common processing for visible and private declarations
+      --  of a protected type.
+
+      procedure Scan_Declarations (L : List_Id) is
+         Decl      : Node_Id;
+         Wrap_Decl : Node_Id;
+         Wrap_Spec : Node_Id;
+
+      begin
+         if No (L) then
+            return;
+         end if;
+
+         Decl := First (L);
+         while Present (Decl) loop
+            Wrap_Spec := Empty;
+
+            if Nkind (Decl) = N_Entry_Declaration
+              and then Ekind (Defining_Identifier (Decl)) = E_Entry
+            then
+               Wrap_Spec :=
+                 Build_Wrapper_Spec
+                   (Subp_Id => Defining_Identifier (Decl),
+                    Obj_Typ => Rec_Typ,
+                    Formals => Parameter_Specifications (Decl));
+
+            elsif Nkind (Decl) = N_Subprogram_Declaration then
+               Wrap_Spec :=
+                 Build_Wrapper_Spec
+                   (Subp_Id => Defining_Unit_Name (Specification (Decl)),
+                    Obj_Typ => Rec_Typ,
+                    Formals =>
+                      Parameter_Specifications (Specification (Decl)));
+            end if;
+
+            if Present (Wrap_Spec) then
+               Wrap_Decl :=
+                 Make_Subprogram_Declaration (Loc,
+                   Specification => Wrap_Spec);
+
+               Insert_After (N, Wrap_Decl);
+               N := Wrap_Decl;
+
+               Analyze (Wrap_Decl);
+            end if;
+
+            Next (Decl);
+         end loop;
+      end Scan_Declarations;
+
+      --  start of processing for Build_Wrapper_Specs
 
    begin
       if Is_Protected_Type (Typ) then
@@ -2191,54 +2243,14 @@ package body Exp_Ch9 is
       Rec_Typ := Corresponding_Record_Type (Typ);
 
       --  Generate wrapper specs for a concurrent type which implements an
-      --  interface and has visible entries and/or protected procedures.
+      --  interface. Operations in both the visible and private parts may
+      --  implement progenitor operations.
 
       if Present (Interfaces (Rec_Typ))
         and then Present (Def)
-        and then Present (Visible_Declarations (Def))
       then
-         declare
-            Decl      : Node_Id;
-            Wrap_Decl : Node_Id;
-            Wrap_Spec : Node_Id;
-
-         begin
-            Decl := First (Visible_Declarations (Def));
-            while Present (Decl) loop
-               Wrap_Spec := Empty;
-
-               if Nkind (Decl) = N_Entry_Declaration
-                 and then Ekind (Defining_Identifier (Decl)) = E_Entry
-               then
-                  Wrap_Spec :=
-                    Build_Wrapper_Spec
-                      (Subp_Id => Defining_Identifier (Decl),
-                       Obj_Typ => Rec_Typ,
-                       Formals => Parameter_Specifications (Decl));
-
-               elsif Nkind (Decl) = N_Subprogram_Declaration then
-                  Wrap_Spec :=
-                    Build_Wrapper_Spec
-                      (Subp_Id => Defining_Unit_Name (Specification (Decl)),
-                       Obj_Typ => Rec_Typ,
-                       Formals =>
-                         Parameter_Specifications (Specification (Decl)));
-               end if;
-
-               if Present (Wrap_Spec) then
-                  Wrap_Decl :=
-                    Make_Subprogram_Declaration (Loc,
-                      Specification => Wrap_Spec);
-
-                  Insert_After (N, Wrap_Decl);
-                  N := Wrap_Decl;
-
-                  Analyze (Wrap_Decl);
-               end if;
-
-               Next (Decl);
-            end loop;
-         end;
+         Scan_Declarations (Visible_Declarations (Def));
+         Scan_Declarations (Private_Declarations (Def));
       end if;
    end Build_Wrapper_Specs;
 

gcc/ada/g-sercom-linux.adb

@@ -172,7 +172,7 @@ package body GNAT.Serial_Communications is
          Raise_Error ("read failed");
       end if;
 
-      Last := Last_Index (Buffer'First, C.int (Res));
+      Last := Last_Index (Buffer'First, size_t (Res));
    end Read;
 
    ---------

gcc/ada/g-sercom-mingw.adb

@@ -38,6 +38,7 @@ with Ada.Streams;                use Ada.Streams;
 
 with System;               use System;
 with System.Communication; use System.Communication;
+with System.CRTL;          use System.CRTL;
 with System.Win32;         use System.Win32;
 with System.Win32.Ext;     use System.Win32.Ext;
 
@@ -162,7 +163,7 @@ package body GNAT.Serial_Communications is
          Raise_Error ("read error");
       end if;
 
-      Last := Last_Index (Buffer'First, C.int (Read_Last));
+      Last := Last_Index (Buffer'First, size_t (Read_Last));
    end Read;
 
    ---------

gcc/ada/g-sercom.ads

@@ -92,8 +92,8 @@ package GNAT.Serial_Communications is
       Last   : out Ada.Streams.Stream_Element_Offset);
    --  Read a set of bytes, put result into Buffer and set Last accordingly.
    --  Last is set to Buffer'First - 1 if no byte has been read, unless
-   --  Buffer'First = Stream_Element_Offset'First, in which case Last is
-   --  set to Stream_Element_Offset'Last instead.
+   --  Buffer'First = Stream_Element_Offset'First, in which case
+   --  Constraint_Error raised instead.
 
    overriding procedure Write
      (Port   : in out Serial_Port;

gcc/ada/g-socket.adb

@@ -48,6 +48,7 @@ pragma Warnings (Off, GNAT.Sockets.Linker_Options);
 
 with System;               use System;
 with System.Communication; use System.Communication;
+with System.CRTL;          use System.CRTL;
 
 package body GNAT.Sockets is
 
@@ -1636,7 +1637,7 @@ package body GNAT.Sockets is
          Raise_Socket_Error (Socket_Errno);
       end if;
 
-      Last := Last_Index (First => Item'First, Count => Res);
+      Last := Last_Index (First => Item'First, Count => size_t (Res));
    end Receive_Socket;
 
    --------------------
@@ -1668,7 +1669,7 @@ package body GNAT.Sockets is
          Raise_Socket_Error (Socket_Errno);
       end if;
 
-      Last := Last_Index (First => Item'First, Count => Res);
+      Last := Last_Index (First => Item'First, Count => size_t (Res));
 
       To_Inet_Addr (Sin.Sin_Addr, From.Addr);
       From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
@@ -1917,7 +1918,7 @@ package body GNAT.Sockets is
          Raise_Socket_Error (Socket_Errno);
       end if;
 
-      Last := Last_Index (First => Item'First, Count => Res);
+      Last := Last_Index (First => Item'First, Count => size_t (Res));
    end Send_Socket;
 
    -----------------

gcc/ada/g-socket.ads

@@ -895,10 +895,11 @@ package GNAT.Sockets is
       Flags  : Request_Flag_Type := No_Request_Flag);
    --  Receive message from Socket. Last is the index value such that Item
    --  (Last) is the last character assigned. Note that Last is set to
-   --  Item'First - 1 (or to Stream_Element_Array'Last if Item'First is
-   --  Stream_Element_Offset'First) when the socket has been closed by peer.
-   --  This is not an error and no exception is raised. Flags allows to
-   --  control the reception. Raise Socket_Error on error.
+   --  Item'First - 1 when the socket has been closed by peer. This is not
+   --  an error, and no exception is raised in this case unless Item'First
+   --  is Stream_Element_Offset'First, in which case Constraint_Error is
+   --  raised. Flags allows to control the reception. Raise Socket_Error on
+   --  error.
 
    procedure Receive_Socket
      (Socket : Socket_Type;
@@ -937,12 +938,13 @@ package GNAT.Sockets is
    --  Transmit a message over a socket. For a datagram socket, the address
    --  is given by To.all. For a stream socket, To must be null. Last
    --  is the index value such that Item (Last) is the last character
-   --  sent. Note that Last is set to Item'First - 1 (if Item'First is
-   --  Stream_Element_Offset'First, to Stream_Element_Array'Last) when the
-   --  socket has been closed by peer. This is not an error and no exception
-   --  is raised. Flags allows control of the transmission. Raises exception
-   --  Socket_Error on error. Note: this subprogram is inlined because it is
-   --  also used to implement the two variants below.
+   --  sent. Note that Last is set to Item'First - 1 if the socket has been
+   --  closed by the peer (unless Item'First is Stream_Element_Offset'First,
+   --  in which case Constraint_Error is raised instead). This is not an error,
+   --  and Socket_Error is not raised in that case. Flags allows control of the
+   --  transmission. Raises exception Socket_Error on error. Note: this
+   --  subprogram is inlined because it is also used to implement the two
+   --  variants below.
 
    procedure Send_Socket
      (Socket : Socket_Type;

gcc/ada/gnat1drv.adb

@@ -162,6 +162,12 @@ procedure Gnat1drv is
 
          ASIS_Mode := False;
 
+         --  Disable front-end optimizations, to keep the tree as close to the
+         --  source code as possible, and also to avoid inconsistencies between
+         --  trees when using different optimization switches.
+
+         Optimization_Level := 0;
+
          --  Disable specific expansions for Restrictions pragmas to avoid
          --  tree inconsistencies between compilations with different pragmas
          --  that will cause different SCIL files to be generated for the

gcc/ada/s-commun.adb

@@ -39,12 +39,14 @@ package body System.Communication is
 
    function Last_Index
      (First : Ada.Streams.Stream_Element_Offset;
-      Count : C.int) return Ada.Streams.Stream_Element_Offset
+      Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset
    is
       use type Ada.Streams.Stream_Element_Offset;
+      use type System.CRTL.size_t;
    begin
       if First = SEO'First and then Count = 0 then
-         return SEO'Last;
+         raise Constraint_Error with
+           "last index out of range (no element transferred)";
       else
          return First + SEO (Count - 1);
       end if;

gcc/ada/s-commun.ads

@@ -32,20 +32,17 @@
 --  Common support unit for GNAT.Sockets and GNAT.Serial_Communication
 
 with Ada.Streams;
-with Interfaces.C;
+with System.CRTL;
 
 package System.Communication is
 
-   package C renames Interfaces.C;
-
-   use type C.int;
-
    function Last_Index
      (First : Ada.Streams.Stream_Element_Offset;
-      Count : C.int) return Ada.Streams.Stream_Element_Offset;
+      Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset;
    --  Compute the Last OUT parameter for the various Read / Receive
-   --  subprograms: returns First + Count - 1, except for the case
-   --  where First = Stream_Element_Offset'First and Res = 0, in which
-   --  case Stream_Element_Offset'Last is returned instead.
+   --  subprograms: returns First + Count - 1.
+   --  When First = Stream_Element_Offset'First and Res = 0, Constraint_Error
+   --  is raised. This is consistent with the semantics of stream operations
+   --  as clarified in AI95-227.
 
 end System.Communication;

gcc/ada/scos.ads

@@ -48,6 +48,10 @@ package SCOs is
    --  Put_SCO reads the internal tables and generates text lines in the ALI
    --  format.
 
+   --  ??? The specification below for the SCO ALI format and the internal
+   --  data structures have been modified, but the implementation has not been
+   --  updated yet to reflect these specification changes.
+
    --------------------
    -- SCO ALI Format --
    --------------------
@@ -102,31 +106,52 @@ package SCOs is
    --      renaming_declaration
    --      generic_instantiation
 
+   --    and the following regions of the syntax tree:
+
+   --      the part of a case_statement from CASE up to the expression
+   --      the part of a FOR iteration scheme from FOR up to the
+   --        loop_parameter_specification
+   --      the part of an extended_return_statement from RETURN up to the
+   --        expression (if present) or to the return_subtype_indication (if
+   --        no expression)
+
    --  Statement lines
 
-   --    These lines correspond to a sequence of one or more statements which
-   --    are always executed in sequence, The first statement may be an entry
-   --    point (e.g. statement after a label), and the last statement may be
-   --    an exit point (e.g. an exit statement), but no other entry or exit
-   --    points may occur within the sequence of statements. The idea is that
-   --    the sequence can be treated as a single unit from a coverage point of
-   --    view, if any of the code for the statement sequence is executed, this
-   --    corresponds to coverage of the entire statement sequence. The form of
-   --    a statement line in the ALI file is:
+   --    These lines correspond to one or more successive statements (in the
+   --    sense of the above list) which are always executed in sequence (in the
+   --    absence of exceptions or other external interruptions).
 
-   --      CS sloc-range
+   --    Entry points to such sequences are:
 
-   --  Exit points
+   --      the first statement of any sequence_of_statements
+   --      the first statement after a compound statement
+   --      the first statement after an EXIT, RAISE or GOTO statement
+   --      any statement with a label
 
-   --    An exit point is a statement that causes transfer of control. Examples
-   --    are exit statements, raise statements and return statements. The form
-   --    of an exit point in the ALI file is:
+   --    Each entry point must appear as the first entry on a CS line.
+   --    The idea is that if any simple statement on a CS line is known to have
+   --    been executed, then all statements that appear before it on the same
+   --    CS line are certain to also have been executed.
 
-   --      CT sloc-range
+   --    The form of a statement line in the ALI file is:
 
-   --  Decisions
+   --      CS *sloc-range [*sloc-range...]
+
+   --    where each sloc-range corresponds to a single statement, and * is
+   --    one of:
+
+   --      t  type declaration
+   --      s  subtype declaration
+   --      o  object declaration
+   --      r  renaming declaration
+   --      i  generic instantiation
+   --      C  CASE statement
+   --      F  FOR loop statement
+   --      R  extended RETURN statement
 
-   --    Decisions represent the most significant section of the SCO lines
+   --    and is omitted for all other cases.
+
+   --  Decisions
 
    --    Note: in the following description, logical operator includes the
    --    short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN,
@@ -136,7 +161,7 @@ package SCOs is
    --    expresssion that occurs in the context of a control structure in the
    --    source program, including WHILE, IF, EXIT WHEN. Note that a boolean
    --    expression in any other context, for example, on the right side of an
-   --    assignment, is not considered to be a decision.
+   --    assignment, is not considered to be a simple decision.
 
    --    A complex decision is an occurrence of a logical operator which is not
    --    itself an operand of some other logical operator. If any operand of
@@ -160,7 +185,7 @@ package SCOs is
 
    --    For each decision, a decision line is generated with the form:
 
-   --      C* expression
+   --      C*sloc expression
 
    --    Here * is one of the following characters:
 
@@ -169,15 +194,23 @@ package SCOs is
    --      W  decision in WHILE iteration scheme
    --      X  decision appearing in some other expression context
 
+   --    For I, E, W, sloc is the source location of the IF, EXIT or WHILE
+   --    token.
+
+   --    For X, sloc is omitted.
+
    --    The expression is a prefix polish form indicating the structure of
    --    the decision, including logical operators and short circuit forms.
    --    The following is a grammar showing the structure of expression:
 
    --      expression ::= term             (if expr is not logical operator)
-   --      expression ::= & term term      (if expr is AND or AND THEN)
-   --      expression ::= | term term      (if expr is OR or OR ELSE)
-   --      expression ::= ^ term term      (if expr is XOR)
-   --      expression ::= !term            (if expr is NOT)
+   --      expression ::= &sloc term term  (if expr is AND or AND THEN)
+   --      expression ::= |sloc term term  (if expr is OR or OR ELSE)
+   --      expression ::= ^sloc term term  (if expr is XOR)
+   --      expression ::= !sloc term       (if expr is NOT)
+
+   --      In the last four cases, sloc is the source location of the AND, OR,
+   --      XOR or NOT token, respectively.
 
    --      term ::= element
    --      term ::= expression
@@ -194,15 +227,15 @@ package SCOs is
    --      the compiler as always being true or false.
 
    --    & indicates either AND or AND THEN connecting two conditions. In the
-   --    context of couverture we only permit AND THEN in the source in any
+   --    context of Couverture we only permit AND THEN in the source in any
    --    case, so & can always be understood to be AND THEN.
 
    --    | indicates either OR or OR ELSE connection two conditions. In the
-   --    context of couverture we only permit OR ELSE in the source in any
+   --    context of Couverture we only permit OR ELSE in the source in any
    --    case, so | can always be understood to be OR ELSE.
 
    --    ^ indicates XOR connecting two conditions. In the context of
-   --    couverture, we do not permit XOR, so this will never appear.
+   --    Couverture, we do not permit XOR, so this will never appear.
 
    --    ! indicates NOT applied to the expression.
 
@@ -235,41 +268,34 @@ package SCOs is
    --  The SCO_Table_Entry values appear as follows:
 
    --    Statements
-   --      C1   = 'S'
-   --      C2   = ' '
+   --      C1   = 'S' for entry point, 's' otherwise
+   --      C2   = 't', 's', 'o', 'r', 'i', 'C', 'F', 'R', ' '
+   --             (type/subtype/object/renaming/instantiation/CASE/FOR/RETURN)
    --      From = starting source location
    --      To   = ending source location
-   --      Last = unused
-
-   --    Exit
-   --      C1   = 'T'
-   --      C2   = ' '
-   --      From = starting source location
-   --      To   = ending source location
-   --      Last = unused
+   --      Last = False for all but the last entry, True for last entry
 
-   --    Simple Decision
-   --      C1   = 'I', 'E', 'W', 'X' (if/exit/while/expression)
-   --      C2   = 'c', 't', or 'f'
-   --      From = starting source location
-   --      To   = ending source location
-   --      Last = True
+   --    Note: successive statements (possibly interspersed with entries of
+   --    other kinds, that are ignored for this purpose), starting with one
+   --    labeled with C1 = 'S', up to and including the first one labeled with
+   --    Last=True, indicate the sequence to be output for a sequence of
+   --    statements on a single CS line.
 
-   --    Complex Decision
+   --    Decision
    --      C1   = 'I', 'E', 'W', 'X' (if/exit/while/expression)
    --      C2   = ' '
-   --      From = No_Source_Location
+   --      From = location of IF/EXIT/WHILE token, No_Source_Location for X
    --      To   = No_Source_Location
-   --      Last = False
+   --      Last = unused
 
    --    Operator
    --      C1   = '!', '^', '&', '|'
    --      C2   = ' '
-   --      From = No_Source_Location
+   --      From = location of NOT/XOR/AND/OR token
    --      To   = No_Source_Location
    --      Last = False
 
-   --    Element
+   --    Element (condition)
    --      C1   = ' '
    --      C2   = 'c', 't', or 'f' (condition/true/false)
    --      From = starting source location

gcc/ada/sem_ch10.adb

@@ -4000,13 +4000,44 @@ 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.
+
+                  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 Entity (Name (Clause)) = Id
+                          and then not Private_Present (Clause)
+                        then
+                           return True;
+                        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;
 

gcc/ada/sem_ch6.adb

@@ -2654,10 +2654,13 @@ package body Sem_Ch6 is
       --  If the type of the first formal of the current subprogram is a
       --  nongeneric tagged private type, mark the subprogram as being a
       --  private primitive. Ditto if this is a function with controlling
-      --  result, and the return type is currently private.
+      --  result, and the return type is currently private. In both cases,
+      --  the type of the controlling argument or result must be in the
+      --  current scope for the operation to be primitive.
 
       if Has_Controlling_Result (Designator)
         and then Is_Private_Type (Etype (Designator))
+        and then Scope (Etype (Designator)) = Current_Scope
         and then not Is_Generic_Actual_Type (Etype (Designator))
       then
          Set_Is_Private_Primitive (Designator);
@@ -2669,6 +2672,7 @@ package body Sem_Ch6 is
          begin
             Set_Is_Private_Primitive (Designator,
               Is_Tagged_Type (Formal_Typ)
+                and then Scope (Formal_Typ) = Current_Scope
                 and then Is_Private_Type (Formal_Typ)
                 and then not Is_Generic_Actual_Type (Formal_Typ));
          end;