2014-02-20 Robert Dewar <dewar@adacore.com>

	* sem_ch12.adb (Validate_Access_Type_Instance): Add message if
	mismatching predicates.
	* sem_ch6.adb (Check_Conformance): Give better messages on
	predicate mismatch.
	* sem_eval.adb (Predicates_Match): Move to spec.
	* sem_eval.ads (Predicates_Match): Moved here from body.

2014-02-20  Ed Schonberg  <schonberg@adacore.com>

	* a-cbmutr.adb: Use default value in Insert_Child.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@207949 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 143 insertions, 83 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 13a2d013f30..8452f3df9c5 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2014-02-20  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch12.adb (Validate_Access_Type_Instance): Add message if
+	mismatching predicates.
+	* sem_ch6.adb (Check_Conformance): Give better messages on
+	predicate mismatch.
+	* sem_eval.adb (Predicates_Match): Move to spec.
+	* sem_eval.ads (Predicates_Match): Moved here from body.
+
+2014-02-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-cbmutr.adb: Use default value in Insert_Child.
+
 2014-02-20  Vincent Celier  <celier@adacore.com>
 
 	* gnatcmd.adb, make.adb, prj-makr.adb, clean.adb: Call
diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb
index 536f00afdb3..e0bcd3acafe 100644
--- a/gcc/ada/a-cbmutr.adb
+++ b/gcc/ada/a-cbmutr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2011-2012, Free Software Foundation, Inc.      --
+--             Copyright (C) 2011-2013, Free Software Foundation, Inc.      --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1585,6 +1585,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       Nodes : Tree_Node_Array renames Container.Nodes;
       Last  : Count_Type;
 
+      Elem : Element_Type;
+      pragma Unmodified (Elem);
+      --  There is no explicit element provided, but in an instance the
+      --  element type may be a scalar with a Default_Value aspect, or a
+      --  composite type with such a scalar component, so we insert the
+      --  specified number of possibly initialized elements at the given
+      --  position. So we are declaring Elem just for this possible default
+      --  initialization, which is why we need the pragma Unmodified.
+
    begin
       if Parent = No_Element then
          raise Constraint_Error with "Parent cursor has no element";
@@ -1623,7 +1632,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
          Initialize_Root (Container);
       end if;
 
-      Allocate_Node (Container, Position.Node);
+      Allocate_Node (Container, Elem, Position.Node);
       Nodes (Position.Node).Parent := Parent.Node;
 
       Last := Position.Node;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 15c1cbe36c0..54df193ab8b 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -10662,17 +10662,27 @@ package body Sem_Ch12 is
          if not Subtypes_Match (Desig_Type, Desig_Act) then
             Error_Msg_NE
               ("designated type of actual does not match that of formal &",
-                 Actual, Gen_T);
+               Actual, Gen_T);
+
+            if not Predicates_Match (Desig_Type, Desig_Act) then
+               Error_Msg_N ("\predicates do not match", Actual);
+            end if;
+
             Abandon_Instantiation (Actual);
 
          elsif Is_Access_Type (Designated_Type (Act_T))
            and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
                       /=
-                  Is_Constrained (Designated_Type (Desig_Type))
+                    Is_Constrained (Designated_Type (Desig_Type))
          then
             Error_Msg_NE
               ("designated type of actual does not match that of formal &",
-                 Actual, Gen_T);
+               Actual, Gen_T);
+
+            if not Predicates_Match (Desig_Type, Desig_Act) then
+               Error_Msg_N ("\predicates do not match", Actual);
+            end if;
+
             Abandon_Instantiation (Actual);
          end if;
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 2bd2e3c7080..5885e3f4538 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -669,25 +669,44 @@ package body Sem_Ch6 is
          Subtype_Ind : constant Node_Id :=
                          Object_Definition (Original_Node (Obj_Decl));
 
