exp_aggr.adb (Build_Record_Aggr_Code): Extend the test for an ancestor part…

exp_aggr.adb (Build_Record_Aggr_Code): Extend the test for an ancestor part given by an aggregate to test for an...

2007-08-16  Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_aggr.adb (Build_Record_Aggr_Code): Extend the test for an
	ancestor part given by an aggregate to test for an unchecked conversion,
	since this can occur in some cases when the ancestor part is a function
	call, and we don't want to fall into the recursive call to this
	procedure in that case.

	* exp_ch3.adb (Stream_Operation_OK): Revise tests for availability of
	stream attributes on limited types to account for user-specified
	attributes as well as whether Input (resp. Output) becomes available
	due to Read (resp. Write) being available for the type. Change Boolean
	variable to the more accurate name
	Has_Predefined_Or_Specified_Stream_Attribute. Change convoluted
	double-"not" predicate at beginning of return statement to more
	understandable form.

	* exp_ch5.adb (Expand_N_Extended_Return_Statement): If the extended
	return has an associated N_Handled_Sequence_Of_Statements, then wrap it
	in a block statement and use that as the first statement of the
	expanded return rather than incorrectly using the handled sequence as
	the first statement.

	* exp_ch6.adb (Expand_N_Subprogram_Declaration): If this is a protected
	operation, generate an explicit freeze node for it rather than
	generating extra formals, to ensure that gigi has the proper order of
	elaboration for anonymous subtypes in the signature of the subprograms.
	(Build_In_Place_Formal): Move assertion to beginning of loop.
	(Is_Build_In_Place_Function_Call): Allow for an unchecked conversion
	applied to a function call (occurs for some cases of 'Input).
	(Make_Build_In_Place_Call_In_*): Allow for an unchecked conversion
	applied to a function call (occurs for some cases of 'Input).

	* exp_strm.adb (Build_Record_Or_Elementary_Input_Function): For Ada
	2005, generate an extended return statement enclosing the result object
	and 'Read call.

	* freeze.adb (Freeze_Record_Type): Extend the current management of
	components that are access type with an allocator as default value: add
	missing support to the use of qualified expressions of the
	allocator (which also cause freezing of the designated type!)
	(Freeze_Entity): Call Freeze_Subprogram in the case of a predefined
	dispatching operation, since extra formals may be needed by calls to
	build-in-place functions (such as stream 'Input).

	* sem_ch6.adb (Create_Extra_Formals): Skip creation of the extra
	formals for 'Constrained and accessibility level in the case of a
	predefined dispatching operation.

	* exp_util.adb (Insert_Actions): A protected body is a valid insertion
	point, no need to find the parent node.

From-SVN: r127538

gcc/ada/exp_aggr.adb

@@ -2426,11 +2426,15 @@ package body Exp_Aggr is
             --  Ada 2005 (AI-287): If the ancestor part is an aggregate of
             --  limited type, a recursive call expands the ancestor. Note that
             --  in the limited case, the ancestor part must be either a
-            --  function call (possibly qualified) or aggregate (definitely
-            --  qualified).
+            --  function call (possibly qualified, or wrapped in an unchecked
+            --  conversion) or aggregate (definitely qualified).
 
             elsif Is_Limited_Type (Etype (A))
               and then Nkind (Unqualify (A)) /= N_Function_Call --  aggregate?
+              and then
+                (Nkind (Unqualify (A)) /= N_Unchecked_Type_Conversion
+                   or else
+                 Nkind (Expression (Unqualify (A))) /= N_Function_Call)
             then
                Ancestor_Is_Expression := True;
 

gcc/ada/exp_ch3.adb

@@ -8026,33 +8026,67 @@ package body Exp_Ch3 is
      (Typ       : Entity_Id;
       Operation : TSS_Name_Type) return Boolean
    is
-      Has_Inheritable_Stream_Attribute : Boolean := False;
+      Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
 
    begin
+      --  Special case of a limited type extension: a default implementation
+      --  of the stream attributes Read or Write exists if that attribute
+      --  has been specified or is available for an ancestor type; a default
+      --  implementation of the attribute Output (resp. Input) exists if the
+      --  attribute has been specified or Write (resp. Read) is available for
+      --  an ancestor type. The last condition only applies under Ada 2005.
+
       if Is_Limited_Type (Typ)
         and then Is_Tagged_Type (Typ)
-        and then Is_Derived_Type (Typ)
       then
-         --  Special case of a limited type extension: a default implementation
-         --  of the stream attributes Read and Write exists if the attribute
-         --  has been specified for an ancestor type.
+         if Operation = TSS_Stream_Read then
+            Has_Predefined_Or_Specified_Stream_Attribute :=
+              Has_Specified_Stream_Read (Typ);
+
+         elsif Operation = TSS_Stream_Write then
+            Has_Predefined_Or_Specified_Stream_Attribute :=
+              Has_Specified_Stream_Write (Typ);
+
+         elsif Operation = TSS_Stream_Input then
+            Has_Predefined_Or_Specified_Stream_Attribute :=
+              Has_Specified_Stream_Input (Typ)
+                or else
+                  (Ada_Version >= Ada_05
+                    and then Stream_Operation_OK (Typ, TSS_Stream_Read));
+
+         elsif Operation = TSS_Stream_Output then
+            Has_Predefined_Or_Specified_Stream_Attribute :=
+              Has_Specified_Stream_Output (Typ)
+                or else
+                  (Ada_Version >= Ada_05
+                    and then Stream_Operation_OK (Typ, TSS_Stream_Write));
+         end if;
+
+         --  Case of inherited TSS_Stream_Read or TSS_Stream_Write
 
-         Has_Inheritable_Stream_Attribute :=
-           Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+         if not Has_Predefined_Or_Specified_Stream_Attribute
+           and then Is_Derived_Type (Typ)
+           and then (Operation = TSS_Stream_Read
+                      or else Operation = TSS_Stream_Write)
+         then
+            Has_Predefined_Or_Specified_Stream_Attribute :=
+              Present
+                (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+         end if;
       end if;
 
-      return
-        not (Is_Limited_Type (Typ)
-               and then not Has_Inheritable_Stream_Attribute)
-          and then not Has_Unknown_Discriminants (Typ)
-          and then not (Is_Interface (Typ)
-                         and then (Is_Task_Interface (Typ)
-                                   or else Is_Protected_Interface (Typ)
-                                   or else Is_Synchronized_Interface (Typ)))
-          and then not Restriction_Active (No_Streams)
-          and then not Restriction_Active (No_Dispatch)
-          and then not No_Run_Time_Mode
-          and then RTE_Available (RE_Tag)
-          and then RTE_Available (RE_Root_Stream_Type);
+      return (not Is_Limited_Type (Typ)
+               or else Has_Predefined_Or_Specified_Stream_Attribute)
+        and then not Has_Unknown_Discriminants (Typ)
+        and then not (Is_Interface (Typ)
+                       and then (Is_Task_Interface (Typ)
+                                  or else Is_Protected_Interface (Typ)
+                                  or else Is_Synchronized_Interface (Typ)))
+        and then not Restriction_Active (No_Streams)
+        and then not Restriction_Active (No_Dispatch)
+        and then not No_Run_Time_Mode
+        and then RTE_Available (RE_Tag)
+        and then RTE_Available (RE_Root_Stream_Type);
    end Stream_Operation_OK;
+
 end Exp_Ch3;

gcc/ada/exp_ch5.adb

@@ -1412,7 +1412,6 @@ package body Exp_Ch5 is
             Call           : Node_Id;
             Conctyp        : Entity_Id;
             Ent            : Entity_Id;
-            Object_Parm    : Node_Id;
             Subprg         : Entity_Id;
             RT_Subprg_Name : Node_Id;
 
@@ -1428,7 +1427,7 @@ package body Exp_Ch5 is
             end loop;
 
             --  The attribute Priority applied to protected objects has been
-            --  previously expanded into calls to the Get_Ceiling run-time
+            --  previously expanded into a call to the Get_Ceiling run-time
             --  subprogram.
 
             if Nkind (Ent) = N_Function_Call
@@ -1452,18 +1451,6 @@ package body Exp_Ch5 is
                   Subprg := Scope (Subprg);
                end loop;
 
-               Object_Parm :=
-                 Make_Attribute_Reference (Loc,
-                   Prefix =>
-                     Make_Selected_Component (Loc,
-                       Prefix => New_Reference_To
-                                   (First_Entity
-                                     (Protected_Body_Subprogram (Subprg)),
-                                    Loc),
-                     Selector_Name =>
-                       Make_Identifier (Loc, Name_uObject)),
-                   Attribute_Name => Name_Unchecked_Access);
-
                --  Select the appropriate run-time call
 
                if Number_Entries (Conctyp) = 0 then
@@ -1477,9 +1464,9 @@ package body Exp_Ch5 is
                Call :=
                  Make_Procedure_Call_Statement (Loc,
                    Name => RT_Subprg_Name,
-                   Parameter_Associations =>
-                     New_List (Object_Parm,
-                               Relocate_Node (Expression (N))));
+                   Parameter_Associations => New_List (
+                     New_Copy_Tree (First (Parameter_Associations (Ent))),
+                     Relocate_Node (Expression (N))));
 
                Rewrite (N, Call);
                Analyze (N);
@@ -1616,16 +1603,16 @@ package body Exp_Ch5 is
             --  We do not need to reanalyze that assignment, and we do not need
             --  to worry about references to the temporary, but we do need to
             --  make sure that the temporary is not marked as a true constant
-            --  since we now have a generate assignment to it!
+            --  since we now have a generated assignment to it!
 
             Set_Is_True_Constant (Tnn, False);
          end;
       end if;
 
-      --  When we have the appropriate type of aggregate in the
-      --  expression (it has been determined during analysis of the
-      --  aggregate by setting the delay flag), let's perform in place
-      --  assignment and thus avoid creating a temporay.
+      --  When we have the appropriate type of aggregate in the expression (it
+      --  has been determined during analysis of the aggregate by setting the
+      --  delay flag), let's perform in place assignment and thus avoid
+      --  creating a temporary.
 
       if Is_Delayed_Aggregate (Rhs) then
          Convert_Aggr_In_Assignment (N);
@@ -1762,8 +1749,10 @@ package body Exp_Ch5 is
          Make_Build_In_Place_Call_In_Assignment (N, Rhs);
 
       elsif Is_Tagged_Type (Typ) and then Is_Value_Type (Etype (Lhs)) then
+
          --  Nothing to do for valuetypes
          --  ??? Set_Scope_Is_Transient (False);
+
          return;
 
       elsif Is_Tagged_Type (Typ)
@@ -2059,9 +2048,8 @@ package body Exp_Ch5 is
             elsif Is_Entity_Name (Lhs)
               and then Is_Known_Valid (Entity (Lhs))
             then
-               --  Note that the Ensure_Valid call is ignored if the
-               --  Validity_Checking mode is set to none so we do not
-               --  need to worry about that case here.
+               --  Note: If Validity_Checking mode is set to none, we ignore
+               --  the Ensure_Valid call so don't worry about that case here.
 
                Ensure_Valid (Rhs);
 
@@ -2484,10 +2472,17 @@ package body Exp_Ch5 is
         or else Is_Composite_Type (Etype (Parent_Function))
         or else No (Exp)
       then
-         Statements := New_List;
+         if No (Handled_Stm_Seq) then
+            Statements := New_List;
+
+         --  If the extended return has a handled statement sequence, then wrap
+         --  it in a block and use the block as the first statement.
 
-         if Present (Handled_Stm_Seq) then
-            Append_To (Statements, Handled_Stm_Seq);
+         else
+            Statements :=
+              New_List (Make_Block_Statement (Loc,
+                          Declarations => New_List,
+                          Handled_Statement_Sequence => Handled_Stm_Seq));
          end if;
 
          --  If control gets past the above Statements, we have successfully

gcc/ada/exp_ch6.adb

@@ -537,11 +537,11 @@ package body Exp_Ch6 is
       --  function to have a flag or a Uint attribute to identify it. ???
 
       loop
+         pragma Assert (Present (Extra_Formal));
          exit when
            Chars (Extra_Formal) =
              New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind));
          Next_Formal_With_Extras (Extra_Formal);
-         pragma Assert (Present (Extra_Formal));
       end loop;
 
       return Extra_Formal;
@@ -4551,6 +4551,8 @@ package body Exp_Ch6 is
             --  The protected subprogram is declared outside of the protected
             --  body. Given that the body has frozen all entities so far, we
             --  analyze the subprogram and perform freezing actions explicitly.
+            --  including the generation of an explicit freeze node, to ensure
+            --  that gigi has the proper order of elaboration.
             --  If the body is a subunit, the insertion point is before the
             --  stub in the parent.
 
@@ -4562,10 +4564,11 @@ package body Exp_Ch6 is
 
             Insert_Before (Prot_Bod, Prot_Decl);
             Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
+            Set_Has_Delayed_Freeze (Prot_Id);
 
             Push_Scope (Scope (Scop));
             Analyze (Prot_Decl);
-            Create_Extra_Formals (Prot_Id);
+            Insert_Actions (N, Freeze_Entity (Prot_Id, Loc));
             Set_Protected_Body_Subprogram (Subp, Prot_Id);
             Pop_Scope;
          end if;
@@ -4820,7 +4823,12 @@ package body Exp_Ch6 is
       Function_Id : Entity_Id;
 
    begin
-      if Nkind (Exp_Node) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind (Exp_Node) = N_Qualified_Expression
+        or else Nkind (Exp_Node) = N_Unchecked_Type_Conversion
+      then
          Exp_Node := Expression (N);
       end if;
 
@@ -5022,7 +5030,12 @@ package body Exp_Ch6 is
       Return_Obj_Access : Entity_Id;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind (Func_Call) = N_Qualified_Expression
+        or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+      then
          Func_Call := Expression (Func_Call);
       end if;
 
@@ -5158,7 +5171,12 @@ package body Exp_Ch6 is
       Return_Obj_Decl : Entity_Id;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind (Func_Call) = N_Qualified_Expression
+        or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+      then
          Func_Call := Expression (Func_Call);
       end if;
 
@@ -5267,7 +5285,12 @@ package body Exp_Ch6 is
       New_Expr        : Node_Id;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind (Func_Call) = N_Qualified_Expression
+        or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+      then
          Func_Call := Expression (Func_Call);
       end if;
 
@@ -5372,7 +5395,12 @@ package body Exp_Ch6 is
       Pass_Caller_Acc : Boolean := False;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind (Func_Call) = N_Qualified_Expression
+        or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+      then
          Func_Call := Expression (Func_Call);
       end if;
 

gcc/ada/exp_strm.adb

@@ -29,6 +29,7 @@ with Einfo;    use Einfo;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
+with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
@@ -1145,21 +1146,47 @@ package body Exp_Strm is
          Odef := New_Occurrence_Of (Typ, Loc);
       end if;
 
-      Append_To (Decls,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
-          Object_Definition => Odef));
+      --  For Ada 2005 we create an extended return statement encapsulating
+      --  the result object and 'Read call, which is needed in general for
+      --  proper handling of build-in-place results (such as when the result
+      --  type is inherently limited).
+
+      --  Perhaps we should just generate an extended return in all cases???
+
+      if Ada_Version >= Ada_05 then
+         Stms := New_List (
+           Make_Extended_Return_Statement (Loc,
+             Return_Object_Declarations =>
+               New_List (Make_Object_Declaration (Loc,
+                           Defining_Identifier =>
+                             Make_Defining_Identifier (Loc, Name_V),
+                           Object_Definition => Odef)),
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 New_List (Make_Attribute_Reference (Loc,
+                             Prefix => New_Occurrence_Of (Typ, Loc),
+                             Attribute_Name => Name_Read,
+                             Expressions => New_List (
+                               Make_Identifier (Loc, Name_S),
+                               Make_Identifier (Loc, Name_V)))))));
 
