[multiple changes]

2010-10-12  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Clarify that 'Old can be used in preconditions and
	postcondition pragmas.

2010-10-12  Robert Dewar  <dewar@adacore.com>

	* errout.ads, erroutc.adb: The # insertion now handles from in place of
	at.
	* exp_prag.adb (Expand_Pragma_Check): Suppress generated default
	message if new switch Exception_Locations_Suppressed is set.
	(Expand_Pragma_Check): Revised wording for default message for case
	of precondition or postcondition.
	* namet.ads, namet.adb (Build_Location_String): New procedure.
	* opt.ads (List_Inherited_Pre_Post): New flag.
	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Add call to
	list inherited pre/post aspects.
	* sem_ch13.adb (Analyze_Aspect_Specification): Improve generation of
	messages for precondition/postcondition cases.
	* sem_ch6.adb (Process_PPCs): General cleanup, and list inherited PPC's
	if flag List_Inherited_Pre_Post is set True.
	(Process_PPCs): Add initial handling for inherited preconditions
	(List_Inherited_Pre_Post_Aspects): New procedure
	* sem_ch6.ads (List_Inherited_Pre_Post_Aspects): New procedure
	* sem_disp.adb (Inherited_Subprograms): New function
	* sem_disp.ads (Inherited_Subprograms): New function
	* sem_prag.adb (Check_Duplicate_Pragma): Clean up handling of
	pre/postcondition.
	(Check_Precondition_Postcondition): Check for inherited aspects
	* sem_warn.adb: Process -gnatw.l/w.L setting List_Inherited_Pre_Post
	* sinfo.ads, sinfo.adb (Split_PPC): New flag.
	* sinput.ads, sinput.adb (Build_Location_String): New function.
	* usage.adb: Add line for -gnatw.l/-gnatw.L

2010-10-12  Javier Miranda  <miranda@adacore.com>

	* exp_util.adb (Remove_Side_Effects): Remove wrong code.

2010-10-12  Arnaud Charlet  <charlet@adacore.com>

	* xref_lib.adb: Add handling of j/J letters.

From-SVN: r165361

gcc/ada/ChangeLog

@@ -1,3 +1,45 @@
+2010-10-12  Robert Dewar  <dewar@adacore.com>
+
+	* gnat_rm.texi: Clarify that 'Old can be used in preconditions and
+	postcondition pragmas.
+
+2010-10-12  Robert Dewar  <dewar@adacore.com>
+
+	* errout.ads, erroutc.adb: The # insertion now handles from in place of
+	at.
+	* exp_prag.adb (Expand_Pragma_Check): Suppress generated default
+	message if new switch Exception_Locations_Suppressed is set.
+	(Expand_Pragma_Check): Revised wording for default message for case
+	of precondition or postcondition.
+	* namet.ads, namet.adb (Build_Location_String): New procedure.
+	* opt.ads (List_Inherited_Pre_Post): New flag.
+	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Add call to
+	list inherited pre/post aspects.
+	* sem_ch13.adb (Analyze_Aspect_Specification): Improve generation of
+	messages for precondition/postcondition cases.
+	* sem_ch6.adb (Process_PPCs): General cleanup, and list inherited PPC's
+	if flag List_Inherited_Pre_Post is set True.
+	(Process_PPCs): Add initial handling for inherited preconditions
+	(List_Inherited_Pre_Post_Aspects): New procedure
+	* sem_ch6.ads (List_Inherited_Pre_Post_Aspects): New procedure
+	* sem_disp.adb (Inherited_Subprograms): New function
+	* sem_disp.ads (Inherited_Subprograms): New function
+	* sem_prag.adb (Check_Duplicate_Pragma): Clean up handling of
+	pre/postcondition.
+	(Check_Precondition_Postcondition): Check for inherited aspects
+	* sem_warn.adb: Process -gnatw.l/w.L setting List_Inherited_Pre_Post
+	* sinfo.ads, sinfo.adb (Split_PPC): New flag.
+	* sinput.ads, sinput.adb (Build_Location_String): New function.
+	* usage.adb: Add line for -gnatw.l/-gnatw.L
+
+2010-10-12  Javier Miranda  <miranda@adacore.com>
+
+	* exp_util.adb (Remove_Side_Effects): Remove wrong code.
+
+2010-10-12  Arnaud Charlet  <charlet@adacore.com>
+
+	* xref_lib.adb: Add handling of j/J letters.
+
 2010-10-12  Pascal Obry  <obry@adacore.com>
 
 	* adaint.c (__gnat_number_of_cpus): Add implementation for Windows.

gcc/ada/errout.ads

@@ -207,6 +207,10 @@ package Errout is
    --      The idea is that for any use of -gnatj, it will still be the case
    --      that a location reference appears only at the end of a line.
 
+   --      Note: the output of the string "at " is suppressed if the string
+   --      " from" or " from " immediately precedes the insertion character #.
+   --      Certain messages read better with from than at.
+
    --    Insertion character } (Right brace: insert type reference)
    --      The character } is replaced by a string describing the type
    --      referenced by the entity whose Id is stored in Error_Msg_Node_1.

gcc/ada/erroutc.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -717,11 +717,31 @@ package body Erroutc is
       Sindex_Loc  : Source_File_Index;
       Sindex_Flag : Source_File_Index;
 
+      procedure Set_At;
+      --  Outputs "at " unless last characters in buffer are " from ". Certain
+      --  messages read better with from than at.
+
+      ------------
+      -- Set_At --
+      ------------
+
+      procedure Set_At is
+      begin
+         if Msglen < 6
+           or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
+         then
+            Set_Msg_Str ("at ");
+         end if;
+      end Set_At;
+
+   --  Start of processing for Set_Msg_Insertion_Line_Number
+
    begin
       Set_Msg_Blank;
 
       if Loc = No_Location then
-         Set_Msg_Str ("at unknown location");
+         Set_At;
+         Set_Msg_Str ("unknown location");
 
       elsif Loc = System_Location then
          Set_Msg_Str ("in package System");