-         R_Type_Is_Anon_Access :
-           constant Boolean :=
-             Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
-               or else
-             Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
-               or else
-             Ekind (R_Type) = E_Anonymous_Access_Type;
+         R_Type_Is_Anon_Access : constant Boolean :=
+             Ekind_In (R_Type,
+                       E_Anonymous_Access_Subprogram_Type,
+                       E_Anonymous_Access_Protected_Subprogram_Type,
+                       E_Anonymous_Access_Type);
          --  True if return type of the function is an anonymous access type
          --  Can't we make Is_Anonymous_Access_Type in einfo ???
 
-         R_Stm_Type_Is_Anon_Access :
-           constant Boolean :=
-             Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
-               or else
-             Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
-               or else
-             Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
+         R_Stm_Type_Is_Anon_Access : constant Boolean :=
+             Ekind_In (R_Stm_Type,
+                       E_Anonymous_Access_Subprogram_Type,
+                       E_Anonymous_Access_Protected_Subprogram_Type,
+                       E_Anonymous_Access_Type);
          --  True if type of the return object is an anonymous access type
 
+         procedure Error_No_Match (N : Node_Id);
+         --  Output error messages for case where types do not statically
+         --  match. N is the location for the messages.
+
+         --------------------
+         -- Error_No_Match --
+         --------------------
+
+         procedure Error_No_Match (N : Node_Id) is
+         begin
+            Error_Msg_N
+              ("subtype must statically match function result subtype", N);
+
+            if not Predicates_Match (R_Stm_Type, R_Type) then
+               Error_Msg_Node_2 := R_Type;
+               Error_Msg_NE
+                 ("\predicate of & does not match predicate of &",
+                  N, R_Stm_Type);
+            end if;
+         end Error_No_Match;
+
+      --  Start of processing for Check_Return_Subtype_Indication
+
       begin
          --  First, avoid cascaded errors
 
@@ -708,9 +727,7 @@ package body Sem_Ch6 is
                      Base_Type (Designated_Type (R_Type))
                     or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
                   then
-                     Error_Msg_N
-                      ("subtype must statically match function result subtype",
-                       Subtype_Mark (Subtype_Ind));
+                     Error_No_Match (Subtype_Mark (Subtype_Ind));
                   end if;
 
                else
@@ -720,9 +737,7 @@ package body Sem_Ch6 is
                   if not Conforming_Types
                     (R_Stm_Type, R_Type, Fully_Conformant)
                   then
-                     Error_Msg_N
-                      ("subtype must statically match function result subtype",
-                         Subtype_Ind);
+                     Error_No_Match (Subtype_Ind);
                   end if;
                end if;
 
@@ -763,9 +778,7 @@ package body Sem_Ch6 is
                  or else Null_Exclusion_Present (Parent (Scope_Id))) /=
                                               Can_Never_Be_Null (R_Stm_Type)
             then
-               Error_Msg_N
-                 ("subtype must statically match function result subtype",
-                  Subtype_Ind);
+               Error_No_Match (Subtype_Ind);
             end if;
 
             --  AI05-103: for elementary types, subtypes must statically match
@@ -774,9 +787,7 @@ package body Sem_Ch6 is
               or else Is_Access_Type (R_Type)
             then
                if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
-                  Error_Msg_N
-                    ("subtype must statically match function result subtype",
-                     Subtype_Ind);
+                  Error_No_Match (Subtype_Ind);
                end if;
             end if;
 
@@ -5931,7 +5942,16 @@ package body Sem_Ch6 is
             null;
 
          elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
-            Conformance_Error ("\return type does not match!", New_Id);
+            if Ctype >= Subtype_Conformant
+              and then not Predicates_Match (Old_Type, New_Type)
+            then
+               Conformance_Error
+                 ("\predicate of return type does not match!", New_Id);
+            else
+               Conformance_Error
+                 ("\return type does not match!", New_Id);
+            end if;
+
             return;
          end if;
 
@@ -6168,7 +6188,16 @@ package body Sem_Ch6 is
             if Errmsg and then Old_Formal_Base = Any_Type then
                Conforms := False;
             else