-      Stms := New_List (
-         Make_Attribute_Reference (Loc,
-           Prefix => New_Occurrence_Of (Typ, Loc),
-           Attribute_Name => Name_Read,
-           Expressions => New_List (
-             Make_Identifier (Loc, Name_S),
-             Make_Identifier (Loc, Name_V))),
+      else
+         Append_To (Decls,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+             Object_Definition => Odef));
 
-         Make_Simple_Return_Statement (Loc,
-           Expression => Make_Identifier (Loc, Name_V)));
+         Stms := New_List (
+            Make_Attribute_Reference (Loc,
+              Prefix => New_Occurrence_Of (Typ, Loc),
+              Attribute_Name => Name_Read,
+              Expressions => New_List (
+                Make_Identifier (Loc, Name_S),
+                Make_Identifier (Loc, Name_V))),
+
+            Make_Simple_Return_Statement (Loc,
+              Expression => Make_Identifier (Loc, Name_V)));
+      end if;
 
       Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
 

gcc/ada/exp_util.adb

@@ -1065,7 +1065,7 @@ package body Exp_Util is
       --  itype, so that gigi can elaborate it on the proper objstack.
 
       if Is_Itype (Typ)
-        and then  Scope (Typ) = Current_Scope
+        and then Scope (Typ) = Current_Scope
       then
          IR := Make_Itype_Reference (Sloc (N));
          Set_Itype (IR, Typ);