@@ -743,7 +763,7 @@ package body Erroutc is
          Sindex_Flag := Get_Source_File_Index (Flag);
 
          if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
-            Set_Msg_Str ("at ");
+            Set_At;
             Get_Name_String
               (Reference_Name (Get_Source_File_Index (Loc)));
             Set_Msg_Name_Buffer;
@@ -752,7 +772,8 @@ package body Erroutc is
          --  If in current file, add text "at line "
 
          else
-            Set_Msg_Str ("at line ");
+            Set_At;
+            Set_Msg_Str ("line ");
          end if;
 
          --  Output line number for reference

gcc/ada/exp_prag.adb

@@ -310,6 +310,9 @@ package body Exp_Prag is
       --  be able to handle the assert error (which would not be the case if a
       --  call is made to the Raise_Assert_Failure procedure).
 
+      --  We also generate the direct raise if the Suppress_Exception_Locations
+      --  is active, since we don't want to generate messages in this case.
+
       --  Note that the reason we do not always generate a direct raise is that
       --  the form in which the procedure is called allows for more efficient
       --  breakpointing of assertion errors.
@@ -320,9 +323,10 @@ package body Exp_Prag is
 
       --  Case where we generate a direct raise
 
-      if (Debug_Flag_Dot_G
+      if ((Debug_Flag_Dot_G
            or else Restriction_Active (No_Exception_Propagation))
-        and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))
+          and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
+        or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
       then
          Rewrite (N,
            Make_If_Statement (Loc,
@@ -337,29 +341,55 @@ package body Exp_Prag is
       --  Case where we call the procedure
 
       else
-         --  First, we need to prepare the string argument
-
          --  If we have a message given, use it
 
          if Present (Arg3 (N)) then
-            Msg := Arg3 (N);
+            Msg := Get_Pragma_Arg (Arg3 (N));
 
-         --  Otherwise string is "name failed at location" except in the case
+         --  Here we have no string, so prepare one
-         --  of Assertion where "name failed at" is omitted.
 
          else
-            if Nam = Name_Assertion then
+            declare
-               Name_Len := 0;
+               Msg_Loc : constant String := Build_Location_String (Loc);
-            else
-               Get_Name_String (Nam);
-               Set_Casing (Identifier_Casing (Current_Source_File));
-               Add_Str_To_Name_Buffer (" failed at ");
-            end if;
 
-            Build_Location_String (Loc);
+            begin
-            Msg :=
+               --  For Assert, we just use the location
-              Make_String_Literal (Loc,
+
-                Strval => String_From_Name_Buffer);
+               if Nam = Name_Assertion then
+                  Name_Len := 0;
+
+                  --  For any check except Precondition/Postcondition, the
+                  --  string is "xxx failed at yyy" where xxx is the name of
+                  --  the check with current source file casing.
+
+               elsif Nam /= Name_Precondition
+                       and then
+                     Nam /= Name_Postcondition
+               then
+                  Get_Name_String (Nam);
+                  Set_Casing (Identifier_Casing (Current_Source_File));
+                  Add_Str_To_Name_Buffer (" failed at ");
+
+               --  For special case of Precondition/Postcondition the string is
+               --  "failed xx from yy" where xx is precondition/postcondition
+               --  in all lower case. The reason for this different wording is
+               --  that the failure is not at the point of occurrence of the
+               --  pragma, unlike the other Check cases.
+
+               else
+                  Get_Name_String (Nam);
+                  Insert_Str_In_Name_Buffer ("failed ", 1);
+                  Add_Str_To_Name_Buffer (" from ");
+               end if;
+
+               --  In all cases, add location string
+
+               Add_Str_To_Name_Buffer (Msg_Loc);
+
+               --  Build the message
+
+               Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
+            end;
          end if;
 
          --  Now rewrite as an if statement
@@ -373,7 +403,7 @@ package body Exp_Prag is
                Make_Procedure_Call_Statement (Loc,
                  Name =>
                    New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
-                 Parameter_Associations => New_List (Msg)))));
+                 Parameter_Associations => New_List (Relocate_Node (Msg))))));
       end if;
 
       Analyze (N);

gcc/ada/exp_util.adb

@@ -4839,21 +4839,6 @@ package body Exp_Util is
          return;
       end if;
 
-      --  No action needed for renamings of class-wide expressions because for
-      --  class-wide types Remove_Side_Effects uses a renaming to capture the
-      --  expression (and hence we would generate a never-ending loop in the
-      --  front end).
-
-      --  For now, disable this test. class-wide renamings can have side
-      --  effects, and this test causes such side effects to be duplicated.
-      --  To be sorted out later ???
-
-      if False and then Is_Class_Wide_Type (Exp_Type)
-        and then Nkind (Parent (Exp)) = N_Object_Renaming_Declaration
-      then
-         return;
-      end if;
-
       --  All this must not have any checks
 
       Scope_Suppress := (others => True);

gcc/ada/gnat_rm.texi

@@ -6158,14 +6158,17 @@ will be 64 (8 bytes).
 @cindex Postconditions
 @noindent
 The attribute Prefix'Old can be used within a
-subprogram to refer to the value of the prefix on entry. So for
+subprogram body or within a precondition or
+postcondition pragma. The effect is to
+refer to the value of the prefix on entry. So for
 example if you have an argument of a record type X called Arg1,
 you can refer to Arg1.Field'Old which yields the value of
 Arg1.Field on entry. The implementation simply involves generating
 an object declaration which captures the value on entry. Any
 prefix is allowed except one of a limited type (since limited
-types cannot be copied to capture their values) or a local variable
+types cannot be copied to capture their values) or an expression
-(since it does not exist at subprogram entry time).
+which references a local variable
+(since local variables do not exist at subprogram entry time).
 
 The following example shows the use of 'Old to implement
 a test of a postcondition:

gcc/ada/namet.adb

