[multiple changes]

2015-10-26  Bob Duff  <duff@adacore.com>

	* snames.ads-tmpl, aspects.adb, aspects.ads: Add the aspect and
	pragma names and enter into relevant tables.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Analyze aspect
	Predicate_Failure.
	* sem_prag.adb (Predicate_Failure): Analyze pragma Predicate_Failure.
	* exp_util.adb (Make_Predicate_Check): When building the Check
	pragma, if Predicate_Failure has been specified, add the relevant
	String argument to the pragma.
	* par-prag.adb (Prag): Add Predicate_Failure to list of pragmas
	handled during semantic analysis.

2015-10-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb (Analyze_Assignment): If the left-hand side
	is an indexed component with generalized indexing, discard
	interpretation that yields a reference type, which is not
	assignable. This prevent spurious ambiguities when the right-hand
	side is an aggregate which does not provide a target type.

From-SVN: r229358

9 files changed, 153 insertions, 15 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f93439e..c409799 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,26 @@
 2015-10-26  Bob Duff  <duff@adacore.com>
 
+	* snames.ads-tmpl, aspects.adb, aspects.ads: Add the aspect and
+	pragma names and enter into relevant tables.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Analyze aspect
+	Predicate_Failure.
+	* sem_prag.adb (Predicate_Failure): Analyze pragma Predicate_Failure.
+	* exp_util.adb (Make_Predicate_Check): When building the Check
+	pragma, if Predicate_Failure has been specified, add the relevant
+	String argument to the pragma.
+	* par-prag.adb (Prag): Add Predicate_Failure to list of pragmas
+	handled during semantic analysis.
+
+2015-10-26  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch5.adb (Analyze_Assignment): If the left-hand side
+	is an indexed component with generalized indexing, discard
+	interpretation that yields a reference type, which is not
+	assignable. This prevent spurious ambiguities when the right-hand
+	side is an aggregate which does not provide a target type.
+
+2015-10-26  Bob Duff  <duff@adacore.com>
+
 	* exp_ch7.adb, exp_ch6.adb: Minor comment fix.
 
 2015-10-26  Hristian Kirtchev  <kirtchev@adacore.com>
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index e2bf1ea..4398f92 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -582,6 +582,7 @@ package body Aspects is
     Aspect_Pre                          => Aspect_Pre,
     Aspect_Precondition                 => Aspect_Pre,
     Aspect_Predicate                    => Aspect_Predicate,
+    Aspect_Predicate_Failure            => Aspect_Predicate_Failure,
     Aspect_Preelaborate                 => Aspect_Preelaborate,
     Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
     Aspect_Priority                     => Aspect_Priority,
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 55c51a1..5e042ad 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -125,6 +125,7 @@ package Aspects is
       Aspect_Pre,
       Aspect_Precondition,
       Aspect_Predicate,                     -- GNAT
+      Aspect_Predicate_Failure,
       Aspect_Priority,
       Aspect_Read,
       Aspect_Refined_Depends,               -- GNAT
@@ -361,6 +362,7 @@ package Aspects is
       Aspect_Pre                        => Expression,
       Aspect_Precondition               => Expression,
       Aspect_Predicate                  => Expression,
+      Aspect_Predicate_Failure          => Expression,
       Aspect_Priority                   => Expression,
       Aspect_Read                       => Name,
       Aspect_Refined_Depends            => Expression,
@@ -472,6 +474,7 @@ package Aspects is
       Aspect_Pre                          => Name_Pre,
       Aspect_Precondition                 => Name_Precondition,
       Aspect_Predicate                    => Name_Predicate,
+      Aspect_Predicate_Failure            => Name_Predicate_Failure,
       Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization,
       Aspect_Preelaborate                 => Name_Preelaborate,
       Aspect_Priority                     => Name_Priority,
@@ -587,7 +590,7 @@ package Aspects is
    --  constructs. To handle forward references in such aspects, the compiler
    --  delays the analysis of their respective pragmas by collecting them in
    --  N_Contract nodes. The pragmas are then analyzed at the end of the
-   --  declarative region which contains the related construct. For details,
+   --  declarative region containing the related construct. For details,
    --  see routines Analyze_xxx_In_Decl_Part.
 
    --  The following shows which aspects are delayed. There are three cases:
@@ -676,6 +679,7 @@ package Aspects is
       Aspect_Pre                          => Always_Delay,
       Aspect_Precondition                 => Always_Delay,
       Aspect_Predicate                    => Always_Delay,
+      Aspect_Predicate_Failure            => Always_Delay,
       Aspect_Preelaborable_Initialization => Always_Delay,
       Aspect_Preelaborate                 => Always_Delay,
       Aspect_Priority                     => Always_Delay,
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index aec7320..d546fa8 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6507,8 +6507,9 @@ package body Exp_Util is
      (Typ  : Entity_Id;
       Expr : Node_Id) return Node_Id
    is