@@ -2476,6 +2476,7 @@ package body Exp_Util is
                N_Private_Extension_Declaration          |
                N_Private_Type_Declaration               |
                N_Procedure_Instantiation                |
+               N_Protected_Body                         |
                N_Protected_Body_Stub                    |
                N_Protected_Type_Declaration             |
                N_Single_Task_Declaration                |
@@ -2748,7 +2749,6 @@ package body Exp_Util is
                N_Pop_Storage_Error_Label                |
                N_Pragma_Argument_Association            |
                N_Procedure_Specification                |
-               N_Protected_Body                         |
                N_Protected_Definition                   |
                N_Push_Constraint_Error_Label            |
                N_Push_Program_Error_Label               |

gcc/ada/freeze.adb

-------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
 --                                                                          --
 --                         GNAT COMPILER COMPONENTS                         --
 --                                                                          --
@@ -1461,6 +1461,10 @@ package body Freeze is
          --  Set True if we find at least one component with a component
          --  clause (used to warn about useless Bit_Order pragmas).
 
+         function Check_Allocator (N : Node_Id) return Boolean;
+         --  Returns True if N is an expression or a qualified expression with
+         --  an allocator.
+
          procedure Check_Itype (Typ : Entity_Id);
          --  If the component subtype is an access to a constrained subtype of
          --  an already frozen type, make the subtype frozen as well. It might