@@ -867,6 +867,19 @@ package body Namet is
       null;
    end Initialize;
 
+   -------------------------------
+   -- Insert_Str_In_Name_Buffer --
+   -------------------------------
+
+   procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is
+      SL : constant Natural := S'Length;
+   begin
+      Name_Buffer (Index + SL .. Name_Len + SL) :=
+        Name_Buffer (Index .. Name_Len);
+      Name_Buffer (Index .. Index + SL - 1) := S;
+      Name_Len := Name_Len + SL;
+   end Insert_Str_In_Name_Buffer;
+
    ----------------------
    -- Is_Internal_Name --
    ----------------------

gcc/ada/namet.ads

@@ -350,6 +350,11 @@ package Namet is
    --  Add characters of string S to the end of the string currently stored
    --  in the Name_Buffer, incrementing Name_Len by the length of the string.
 
+   procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive);
+   --  Inserts given string in name buffer, starting at Index. Any existing
+   --  characters at or past this location get moved beyond the inserted string
+   --  and Name_Len is incremented by the length of the string.
+
    procedure Set_Character_Literal_Name (C : Char_Code);
    --  This procedure sets the proper encoded name for the character literal
    --  for the given character code. On return Name_Buffer and Name_Len are

gcc/ada/opt.ads

@@ -729,6 +729,11 @@ package Opt is
    --  Set to True to skip compile and bind steps (except when Bind_Only is
    --  set to True).
 
+   List_Inherited_Pre_Post : Boolean := True;
+   --  GNAT
+   --  List inherited preconditions and postconditions from Pre'Class and
+   --  Post'Class aspects for ancestor subprograms.
+
    List_Restrictions : Boolean := False;
    --  GNATBIND
    --  Set to True to list restrictions pragmas that could apply to partition

gcc/ada/sem_ch12.adb

@@ -2877,6 +2877,8 @@ package body Sem_Ch12 is
       End_Scope;
       Exit_Generic_Scope (Id);
       Generate_Reference_To_Formals (Id);
+
+      List_Inherited_Pre_Post_Aspects (Id);
       Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
    end Analyze_Generic_Subprogram_Declaration;
 

gcc/ada/sem_ch13.adb

@@ -667,12 +667,14 @@ package body Sem_Ch13 is
             Loc  : constant Source_Ptr := Sloc (Aspect);
             Id   : constant Node_Id    := Identifier (Aspect);
             Expr : constant Node_Id    := Expression (Aspect);
-            Eloc :          Source_Ptr := Sloc (Expr);
             Nam  : constant Name_Id    := Chars (Id);
             A_Id : constant Aspect_Id  := Get_Aspect_Id (Nam);
             Anod : Node_Id;
             T    : Entity_Id;
 
+            Eloc : Source_Ptr := Sloc (Expr);
+            --  Source location of expression, modified when we split PPC's
+
          begin
             Set_Entity (Aspect, E);
             Ent := New_Occurrence_Of (E, Sloc (Id));
@@ -688,8 +690,41 @@ package body Sem_Ch13 is
                then
                   Error_Msg_Name_1 := Nam;
                   Error_Msg_Sloc := Sloc (Anod);
-                  Error_Msg_NE
+
-                    ("aspect% for & ignored, already given at#", Id, E);
+                  --  Case of same aspect specified twice
+
+                  if Class_Present (Anod) = Class_Present (Aspect) then
+                     if not Class_Present (Anod) then
+                        Error_Msg_NE
+                          ("aspect% for & previously given#",
+                           Id, E);
+                     else
+                        Error_Msg_NE
+                          ("aspect `%''Class` for & previously given#",
+                           Id, E);
+                     end if;
+
+                  --  Case of Pre and Pre'Class both specified
+
+                  elsif Nam = Name_Pre then
+                     if Class_Present (Aspect) then
+                        Error_Msg_NE
+                          ("aspect `Pre''Class` for & is not allowed here",
+                           Id, E);
+                        Error_Msg_NE
+                          ("\since aspect `Pre` previously given#",
+                           Id, E);
+
+                     else
+                        Error_Msg_NE
+                          ("aspect `Pre` for & is not allowed here",
+                           Id, E);
+                        Error_Msg_NE
+                          ("\since aspect `Pre''Class` previously given#",
+                           Id, E);
+                     end if;
+                  end if;
+
                   goto Continue;
                end if;
 
@@ -872,7 +907,6 @@ package body Sem_Ch13 is
 
                when Aspect_Pre | Aspect_Post => declare
                   Pname : Name_Id;
-                  Msg   : Node_Id;
 
                begin
                   if A_Id = Aspect_Pre then
@@ -886,26 +920,25 @@ package body Sem_Ch13 is
                   --  clauses. Since we allow multiple pragmas, there is no
                   --  problem in allowing multiple Pre/Post aspects internally.
 
-                  while Nkind (Expr) = N_And_Then loop
+                  --  We do not do this for Pre'Class, since we have to put
-                     Insert_After (Aspect,
+                  --  these conditions together in a complex OR expression
-                       Make_Aspect_Specification (Sloc (Right_Opnd (Expr)),
-                         Identifier    => Identifier (Aspect),
-                         Expression    => Relocate_Node (Right_Opnd (Expr)),
-                         Class_Present => Class_Present (Aspect)));
-                     Rewrite (Expr, Relocate_Node (Left_Opnd (Expr)));
-                     Eloc := Sloc (Expr);
-                  end loop;
 
-                  --  Proceed with handling what's left after this split up
+                  if Pname = Name_Postcondition
+                       or else not Class_Present (Aspect)
+                  then
+                     while Nkind (Expr) = N_And_Then loop
+                        Insert_After (Aspect,
+                          Make_Aspect_Specification (Sloc (Right_Opnd (Expr)),
+                            Identifier    => Identifier (Aspect),
+                            Expression    => Relocate_Node (Right_Opnd (Expr)),
+                            Class_Present => Class_Present (Aspect),
+                            Split_PPC     => True));
+                        Rewrite (Expr, Relocate_Node (Left_Opnd (Expr)));
+                        Eloc := Sloc (Expr);
+                     end loop;
+                  end if;
 