-      Loc : constant Source_Ptr := Sloc (Expr);
-      Nam : Name_Id;
+      Loc      : constant Source_Ptr := Sloc (Expr);
+      Nam      : Name_Id;
+      Arg_List : List_Id;
 
    begin
       --  If predicate checks are suppressed, then return a null statement.
@@ -6537,14 +6538,24 @@ package body Exp_Util is
          Nam := Name_Predicate;
       end if;
 
+      Arg_List := New_List (
+        Make_Pragma_Argument_Association (Loc,
+          Expression => Make_Identifier (Loc, Nam)),
+        Make_Pragma_Argument_Association (Loc,
+          Expression => Make_Predicate_Call (Typ, Expr)));
+
+      if Has_Aspect (Typ, Aspect_Predicate_Failure) then
+         Append_To (Arg_List,
+           Make_Pragma_Argument_Association (Loc,
+             Expression =>
+               New_Copy_Tree (Expression
+                 (Find_Aspect (Typ, Aspect_Predicate_Failure)))));
+      end if;
+
       return
         Make_Pragma (Loc,
           Pragma_Identifier            => Make_Identifier (Loc, Name_Check),
-          Pragma_Argument_Associations => New_List (
-            Make_Pragma_Argument_Association (Loc,
-              Expression => Make_Identifier (Loc, Nam)),
-            Make_Pragma_Argument_Association (Loc,
-              Expression => Make_Predicate_Call (Typ, Expr))));
+          Pragma_Argument_Associations => Arg_List);
    end Make_Predicate_Check;
 
    ----------------------------
@@ -9427,7 +9438,8 @@ package body Exp_Util is
 
       return Present (S)
         and then Get_TSS_Name (S) /= TSS_Null
-        and then not Is_Predicate_Function (S);
+        and then not Is_Predicate_Function (S)
+        and then not Is_Predicate_Function_M (S);
    end Within_Internal_Subprogram;
 
    ----------------------------
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index a3ed732..c317949 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1421,6 +1421,7 @@ begin
            Pragma_Pre                            |
            Pragma_Precondition                   |
            Pragma_Predicate                      |
+           Pragma_Predicate_Failure              |
            Pragma_Preelaborate                   |
            Pragma_Pre_Class                      |
            Pragma_Priority                       |
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index d02d8e5..36eb7ad 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1642,7 +1642,7 @@ package body Sem_Ch13 is
                end if;
 
                Set_Corresponding_Aspect (Aitem, Aspect);
-               Set_From_Aspect_Specification (Aitem, True);
+               Set_From_Aspect_Specification (Aitem);
             end Make_Aitem_Pragma;
 
          --  Start of processing for Analyze_One_Aspect
@@ -1979,7 +1979,7 @@ package body Sem_Ch13 is
                          Expression => Ent),
                        Make_Pragma_Argument_Association (Sloc (Expr),
                          Expression => Relocate_Node (Expr))),