@@ -1471,6 +1475,21 @@ package body Freeze is
          --  freeze node at some eventual point of call. Protected operations
          --  are handled elsewhere.
 
+         ---------------------
+         -- Check_Allocator --
+         ---------------------
+
+         function Check_Allocator (N : Node_Id) return Boolean is
+         begin
+            if Nkind (N) = N_Allocator then
+               return True;
+            elsif Nkind (N) = N_Qualified_Expression then
+               return Check_Allocator (Expression (N));
+            else
+               return False;
+            end if;
+         end Check_Allocator;
+
          -----------------
          -- Check_Itype --
          -----------------
@@ -1819,16 +1838,24 @@ package body Freeze is
             elsif Is_Access_Type (Etype (Comp))
               and then Present (Parent (Comp))
               and then Present (Expression (Parent (Comp)))
-              and then Nkind (Expression (Parent (Comp))) = N_Allocator
+              and then Check_Allocator (Expression (Parent (Comp)))
             then
                declare
-                  Alloc : constant Node_Id := Expression (Parent (Comp));
+                  Alloc : Node_Id;
 
                begin
-                  --  If component is pointer to a classwide type, freeze
-                  --  the specific type in the expression being allocated.
-                  --  The expression may be a subtype indication, in which
-                  --  case freeze the subtype mark.
+                  --  Handle qualified expressions
+
+                  Alloc := Expression (Parent (Comp));
+                  while Nkind (Alloc) /= N_Allocator loop
+                     pragma Assert (Nkind (Alloc) = N_Qualified_Expression);
+                     Alloc := Expression (Alloc);
+                  end loop;
+
+                  --  If component is pointer to a classwide type, freeze the
+                  --  specific type in the expression being allocated. The
+                  --  expression may be a subtype indication, in which case
+                  --  freeze the subtype mark.
 
                   if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
                      if Is_Entity_Name (Expression (Alloc)) then