-                  Msg :=
+                  --  Build the precondition/postcondition pragma
-                    Make_String_Literal (Eloc,
-                      Strval => "failed "
-                                  & Get_Name_String (Pname)
-                                  & " from line "
-                                  & Get_Logical_Line_Number_Img (Eloc));
-
-                  --  Construct the pragma
 
                   Aitem :=
                     Make_Pragma (Loc,
@@ -913,13 +946,25 @@ package body Sem_Ch13 is
                         Make_Identifier (Sloc (Id),
                           Chars => Pname),
                       Class_Present                => Class_Present (Aspect),
+                      Split_PPC                    => Split_PPC (Aspect),
                       Pragma_Argument_Associations => New_List (
                         Make_Pragma_Argument_Association (Eloc,
                           Chars      => Name_Check,
-                          Expression => Relocate_Node (Expr)),
+                          Expression => Relocate_Node (Expr))));
-                        Make_Pragma_Argument_Association (Eloc,
+
-                          Chars      => Name_Message,
+                  --  Add message unless exception messages are suppressed
-                          Expression => Msg)));
+
+                  if not Opt.Exception_Locations_Suppressed then
+                     Append_To (Pragma_Argument_Associations (Aitem),
+                       Make_Pragma_Argument_Association (Eloc,
+                         Chars     => Name_Message,
+                         Expression =>
+                           Make_String_Literal (Eloc,
+                             Strval => "failed "
+                                       & Get_Name_String (Pname)
+                                       & " from "
+                                       & Build_Location_String (Eloc))));
+                  end if;
 
                   Set_From_Aspect_Specification (Aitem, True);
 
@@ -1213,7 +1258,7 @@ package body Sem_Ch13 is
             if Entity (A) = U_Ent then
                Error_Msg_Name_1 := Chars (N);
                Error_Msg_Sloc := Sloc (A);
-               Error_Msg_NE ("aspect% for & previously specified#", N, U_Ent);
+               Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
                return True;
             end if;
          end if;

gcc/ada/sem_ch6.adb

@@ -2766,7 +2766,7 @@ package body Sem_Ch6 is
          end if;
       end if;
 
-      Designator :=  Analyze_Subprogram_Specification (Specification (N));
+      Designator := Analyze_Subprogram_Specification (Specification (N));
       Generate_Definition (Designator);
 
       if Debug_Flag_C then
@@ -2916,6 +2916,7 @@ package body Sem_Ch6 is
          Write_Eol;
       end if;
 
+      List_Inherited_Pre_Post_Aspects (Designator);
       Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N));
    end Analyze_Subprogram_Declaration;
 
@@ -6937,6 +6938,43 @@ package body Sem_Ch6 is
       end if;
    end Is_Non_Overriding_Operation;
 
+   -------------------------------------
+   -- List_Inherited_Pre_Post_Aspects --
+   -------------------------------------
+
+   procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is
+   begin
+      if Opt.List_Inherited_Pre_Post
+        and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E))
+      then
+         declare
+            Inherited : constant Subprogram_List :=
+                          Inherited_Subprograms (E);
+            P         : Node_Id;
+
+         begin
+            for J in Inherited'Range loop
+               P := Spec_PPC_List (Inherited (J));
+               while Present (P) loop
+                  Error_Msg_Sloc := Sloc (P);
+
+                  if Class_Present (P) and then not Split_PPC (P) then
+                     if Pragma_Name (P) = Name_Precondition then
+                        Error_Msg_N
+                          ("?info: & inherits `Pre''Class` aspect from #", E);
+                     else
+                        Error_Msg_N
+                          ("?info: & inherits `Post''Class` aspect from #", E);
+                     end if;
+                  end if;
+
+                  P := Next_Pragma (P);
+               end loop;
+            end loop;
+         end;
+      end if;
+   end List_Inherited_Pre_Post_Aspects;
+
    ------------------------------
    -- Make_Inequality_Operator --
    ------------------------------
@@ -8586,11 +8624,25 @@ package body Sem_Ch6 is
       Body_Id : Entity_Id)
    is
       Loc   : constant Source_Ptr := Sloc (N);
-      Plist : List_Id             := No_List;
       Prag  : Node_Id;
       Subp  : Entity_Id;
       Parms : List_Id;
 
+      Precond : Node_Id := Empty;
+      --  Set non-Empty if we prepend precondition to the declarations. This
+      --  is used to hook up inherited preconditions (adding the condition
+      --  expression with OR ELSE, and adding the message).
+
+      Inherited_Precond : Node_Id;
+      --  Precondition inherited from parent subprogram
+
+      Inherited : constant Subprogram_List :=
+                    Inherited_Subprograms (Spec_Id);
+      --  List of subprograms inherited by this subprogram, null if no Spec_Id
+
+      Plist : List_Id := No_List;
+      --  List of generated postconditions
+
       function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id;
       --  Prag contains an analyzed precondition or postcondition pragma. This
       --  function copies the pragma, changes it to the corresponding Check
@@ -8665,19 +8717,26 @@ package body Sem_Ch6 is
            Make_Identifier (Sloc (Prag),
              Chars => Name_Check));
 
-         --  If this is inherited case then the current message starts with
+         --  If this is inherited case and the current message starts with
-         --  "failed p" and we change this to "failed inherited p".
+         --  "failed p", we change it to "failed inherited p...".
 
          if Present (Pspec) then