-               Conformance_Error ("\type of & does not match!", New_Formal);
+               if Ctype >= Subtype_Conformant
+                 and then
+                   not Predicates_Match (Old_Formal_Base, New_Formal_Base)
+               then
+                  Conformance_Error
+                    ("\predicate of & does not match!", New_Formal);
+               else
+                  Conformance_Error
+                    ("\type of & does not match!", New_Formal);
+               end if;
             end if;
 
             return;
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 7857d80f1d4..14b2fa97a3b 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -4686,6 +4686,48 @@ package body Sem_Eval is
       end if;
    end Out_Of_Range;
 
+   ----------------------
+   -- Predicates_Match --
+   ----------------------
+
+   function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
+      Pred1 : Node_Id;
+      Pred2 : Node_Id;
+
+   begin
+      if Ada_Version < Ada_2012 then
+         return True;
+
+         --  Both types must have predicates or lack them
+
+      elsif Has_Predicates (T1) /= Has_Predicates (T2) then
+         return False;
+
+         --  Check matching predicates
+
+      else
+         Pred1 :=
+           Get_Rep_Item
+             (T1, Name_Static_Predicate, Check_Parents => False);
+         Pred2 :=
+           Get_Rep_Item
+             (T2, Name_Static_Predicate, Check_Parents => False);
+
+         --  Subtypes statically match if the predicate comes from the
+         --  same declaration, which can only happen if one is a subtype
+         --  of the other and has no explicit predicate.
+
+         --  Suppress warnings on order of actuals, which is otherwise
+         --  triggered by one of the two calls below.
+
+         pragma Warnings (Off);
+         return Pred1 = Pred2
+           or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
+           or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
+         pragma Warnings (On);
+      end if;
+   end Predicates_Match;
+
    -------------------------
    -- Rewrite_In_Raise_CE --
    -------------------------
@@ -4839,55 +4881,6 @@ package body Sem_Eval is
    --  false even if the types would otherwise match in the RM sense.
 
    function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
-
-      function Predicates_Match return Boolean;
-      --  In Ada 2012, subtypes statically match if their static predicates
-      --  match as well.
-
-      ----------------------
-      -- Predicates_Match --
-      ----------------------
-
-      function Predicates_Match return Boolean is
-         Pred1 : Node_Id;
-         Pred2 : Node_Id;
-
-      begin
-         if Ada_Version < Ada_2012 then
-            return True;
-
-         --  Both types must have predicates or lack them
-
-         elsif Has_Predicates (T1) /= Has_Predicates (T2) then
-            return False;
-
-         --  Check matching predicates
-
-         else
-            Pred1 :=
-              Get_Rep_Item
-                (T1, Name_Static_Predicate, Check_Parents => False);
-            Pred2 :=
-              Get_Rep_Item
-                (T2, Name_Static_Predicate, Check_Parents => False);
-
-            --  Subtypes statically match if the predicate comes from the
-            --  same declaration, which can only happen if one is a subtype
-            --  of the other and has no explicit predicate.
-
-            --  Suppress warnings on order of actuals, which is otherwise
-            --  triggered by one of the two calls below.
-
-            pragma Warnings (Off);
-            return Pred1 = Pred2
-              or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
-              or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
-            pragma Warnings (On);
-         end if;
-      end Predicates_Match;
-
-   --  Start of processing for Subtypes_Statically_Match
-
    begin
       --  A type always statically matches itself
 
@@ -4903,7 +4896,7 @@ package body Sem_Eval is
 
       --  No match if predicates do not match
 
-      elsif not Predicates_Match then
+      elsif not Predicates_Match (T1, T2) then
          return False;
 
       --  Scalar types
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 312fac13cf7..6d5cdc8319f 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -454,6 +454,12 @@ package Sem_Eval is
    --  it cannot (because the value of Lo or Hi is not known at compile time)
    --  then it returns False.
 
+   function Predicates_Match (T1, T2 : Entity_Id) return Boolean;
+   --  In Ada 2012, subtypes statically match if their static predicates
+   --  match as well. This function performs the required check that
+   --  predicates match. Separated out from Subtypes_Statically_Match so
+   --  that it can be used in specializing error messages.
+
    procedure Why_Not_Static (Expr : Node_Id);
    --  This procedure may be called after generating an error message that
    --  complains that something is non-static. If it finds good reasons,