@@ -2061,11 +2088,12 @@ package body Freeze is
       --  The two-pass elaboration mechanism in gigi guarantees that E will
       --  be frozen before the inner call is elaborated. We exclude constants
       --  from this test, because deferred constants may be frozen early, and
-      --  must be diagnosed (see e.g. 1522-005). If the enclosing subprogram
-      --  comes from source, or is a generic instance, then the freeze point
-      --  is the one mandated by the language. and we freze the entity.
-      --  A subprogram that is a child unit body that acts as a spec does not
-      --  have a spec that comes from source, but can only come from source.
+      --  must be diagnosed (e.g. in the case of a deferred constant being used
+      --  in a default expression). If the enclosing subprogram comes from
+      --  source, or is a generic instance, then the freeze point is the one
+      --  mandated by the language, and we freeze the entity. A subprogram that
+      --  is a child unit body that acts as a spec does not have a spec that
+      --  comes from source, but can only come from source.
 
       elsif In_Open_Scopes (Scope (Test_E))
         and then Scope (Test_E) /= Current_Scope
@@ -2380,7 +2408,15 @@ package body Freeze is
                Freeze_And_Append (Alias (E), Loc, Result);
             end if;
 
-            if not Is_Internal (E) then
+            --  We don't freeze internal subprograms, because we don't normally
+            --  want addition of extra formals or mechanism setting to happen
+            --  for those. However we do pass through predefined dispatching
+            --  cases, since extra formals may be needed in some cases, such as
+            --  for the stream 'Input function (build-in-place formals).
+
+            if not Is_Internal (E)
+              or else Is_Predefined_Dispatching_Operation (E)
+            then
                Freeze_Subprogram (E);
             end if;
 