-            String_To_Name_Buffer
+            declare
-              (Strval (Expression (Last (Pragma_Argument_Associations (CP)))));
+               Msg : constant Node_Id :=
-            pragma Assert (Name_Buffer (1 .. 8) = "failed p");
+                       Last (Pragma_Argument_Associations (CP));
-            Name_Len := Name_Len + 10;
+
-            Name_Buffer (17 .. Name_Len) := Name_Buffer (7 .. Name_Len - 10);
+            begin
-            Name_Buffer (7 .. 16) := " inherited";
+               if Chars (Msg) = Name_Message then
-            Set_Strval
+                  String_To_Name_Buffer (Strval (Expression (Msg)));
-              (Expression (Last (Pragma_Argument_Associations (CP))),
+
-               String_From_Name_Buffer);
+                  if Name_Buffer (1 .. 8) = "failed p" then
+                     Insert_Str_In_Name_Buffer ("inherited ", 8);
+                     Set_Strval
+                       (Expression (Last (Pragma_Argument_Associations (CP))),
+                        String_From_Name_Buffer);
+                  end if;
+               end if;
+            end;
          end if;
 
          --  Return the check pragma
@@ -8688,12 +8747,6 @@ package body Sem_Ch6 is
    --  Start of processing for Process_PPCs
 
    begin
-      --  Nothing to do if we are not generating code
-
-      if Operating_Mode /= Generate_Code then
-         return;
-      end if;
-
       --  Grab preconditions from spec
 
       if Present (Spec_Id) then
@@ -8707,16 +8760,115 @@ package body Sem_Ch6 is
             if Pragma_Name (Prag) = Name_Precondition
               and then Pragma_Enabled (Prag)
             then
-               --  Add pragma Check at the start of the declarations of N.
+               --  For Pre (or Precondition pragma), we simply prepend the
-               --  Note that this processing reverses the order of the list,
+               --  pragma to the list of declarations right away so that it
-               --  which is what we want since new entries were chained to
+               --  will be executed at the start of the procedure. Note that
-               --  the head of the list.
+               --  this processing reverses the order of the list, which is
+               --  what we want since new entries were chained to the head of
+               --  the list. There can be more then one precondition when we
+               --  use pragma Precondition
 
-               Prepend (Grab_PPC, Declarations (N));
+               if not Class_Present (Prag) then
+                  Prepend (Grab_PPC, Declarations (N));
+
+               --  For Pre'Class there can only be one pragma, and we save
+               --  it in Precond for now. We will add inherited Pre'Class
+               --  stuff before inserting this pragma in the declarations.
+               else
+                  Precond := Grab_PPC;
+               end if;
             end if;
 
             Prag := Next_Pragma (Prag);
          end loop;
+
+         --  Now deal with inherited preconditions
+
+         for J in Inherited'Range loop
+            Prag := Spec_PPC_List (Inherited (J));
+
+            while Present (Prag) loop
+               if Pragma_Name (Prag) = Name_Precondition
+                 and then Class_Present (Prag)
+               then
+                  Inherited_Precond := Grab_PPC;
+
+                  --  No precondition so far, so establish this as the first
+
+                  if No (Precond) then
+                     Precond := Inherited_Precond;
+
+                  --  Here we already have a precondition, add inherited one
+
+                  else
+                     --  Add new precondition to old one using OR ELSE
+
+                     declare
+                        New_Expr : constant Node_Id :=
+                                     Get_Pragma_Arg
+                                       (Next
+                                         (First
+                                           (Pragma_Argument_Associations
+                                             (Inherited_Precond))));
+                        Old_Expr : constant Node_Id :=
+                                     Get_Pragma_Arg
+                                       (Next
+                                         (First
+                                           (Pragma_Argument_Associations
+                                             (Precond))));
+
+                     begin
+                        if Paren_Count (Old_Expr) = 0 then
+                           Set_Paren_Count (Old_Expr, 1);
+                        end if;
+
+                        if Paren_Count (New_Expr) = 0 then
+                           Set_Paren_Count (New_Expr, 1);
+                        end if;
+
+                        Rewrite (Old_Expr,
+                          Make_Or_Else (Sloc (Old_Expr),
+                            Left_Opnd  => Relocate_Node (Old_Expr),
+                            Right_Opnd => New_Expr));
+                     end;
+
+                     --  Add new message in the form:
+
+                     --     failed precondition from bla
+                     --       also failed inherited precondition from bla
+                     --       ...
+
+                     declare
+                        New_Msg : constant Node_Id :=
+                                    Get_Pragma_Arg
+                                      (Last
+                                        (Pragma_Argument_Associations
+                                          (Inherited_Precond)));
+                        Old_Msg : constant Node_Id :=
+                                    Get_Pragma_Arg
+                                      (Last
+                                        (Pragma_Argument_Associations
+                                          (Precond)));
+                     begin
+                        Start_String (Strval (Old_Msg));
+                        Store_String_Chars (ASCII.LF & "  also ");
+                        Store_String_Chars (Strval (New_Msg));
+                        Set_Strval (Old_Msg, End_String);
+                     end;
+                  end if;
+               end if;
+
+               Prag := Next_Pragma (Prag);
+            end loop;
+         end loop;
+
+         --  If we have built a precondition for Pre'Class (including any
+         --  Pre'Class aspects inherited from parent subprograms), then we
+         --  insert this composite precondition at this stage.
+
+         if Present (Precond) then
+            Prepend (Precond, Declarations (N));
+         end if;
       end if;
 
       --  Build postconditions procedure if needed and prepend the following
@@ -8779,8 +8931,6 @@ package body Sem_Ch6 is
 
       if Present (Spec_Id) then
          declare
-            Parent_Op : Node_Id;
-
             procedure Process_Post_Conditions
               (Spec  : Node_Id;
                Class : Boolean);
@@ -8836,17 +8986,11 @@ package body Sem_Ch6 is
                Process_Post_Conditions (Spec_Id, Class => False);
             end if;
 
-            --  Process directly inherited specifications
+            --  Process inherited postconditions
 