-                     Pragma_Name                  => Name_Predicate);
+                     Pragma_Name => Name_Predicate);
 
                   --  Mark type has predicates, and remember what kind of
                   --  aspect lead to this predicate (we need this to access
@@ -2010,6 +2010,46 @@ package body Sem_Ch13 is
                      Ensure_Freeze_Node (Full_View (E));
                   end if;
 
+               --  Predicate_Failure
+
+               when Aspect_Predicate_Failure =>
+
+                  --  This aspect applies only to subtypes
+
+                  if not Is_Type (E) then
+                     Error_Msg_N
+                       ("predicate can only be specified for a subtype",
+                        Aspect);
+                     goto Continue;
+
+                  elsif Is_Incomplete_Type (E) then
+                     Error_Msg_N
+                       ("predicate cannot apply to incomplete view", Aspect);
+                     goto Continue;
+                  end if;
+
+                  --  Construct the pragma
+
+                  Make_Aitem_Pragma
+                    (Pragma_Argument_Associations => New_List (
+                       Make_Pragma_Argument_Association (Sloc (Ent),
+                         Expression => Ent),
+                       Make_Pragma_Argument_Association (Sloc (Expr),
+                         Expression => Relocate_Node (Expr))),
+                     Pragma_Name => Name_Predicate_Failure);
+
+                  Set_Has_Predicates (E);
+
+                  --  If the type is private, indicate that its completion
+                  --  has a freeze node, because that is the one that will
+                  --  be visible at freeze time.
+
+                  if Is_Private_Type (E) and then Present (Full_View (E)) then
+                     Set_Has_Predicates (Full_View (E));
+                     Set_Has_Delayed_Aspects (Full_View (E));
+                     Ensure_Freeze_Node (Full_View (E));
+                  end if;
+
                --  Case 2b: Aspects corresponding to pragmas with two
                --  arguments, where the second argument is a local name
                --  referring to the entity, and the first argument is the
@@ -7670,7 +7710,7 @@ package body Sem_Ch13 is
    --  Start of processing for Build_Discrete_Static_Predicate
 
    begin
-      --  Establish  bounds for the predicate
+      --  Establish bounds for the predicate
 
       if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
          TLo := Expr_Value (Type_Low_Bound (Typ));
@@ -9373,6 +9413,9 @@ package body Sem_Ch13 is
               Aspect_Type_Invariant    =>
             T := Standard_Boolean;
 
+         when Aspect_Predicate_Failure =>
+            T := Standard_String;
+
          --  Here is the list of aspects that don't require delay analysis
 
          when Aspect_Abstract_State             |
@@ -12509,9 +12552,10 @@ package body Sem_Ch13 is
             case A_Id is
                --  For now we only deal with aspects that do not generate
                --  subprograms, or that may mention current instances of
-               --  types. These will require special handling (TBD).
+               --  types. These will require special handling (???TBD).
 
                when Aspect_Predicate |
+                    Aspect_Predicate_Failure |
                     Aspect_Invariant |
                     Aspect_Static_Predicate |
                     Aspect_Dynamic_Predicate =>
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 3e79179..0c9c56e 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -316,7 +316,18 @@ package body Sem_Ch5 is
             Get_First_Interp (Lhs, I, It);
 
             while Present (It.Typ) loop
-               if Has_Compatible_Type (Rhs, It.Typ) then
+               --  An indexed component with generalized indexing is always
+               --  overloaded with the corresponding dereference. Discard
+               --  the interpretation that yields a reference type, which
+               --  is not assignable.
+
+               if Nkind (Lhs) = N_Indexed_Component
+                 and then Present (Generalized_Indexing (Lhs))
+                 and then Has_Implicit_Dereference (It.Typ)
+               then
+                  null;
+
+               elsif Has_Compatible_Type (Rhs, It.Typ) then
                   if T1 /= Any_Type then
 
                      --  An explicit dereference is overloaded if the prefix
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 0b6e64d..cd5f9d0 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -18243,6 +18243,47 @@ package body Sem_Prag is
             Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
          end Predicate;
 
+         -----------------------
+         -- Predicate_Failure --
+         -----------------------
+
+         --  pragma Predicate_Failure
+         --    ([Entity  =>] type_LOCAL_NAME,
+         --     [Message =>] string_EXPRESSION);
+
+         when Pragma_Predicate_Failure => Predicate_Failure : declare
+            Discard : Boolean;
+            Typ     : Entity_Id;
+            Type_Id : Node_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_Arg_Count (2);
+            Check_Optional_Identifier (Arg1, Name_Entity);
+            Check_Optional_Identifier (Arg2, Name_Message);
+
+            Check_Arg_Is_Local_Name (Arg1);
+
+            Type_Id := Get_Pragma_Arg (Arg1);
+            Find_Type (Type_Id);
+            Typ := Entity (Type_Id);
+
+            if Typ = Any_Type then
+               return;
+            end if;
+
+            --  A pragma that applies to a Ghost entity becomes Ghost for the
+            --  purposes of legality checks and removal of ignored Ghost code.
+
+            Mark_Pragma_As_Ghost (N, Typ);
+
+            --  The remaining processing is simply to link the pragma on to
+            --  the rep item chain, for processing when the type is frozen.
+            --  This is accomplished by a call to Rep_Item_Too_Late.
+
+            Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
+         end Predicate_Failure;
+
          ------------------
          -- Preelaborate --
          ------------------
@@ -27291,7 +27332,7 @@ package body Sem_Prag is
    --  0   indicates that appearance in any argument is not significant
    --  +n  indicates that appearance as argument n is significant, but all
    --      other arguments are not significant
-   --  9n  arguments from n on are significant, before n inisignificant
+   --  9n  arguments from n on are significant, before n insignificant
 
    Sig_Flags : constant array (Pragma_Id) of Int :=
      (Pragma_Abort_Defer                    => -1,
@@ -27446,6 +27487,7 @@ package body Sem_Prag is
       Pragma_Pre                            => -1,
       Pragma_Precondition                   => -1,
       Pragma_Predicate                      => -1,
+      Pragma_Predicate_Failure              => -1,
       Pragma_Preelaborable_Initialization   => -1,
       Pragma_Preelaborate                   =>  0,
       Pragma_Pre_Class                      => -1,
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 6d9ca7d..76d8028 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -570,6 +570,7 @@ package Snames is
    Name_Pre                            : constant Name_Id := N + $; -- GNAT
    Name_Precondition                   : constant Name_Id := N + $; -- GNAT
    Name_Predicate                      : constant Name_Id := N + $; -- GNAT
+   Name_Predicate_Failure              : constant Name_Id := N + $; -- Ada 12
    Name_Preelaborable_Initialization   : constant Name_Id := N + $; -- Ada 05
    Name_Preelaborate                   : constant Name_Id := N + $;
    Name_Pre_Class                      : constant Name_Id := N + $; -- GNAT
@@ -1895,6 +1896,7 @@ package Snames is
       Pragma_Pre,
       Pragma_Precondition,
       Pragma_Predicate,
+      Pragma_Predicate_Failure,
       Pragma_Preelaborable_Initialization,
       Pragma_Preelaborate,
       Pragma_Pre_Class,