gcc/ada/sem_ch6.adb

@@ -2946,16 +2946,34 @@ package body Sem_Ch6 is
                     ("not type conformant with declaration#!", Enode);
 
                when Mode_Conformant =>
-                  Error_Msg_N
-                    ("not mode conformant with declaration#!", Enode);
+                  if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
+                     Error_Msg_N
+                       ("not mode conformant with operation inherited#!",
+                         Enode);
+                  else
+                     Error_Msg_N
+                       ("not mode conformant with declaration#!", Enode);
+                  end if;
 
                when Subtype_Conformant =>
-                  Error_Msg_N
-                    ("not subtype conformant with declaration#!", Enode);
+                  if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
+                     Error_Msg_N
+                       ("not subtype conformant with operation inherited#!",
+                         Enode);
+                  else
+                     Error_Msg_N
+                       ("not subtype conformant with declaration#!", Enode);
+                  end if;
 
                when Fully_Conformant =>
-                  Error_Msg_N
-                    ("not fully conformant with declaration#!", Enode);
+                  if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
+                     Error_Msg_N
+                       ("not fully conformant with operation inherited#!",
+                         Enode);
+                  else
+                     Error_Msg_N
+                       ("not fully conformant with declaration#!", Enode);
+                  end if;
             end case;
 
             Error_Msg_NE (Msg, Enode, N);
@@ -4728,6 +4746,17 @@ package body Sem_Ch6 is
          return;
       end if;
 
+      --  If the subprogram is a predefined dispatching subprogram then don't
+      --  generate any extra constrained or accessibility level formals. In
+      --  general we suppress these for internal subprograms (by not calling
+      --  Freeze_Subprogram and Create_Extra_Formals at all), but internally
+      --  generated stream attributes do get passed through because extra
+      --  build-in-place formals are needed in some cases (limited 'Input).
+
+      if Is_Predefined_Dispatching_Operation (E) then
+         goto Test_For_BIP_Extras;
+      end if;
+
       Formal := First_Formal (E);
       while Present (Formal) loop
 
@@ -4818,6 +4847,8 @@ package body Sem_Ch6 is
          Next_Formal (Formal);
       end loop;
 
+      <<Test_For_BIP_Extras>>
+
       --  Ada 2005 (AI-318-02): In the case of build-in-place functions, add
       --  appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.