-            Parent_Op := Spec_Id;
+            for J in Inherited'Range loop
-            loop
+               if Present (Spec_PPC_List (Inherited (J))) then
-               Parent_Op := Overridden_Operation (Parent_Op);
+                  Process_Post_Conditions (Inherited (J), Class => True);
-               exit when No (Parent_Op);
-
-               if Ekind (Parent_Op) /= E_Enumeration_Literal
-                 and then Present (Spec_PPC_List (Parent_Op))
-               then
-                  Process_Post_Conditions (Parent_Op, Class => True);
                end if;
             end loop;
          end;

gcc/ada/sem_ch6.ads

@@ -190,6 +190,10 @@ package Sem_Ch6 is
    --  conformant, and Prim is defined in the scope of Tagged_Type. Special
    --  management is done for functions returning interfaces.
 
+   procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id);
+   --  E is the entity for a subprogram or generic subprogram spec. This call
+   --  lists all inherited Pre/Post aspects if List_Inherited_Pre_Post is True.
+
    function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
    --  Determine whether two callable entities (subprograms, entries,
    --  literals) are mode conformant (RM 6.3.1(15))

gcc/ada/sem_disp.adb

@@ -1726,6 +1726,47 @@ package body Sem_Disp is
       return Empty;
    end Find_Primitive_Covering_Interface;
 
+   ---------------------------
+   -- Inherited_Subprograms --
+   ---------------------------
+
+   function Inherited_Subprograms (S : Entity_Id) return Subprogram_List is
+      Result : Subprogram_List (1 .. 6000);
+      --  6000 here is intended to be infinity. We could use an expandable
+      --  table, but it would be awfully heavy, and there is no way that we
+      --  could reasonably exceed this value.
+
+      N : Int := 0;
+      --  Number of entries in Result
+
+      Parent_Op : Entity_Id;
+      --  Traverses the Overridden_Operation chain
+
+   begin
+      if Present (S) then
+
+         --  Deal with direct inheritance
+
+         Parent_Op := S;
+         loop
+            Parent_Op := Overridden_Operation (Parent_Op);
+            exit when No (Parent_Op);
+
+            if Is_Subprogram (Parent_Op)
+              or else Is_Generic_Subprogram (Parent_Op)
+            then
+               N := N + 1;
+               Result (N) := Parent_Op;
+            end if;
+         end loop;
+
+         --  For now don't bother with interfaces, TBD ???
+
+      end if;
+
+      return Result (1 .. N);
+   end Inherited_Subprograms;
+
    ---------------------------
    -- Is_Dynamically_Tagged --
    ---------------------------

gcc/ada/sem_disp.ads

@@ -93,6 +93,17 @@ package Sem_Disp is
    --  whose alias attribute references the interface primitive). If none of
    --  these entities is found then return Empty.
 
+   type Subprogram_List is array (Nat range <>) of Entity_Id;
+   --  Type returned by Inherited_Subprograms function
+
+   function Inherited_Subprograms (S : Entity_Id) return Subprogram_List;
+   --  Given the spec of a subprogram, this function gathers any inherited
+   --  subprograms from direct inheritance or via interfaces. The list is
+   --  a list of entity id's of the specs of inherited subprograms. Returns
+   --  a null array if passed an Empty spec id. Note that the returned array
+   --  only includes subprograms and generic subprograms (and excludes any
+   --  other inherited entities, in particular enumeration literals).
+
    function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
    --  Used to determine whether a call is dispatching, i.e. if is an
    --  an expression of a class_Wide type, or a call to a function with

gcc/ada/sem_prag.adb

@@ -58,6 +58,7 @@ with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch12; use Sem_Ch12;
 with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
 with Sem_Dist; use Sem_Dist;
 with Sem_Elim; use Sem_Elim;
 with Sem_Eval; use Sem_Eval;
@@ -90,10 +91,9 @@ package body Sem_Prag is
    -- Common Handling of Import-Export Pragmas --
    ----------------------------------------------
 
-   --  In the following section, a number of Import_xxx and Export_xxx
+   --  In the following section, a number of Import_xxx and Export_xxx pragmas
-   --  pragmas are defined by GNAT. These are compatible with the DEC
+   --  are defined by GNAT. These are compatible with the DEC pragmas of the
-   --  pragmas of the same name, and all have the following common
+   --  same name, and all have the following common form and processing:
-   --  form and processing:
 
    --  pragma Export_xxx
    --        [Internal                 =>] LOCAL_NAME
@@ -1247,7 +1247,7 @@ package body Sem_Prag is
             if Nkind (P) = N_Aspect_Specification
               or else From_Aspect_Specification (P)
             then
-               Error_Msg_NE ("aspect% for & previously specified#", N, E);
+               Error_Msg_NE ("aspect% for & previously given#", N, E);
             else
                Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
             end if;
@@ -1529,33 +1529,58 @@ package body Sem_Prag is
 
             S := Defining_Unit_Name (Specification (PO));
 
-            --  Make sure we do not have the case of a pre/postcondition
+            --  Make sure we do not have the case of a precondition pragma when
-            --  pragma when the corresponding aspect is present. This is
+            --  the Pre'Class aspect is present.
-            --  never allowed. We allow either pragmas or aspects, not both.
 
             --  We do this by looking at pragmas already chained to the entity
             --  since the aspect derived pragma will be put on this list first.
 
-            if not From_Aspect_Specification (N) then
+            if Pragma_Name (N) = Name_Precondition then
-               P := Spec_PPC_List (S);
+               if not From_Aspect_Specification (N) then
-               while Present (P) loop
+                  P := Spec_PPC_List (S);
-                  if Pragma_Name (P) = Pragma_Name (N)
+                  while Present (P) loop
-                    and then From_Aspect_Specification (P)
+                     if Pragma_Name (P) = Name_Precondition
-                  then
+                       and then From_Aspect_Specification (P)
-                     Error_Msg_Sloc := Sloc (P);
+                       and then Class_Present (P)
-
+                     then
-                     if Prag_Id = Pragma_Precondition then
+                        Error_Msg_Sloc := Sloc (P);
-                        Error_Msg_Name_2 := Name_Pre;
+                        Error_Pragma
-                     else
+                          ("pragma% not allowed, `Pre''Class` aspect given#");
-                        Error_Msg_Name_2 := Name_Post;
                      end if;
 
-                     Error_Pragma
+                     P := Next_Pragma (P);
-                       ("pragma% not allowed, % aspect given#");
+                  end loop;
-                  end if;
+               end if;
+            end if;
 
-                  P := Next_Pragma (P);
+            --  Similarly check for Pre with inherited Pre'Class. Note that
-               end loop;
+            --  we cover the aspect case as well here.
+
+            if Pragma_Name (N) = Name_Precondition
+              and then not Class_Present (N)
+            then
+               declare
+                  Inherited : constant Subprogram_List :=
+                                Inherited_Subprograms (S);
+                  P         : Node_Id;
+
+               begin
+                  for J in Inherited'Range loop
+                     P := Spec_PPC_List (Inherited (J));
+                     while Present (P) loop
+                        if Pragma_Name (P) = Name_Precondition
+                          and then Class_Present (P)
+                        then
+                           Error_Msg_Sloc := Sloc (P);
+                           Error_Pragma
+                             ("pragma% not allowed, `Pre''Class` "
+                              & "aspect inherited from#");
+                        end if;
+
+                        P := Next_Pragma (P);
+                     end loop;
+                  end loop;
+               end;
             end if;
 
             --  Analyze the pragma unless it appears within a package spec,
@@ -1645,9 +1670,7 @@ package body Sem_Prag is
             if Operating_Mode /= Generate_Code
               or else Inside_A_Generic
             then
-
+               --  Analyze pragma expression for correctness and for ASIS use
-               --  Analyze expression in pragma, for correctness
-               --  and for ASIS use.
 
                Preanalyze_Spec_Expression
                  (Get_Pragma_Arg (Arg1), Standard_Boolean);
@@ -3639,7 +3662,7 @@ package body Sem_Prag is
                               Set_Mechanism_Value
                                 (Formal, Expression (Massoc));
 
-                              --  Set entity on identifier for ASIS
+                              --  Set entity on identifier (needed by ASIS)
 
                               Set_Entity (Choice, Formal);
 
@@ -3814,15 +3837,15 @@ package body Sem_Prag is
          elsif Is_Subprogram (Def_Id)
            or else Is_Generic_Subprogram (Def_Id)
          then
-            --  If the name is overloaded, pragma applies to all of the
+            --  If the name is overloaded, pragma applies to all of the denoted
-            --  denoted entities in the same declarative part.
+            --  entities in the same declarative part.
 
             Hom_Id := Def_Id;
             while Present (Hom_Id) loop
                Def_Id := Get_Base_Subprogram (Hom_Id);
 
-               --  Ignore inherited subprograms because the pragma will
+               --  Ignore inherited subprograms because the pragma will apply
-               --  apply to the parent operation, which is the one called.
+               --  to the parent operation, which is the one called.
 
                if Is_Overloadable (Def_Id)
                  and then Present (Alias (Def_Id))

gcc/ada/sem_warn.adb

@@ -3068,6 +3068,7 @@ package body Sem_Warn is
             Elab_Warnings                       := True;
             Implementation_Unit_Warnings        := True;
             Ineffective_Inline_Warnings         := True;
+            List_Inherited_Pre_Post             := True;
             Warn_On_Ada_2005_Compatibility      := True;
             Warn_On_Ada_2012_Compatibility      := True;
             Warn_On_All_Unread_Out_Parameters   := True;
@@ -3113,6 +3114,12 @@ package body Sem_Warn is
          when 'I' =>
             Warn_On_Overlap                     := False;
 
+         when 'l' =>
+            List_Inherited_Pre_Post             := True;
+
+         when 'L' =>
+            List_Inherited_Pre_Post             := False;
+
          when 'm' =>
             Warn_On_Suspicious_Modulus_Value    := True;
 
@@ -3189,6 +3196,7 @@ package body Sem_Warn is
       Elab_Warnings                       := False;
       Implementation_Unit_Warnings        := False;
       Ineffective_Inline_Warnings         := True;
+      List_Inherited_Pre_Post             := False;
       Warn_On_Ada_2005_Compatibility      := True;
       Warn_On_Ada_2012_Compatibility      := True;
       Warn_On_All_Unread_Out_Parameters   := False;
@@ -3231,6 +3239,7 @@ package body Sem_Warn is
             Constant_Condition_Warnings         := True;
             Implementation_Unit_Warnings        := True;
             Ineffective_Inline_Warnings         := True;
+            List_Inherited_Pre_Post             := True;
             Warn_On_Ada_2005_Compatibility      := True;
             Warn_On_Ada_2012_Compatibility      := True;
             Warn_On_Assertion_Failure           := True;
@@ -3261,6 +3270,7 @@ package body Sem_Warn is
             Elab_Warnings                       := False;
             Implementation_Unit_Warnings        := False;
             Ineffective_Inline_Warnings         := False;
+            List_Inherited_Pre_Post             := False;
             Warn_On_Ada_2005_Compatibility      := False;
             Warn_On_Ada_2012_Compatibility      := False;
             Warn_On_All_Unread_Out_Parameters   := False;

gcc/ada/sinfo.adb

@@ -2745,6 +2745,15 @@ package body Sinfo is
       return Node1 (N);
    end Specification;
 
+   function Split_PPC
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aspect_Specification
+        or else NT (N).Nkind = N_Pragma);
+      return Flag17 (N);
+   end Split_PPC;
+
    function Statements
       (N : Node_Id) return List_Id is
    begin
@@ -5706,6 +5715,15 @@ package body Sinfo is
       Set_Node1_With_Parent (N, Val);
    end Set_Specification;
 
+   procedure Set_Split_PPC
+      (N : Node_Id; Val : Boolean) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Aspect_Specification
+        or else NT (N).Nkind = N_Pragma);
+      Set_Flag17 (N, Val);
+   end Set_Split_PPC;
+
    procedure Set_Statements
       (N : Node_Id; Val : List_Id) is
    begin

gcc/ada/sinfo.ads

@@ -1689,6 +1689,14 @@ package Sinfo is
    --    source type entity for the unchecked conversion instantiation
    --    which gigi must do size validation for.
 
+   --  Split_PPC (Flag17)
+   --     When a Pre or Postaspect specification is processed, it is broken
+   --     into AND THEN sections. The left most section has Split_PPC set to
+   --     False, indicating that it is the original specification (e.g. for
+   --     posting errors). For other sections, Split_PPC is set to True.
+   --     This flag is set in both the N_Aspect_Specification node itself,
+   --     and in the pragma which is generated from this node.
+
    --  Static_Processing_OK (Flag4-Sem)
    --    Present in N_Aggregate nodes. When the Compile_Time_Known_Aggregate
    --    flag is set, the full value of the aggregate can be determined at
@@ -2037,7 +2045,8 @@ package Sinfo is
       --  Is_Delayed_Aspect (Flag14-Sem)
       --  Import_Interface_Present (Flag16-Sem)
       --  Aspect_Cancel (Flag11-Sem)
-      --  Class_Present (Flag6) (set False if not from Aspect with 'Class)
+      --  Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
+      --  Class_Present (Flag6) set if from Aspect with 'Class
 
       --  Note: we should have a section on what pragmas are passed on to
       --  the back end to be processed. This section should note that pragma
@@ -6442,9 +6451,15 @@ package Sinfo is
       --  Entity (Node4-Sem) entity to which the aspect applies
       --  Class_Present (Flag6) Set if 'Class present
       --  Next_Rep_Item (Node5-Sem)
+      --  Split_PPC (Flag17) Set if split pre/post attribute
 
       --  Note: Aspect_Specification is an Ada 2012 feature
 
+      --  Note: When a Pre or Post aspect specification is processed, it is
+      --  broken into AND THEN sections. The left most section has Split_PPC
+      --  set to False, indicating that it is the original specification (e.g.
+      --  for posting errors). For the other sections, Split_PPC is set True.
+
       ---------------------------------------------
       -- 13.4  Enumeration representation clause --
       ---------------------------------------------
@@ -8709,6 +8724,9 @@ package Sinfo is
    function Specification
      (N : Node_Id) return Node_Id;    -- Node1
 
+   function Split_PPC
+     (N : Node_Id) return Boolean;    -- Flag17
+
    function Statements
      (N : Node_Id) return List_Id;    -- List3
 
@@ -9654,6 +9672,9 @@ package Sinfo is
    procedure Set_Specification
      (N : Node_Id; Val : Node_Id);            -- Node1
 
+   procedure Set_Split_PPC
+     (N : Node_Id; Val : Boolean);            -- Flag17
+
    procedure Set_Statements
      (N : Node_Id; Val : List_Id);            -- List3
 
@@ -11744,6 +11765,7 @@ package Sinfo is
    pragma Inline (Shift_Count_OK);
    pragma Inline (Source_Type);
    pragma Inline (Specification);
+   pragma Inline (Split_PPC);
    pragma Inline (Statements);
    pragma Inline (Static_Processing_OK);
    pragma Inline (Storage_Pool);
@@ -12055,6 +12077,7 @@ package Sinfo is
    pragma Inline (Set_Shift_Count_OK);
    pragma Inline (Set_Source_Type);
    pragma Inline (Set_Specification);
+   pragma Inline (Set_Split_PPC);
    pragma Inline (Set_Statements);
    pragma Inline (Set_Static_Processing_OK);
    pragma Inline (Set_Storage_Pool);

gcc/ada/sinput.adb

@@ -238,6 +238,13 @@ package body Sinput is
       return;
    end Build_Location_String;
 
+   function Build_Location_String (Loc : Source_Ptr) return String is
+   begin
+      Name_Len := 0;
+      Build_Location_String (Loc);
+      return Name_Buffer (1 .. Name_Len);
+   end Build_Location_String;
+
    -----------------------
    -- Get_Column_Number --
    -----------------------

gcc/ada/sinput.ads

@@ -471,6 +471,10 @@ package Sinput is
    --  ASCII.NUL, with Name_Length indicating the length not including the
    --  terminating Nul.
 
+   function Build_Location_String (Loc : Source_Ptr) return String;
+   --  Functional form returning a string, which does not include a terminating
+   --  null character. The contents of Name_Buffer is destroyed.
+
    function Get_Column_Number (P : Source_Ptr) return Column_Number;
    --  The ones-origin column number of the specified Source_Ptr value is
    --  determined and returned. Tab characters if present are assumed to

gcc/ada/usage.adb

@@ -438,6 +438,10 @@ begin
                                                   "elaboration pragma");
    Write_Line ("        L*   turn off warnings for missing " &
                                                   "elaboration pragma");
+   Write_Line ("        .l*  turn on info messages for inherited pre/" &
+                                                  "postconditions");
+   Write_Line ("        .L   turn off info messages for inherited pre/" &
+                                                  "postconditions");
    Write_Line ("        m+   turn on warnings for variable assigned " &
                                                   "but not read");
    Write_Line ("        M*   turn off warnings for variable assigned " &

gcc/ada/xref_lib.adb

@@ -525,6 +525,7 @@ package body Xref_Lib is
          when 'e' => return Param_String & "enumeration object";
          when 'f' => return Param_String & "float object";
          when 'i' => return Param_String & "integer object";
+         when 'j' => return Param_String & "class object";
          when 'm' => return Param_String & "modular object";
          when 'o' => return Param_String & "fixed object";
          when 'p' => return Param_String & "access object";
@@ -537,6 +538,7 @@ package body Xref_Lib is
 
          when 'h' => return "interface";
          when 'g' => return "macro";
+         when 'J' => return "class";
          when 'K' => return "package";
          when 'k' => return "generic package";
          when 'L' => return "statement label";