[multiple changes]

2014-07-30  Vincent Celier  <celier@adacore.com>

	* debug.adb: Minor comment update.

2014-07-30  Robert Dewar  <dewar@adacore.com>

	* s-tasuti.adb, s-tassta.adb: Minor reformatting.
	* sprint.adb (Sprint_Node): Handle N_Contract case.
	* exp_prag.adb: Minor reformatting.
	* freeze.adb (Freeze_Entity): Check useless postcondition for
	No_Return subprogram.
	* sem_prag.adb: Minor reformatting.

2014-07-30  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads: Complete comments about performance.

2014-07-30  Fedor Rybin  <frybin@adacore.com>

	* gnat_ugn.texi: Adding description for --exit-status option to
	gnattest section.  Fixing index entry of --passed-tests option
	in gnattest section.

2014-07-30  Javier Miranda  <miranda@adacore.com>

	* Makefile.rtl, gnat_rm.texi, i-cpp.adb, i-cpp.ads, impunit.adb,
	rtsfind.ads: Remove references to package Interfaces.CPP since this
	package is no longer needed.

From-SVN: r213270

16 files changed, 190 insertions, 150 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 073f8c0..81d1faa 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,32 @@
+2014-07-30  Vincent Celier  <celier@adacore.com>
+
+	* debug.adb: Minor comment update.
+
+2014-07-30  Robert Dewar  <dewar@adacore.com>
+
+	* s-tasuti.adb, s-tassta.adb: Minor reformatting.
+	* sprint.adb (Sprint_Node): Handle N_Contract case.
+	* exp_prag.adb: Minor reformatting.
+	* freeze.adb (Freeze_Entity): Check useless postcondition for
+	No_Return subprogram.
+	* sem_prag.adb: Minor reformatting.
+
+2014-07-30  Javier Miranda  <miranda@adacore.com>
+
+	* a-tags.ads: Complete comments about performance.
+
+2014-07-30  Fedor Rybin  <frybin@adacore.com>
+
+	* gnat_ugn.texi: Adding description for --exit-status option to
+	gnattest section.  Fixing index entry of --passed-tests option
+	in gnattest section.
+
+2014-07-30  Javier Miranda  <miranda@adacore.com>
+
+	* Makefile.rtl, gnat_rm.texi, i-cpp.adb, i-cpp.ads, impunit.adb,
+	rtsfind.ads: Remove references to package Interfaces.CPP since this
+	package is no longer needed.
+
 2014-07-30  Bob Duff  <duff@adacore.com>
 
 	* s-taasde.adb (Timer_Queue): Don't use a
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index fdac70c..a959d3c 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -470,7 +470,6 @@ GNATRTL_NONTASKING_OBJS= \
   i-cexten$(objext) \
   i-cobol$(objext) \
   i-cpoint$(objext) \
-  i-cpp$(objext) \
   i-cstrea$(objext) \
   i-cstrin$(objext) \
   i-fortra$(objext) \
diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads
index 9239c99..a9141d2 100644
--- a/gcc/ada/a-tags.ads
+++ b/gcc/ada/a-tags.ads
@@ -44,7 +44,7 @@
 --  time (in terms of source lines executed):
 
 --    Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag,
---    Is_Descendant_At_Same_Level, Parent_Tag
+--    Is_Descendant_At_Same_Level, Parent_Tag, Type_Is_Abstract
 --    Descendant_Tag (when used with a library-level tagged type),
 --    Internal_Tag (when used with a library-level tagged type).
 
@@ -53,7 +53,7 @@
 
 --    Descendant_Tag (when used with a locally defined tagged type)
 --    Internal_Tag (when used with a locally defined tagged type)
---    Interface_Ancestor_Tagswith System
+--    Interface_Ancestor_Tags
 
 with System.Storage_Elements;
 
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index b96ce833..a93af0f 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -814,7 +814,9 @@ package body Debug is
    -- Documentation for gprbuild Debug Flags  --
    ---------------------------------------------
 
-   --  dn  Do not delete temporary files createed by gprbuild at the end
+   --  dm  Display the maximum number of simultaneous compilations.
+
+   --  dn  Do not delete temporary files created by gprbuild at the end
    --      of execution, such as temporary config pragma files, mapping
    --      files or project path files.
 
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index fef09c4..696d063 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -990,8 +990,8 @@ package body Exp_Prag is
 
       --  Case where we generate a direct raise
 
-      if ((Debug_Flag_Dot_G or else
-                              Restriction_Active (No_Exception_Propagation))
+      if ((Debug_Flag_Dot_G
+             or else Restriction_Active (No_Exception_Propagation))
            and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
         or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
       then
@@ -1073,12 +1073,10 @@ package body Exp_Prag is
 
          Rewrite (N,
            Make_If_Statement (Loc,
-             Condition =>
-               Make_Op_Not (Loc,
-                 Right_Opnd => Cond),
+             Condition       => Make_Op_Not (Loc, Right_Opnd => Cond),
              Then_Statements => New_List (
                Make_Procedure_Call_Statement (Loc,
-                 Name =>
+                 Name                   =>
                    New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
                  Parameter_Associations => New_List (Relocate_Node (Msg))))));
       end if;
@@ -1146,15 +1144,13 @@ package body Exp_Prag is
          Set_All_Upper_Case;
 
          Psect :=
-           Make_String_Literal (Eloc,
-             Strval => String_From_Name_Buffer);
+           Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
 
       else
          Get_Name_String (Chars (Internal));
          Set_All_Upper_Case;
          Psect :=
-           Make_String_Literal (Iloc,
-             Strval => String_From_Name_Buffer);
+           Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
       end if;
 
       Ploc := Sloc (Psect);
@@ -1173,7 +1169,6 @@ package body Exp_Prag is
                    Strval => "common_object")),
              Make_Pragma_Argument_Association (Ploc,
                Expression => New_Copy_Tree (Psect)))));
-
    end Expand_Pragma_Common_Object;
 
    ---------------------------------------
@@ -1298,17 +1293,17 @@ package body Exp_Prag is
    -- Expand_Pragma_Import_Export_Exception --
    -------------------------------------------
 
-   --  For a VMS exception fix up the language field with "VMS"
-   --  instead of "Ada" (gigi needs this), create a constant that will be the
-   --  value of the VMS condition code and stuff the Interface_Name field
-   --  with the unexpanded name of the exception (if not already set).
-   --  For a Ada exception, just stuff the Interface_Name field
-   --  with the unexpanded name of the exception (if not already set).
+   --  For a VMS exception fix up the language field with "VMS" instead of
+   --  "Ada" (gigi needs this), create a constant that will be the value of
+   --  the VMS condition code and stuff the Interface_Name field with the
+   --  unexpanded name of the exception (if not already set). For a Ada
+   --  exception, just stuff the Interface_Name field with the unexpanded
+   --  name of the exception (if not already set).
 
    procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
    begin
-      --  This pragma is only effective on OpenVMS systems, it was ignored
-      --  on non-VMS systems, and we need to ignore it here as well.
+      --  This pragma is only effective on OpenVMS systems, it was ignored on
+      --  non-VMS systems, and we need to ignore it here as well.
 
       if not OpenVMS_On_Target then
          return;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index d6acef9..f44cfb1 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -3145,10 +3145,8 @@ package body Freeze is
 
          if Present (ADC) and then Base_Type (Rec) = Rec then
             if not (Placed_Component
-                      or else
-                    Present (SSO_ADC)
-                      or else
-                    Is_Packed (Rec))
+                     or else Present (SSO_ADC)
+                     or else Is_Packed (Rec))
             then
                --  Warn if clause has no effect when no component clause is
                --  present, but suppress warning if the Bit_Order is required
@@ -3296,8 +3294,7 @@ package body Freeze is
             while Present (Comp) loop
                if Present (Component_Clause (Comp))
                  and then (Is_Fixed_Point_Type (Etype (Comp))
-                             or else
-                           Is_Bit_Packed_Array (Etype (Comp)))
+                            or else Is_Bit_Packed_Array (Etype (Comp)))
                then
                   Check_Size
                     (Component_Name (Component_Clause (Comp)),
@@ -4185,6 +4182,41 @@ package body Freeze is
                Freeze_Subprogram (E);
             end if;
 
+            --  If warning on suspicious contracts then check for the case of
+            --  a postcondition other than False for a No_Return subprogram.
+
+            if No_Return (E)
+              and then Warn_On_Suspicious_Contract
+              and then Present (Contract (E))
+            then
+               declare
+                  Prag : Node_Id := Pre_Post_Conditions (Contract (E));
+                  Exp  : Node_Id;
+
+               begin
+                  while Present (Prag) loop
+                     if Nam_In (Pragma_Name (Prag), Name_Post,
+                                                    Name_Postcondition,
+                                                    Name_Refined_Post)
+                     then
+                        Exp :=
+                          Expression
+                            (First (Pragma_Argument_Associations (Prag)));
+
+                        if Nkind (Exp) /= N_Identifier
+                          or else Chars (Exp) /= Name_False
+                        then
+                           Error_Msg_NE
+                             ("useless postcondition, & is marked "
+                              & "No_Return?T?", Exp, E);
+                        end if;
+                     end if;
+
+                     Prag := Next_Pragma (Prag);
+                  end loop;
+               end;
+            end if;
+
          --  Here for other than a subprogram or type
 
          else
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 36444ec..1867302 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -650,7 +650,6 @@ The GNAT Library
 * GNAT.Wide_Wide_String_Split (g-zistsp.ads)::
 * Interfaces.C.Extensions (i-cexten.ads)::
 * Interfaces.C.Streams (i-cstrea.ads)::
-* Interfaces.CPP (i-cpp.ads)::
 * Interfaces.Packed_Decimal (i-pacdec.ads)::
 * Interfaces.VxWorks (i-vxwork.ads)::
 * Interfaces.VxWorks.IO (i-vxwoio.ads)::
@@ -12138,9 +12137,7 @@ convention.  Any declarations useful for interfacing to any language on
 the given hardware architecture should be provided directly in
 @code{Interfaces}.
 @end cartouche
-Followed. An additional package not defined
-in the Ada Reference Manual is @code{Interfaces.CPP}, used
-for interfacing to C++.
+Followed.
 
 @sp 1
 @cartouche
@@ -19015,7 +19012,6 @@ of GNAT, and will generate a warning message.
 * GNAT.Wide_Wide_String_Split (g-zistsp.ads)::
 * Interfaces.C.Extensions (i-cexten.ads)::
 * Interfaces.C.Streams (i-cstrea.ads)::
-* Interfaces.CPP (i-cpp.ads)::
 * Interfaces.Packed_Decimal (i-pacdec.ads)::
 * Interfaces.VxWorks (i-vxwork.ads)::
 * Interfaces.VxWorks.IO (i-vxwoio.ads)::
@@ -20463,17 +20459,6 @@ to C libraries.
 This package is a binding for the most commonly used operations
 on C streams.
 
-@node Interfaces.CPP (i-cpp.ads)
-@section @code{Interfaces.CPP} (@file{i-cpp.ads})
-@cindex @code{Interfaces.CPP} (@file{i-cpp.ads})
-@cindex  C++ interfacing
-@cindex  Interfacing, to C++
-
-@noindent
-This package provides facilities for use in interfacing to C++.  It
-is primarily intended to be used in connection with automated tools
-for the generation of C++ interfaces.
-
 @node Interfaces.Packed_Decimal (i-pacdec.ads)
 @section @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads})
 @cindex @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads})
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 3ed4f15..0c08f0e 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -19872,10 +19872,16 @@ Specifies the default behavior of generated skeletons. @var{val} can be either
 "fail" or "pass", "fail" being the default.
 
 @item --passed-tests=@var{val}
-@cindex @option{--skeleton-default} (@command{gnattest})
+@cindex @option{--passed-tests} (@command{gnattest})
 Specifies whether or not passed tests should be shown. @var{val} can be either
 "show" or "hide", "show" being the default.
 
+@item --exit-status=@var{val}
+@cindex @option{--exit-status} (@command{gnattest})
+Specifies whether or not generated test driver should return failure exit
+status if at least one test fails or crashes. @var{val} can be either
+"on" or "off", "off" being the default.
+
 
 @item --tests-root=@var{dirname}
 @cindex @option{--tests-root} (@command{gnattest})
diff --git a/gcc/ada/i-cpp.adb b/gcc/ada/i-cpp.adb
deleted file mode 100644
index f7a4860..0000000
--- a/gcc/ada/i-cpp.adb
+++ /dev/null
@@ -1,35 +0,0 @@
-------------------------------------------------------------------------------
---                                                                          --
---                         GNAT RUN-TIME COMPONENTS                         --
---                                                                          --
---                       I N T E R F A C E S . C P P                        --
---                                                                          --
---                                 B o d y                                  --
---                                                                          --
---          Copyright (C) 1992-2009, 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- --
--- ware  Foundation;  either version 3,  or (at your option) any later ver- --
--- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
---                                                                          --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception,   --
--- version 3.1, as published by the Free Software Foundation.               --
---                                                                          --
--- You should have received a copy of the GNU General Public License and    --
--- a copy of the GCC Runtime Library Exception along with this program;     --
--- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
--- <http://www.gnu.org/licenses/>.                                          --
---                                                                          --
--- GNAT was originally developed  by the GNAT team at  New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc.      --
---                                                                          --
-------------------------------------------------------------------------------
-
---  Dummy body to deal with bootstrap issues (there used to be a real body)
-
-package body Interfaces.CPP is
-end Interfaces.CPP;
diff --git a/gcc/ada/i-cpp.ads b/gcc/ada/i-cpp.ads
deleted file mode 100644
index 27db1c2..0000000
--- a/gcc/ada/i-cpp.ads
+++ /dev/null
@@ -1,50 +0,0 @@
-------------------------------------------------------------------------------
---                                                                          --
---                         GNAT RUN-TIME COMPONENTS                         --
---                                                                          --
---                       I N T E R F A C E S . C P P                        --
---                                                                          --
---                                 S p e c                                  --
---                                                                          --
---          Copyright (C) 1992-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- --
--- ware  Foundation;  either version 3,  or (at your option) any later ver- --
--- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
---                                                                          --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception,   --
--- version 3.1, as published by the Free Software Foundation.               --
---                                                                          --
--- You should have received a copy of the GNU General Public License and    --
--- a copy of the GCC Runtime Library Exception along with this program;     --
--- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
--- <http://www.gnu.org/licenses/>.                                          --
---                                                                          --
--- GNAT was originally developed  by the GNAT team at  New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc.      --
---                                                                          --
-------------------------------------------------------------------------------
-
---  Missing package comment ???
-
-with Ada.Tags;
-
-package Interfaces.CPP is
-   pragma Elaborate_Body;
-   --  We have a dummy body to deal with bootstrap path issues
-
-   subtype Vtable_Ptr is Ada.Tags.Tag;
-
-   --  These need commenting (this is not an RM package) ???
-
-   function Expanded_Name (T : Vtable_Ptr) return String
-     renames Ada.Tags.Expanded_Name;
-
-   function External_Tag (T : Vtable_Ptr) return String
-     renames Ada.Tags.External_Tag;
-
-end Interfaces.CPP;
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 7b5c0fb..69356cb 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -345,7 +345,6 @@ package body Impunit is
     ("i-cexten", F),  -- Interfaces.C.Extensions
     ("i-cil   ", F),  -- Interfaces.CIL
     ("i-cilobj", F),  -- Interfaces.CIL.Object
-    ("i-cpp   ", F),  -- Interfaces.CPP
     ("i-cstrea", F),  -- Interfaces.C.Streams
     ("i-java  ", F),  -- Interfaces.Java
     ("i-javjni", F),  -- Interfaces.Java.JNI
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 72bbd02..bb57b1c 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -71,7 +71,8 @@ package Rtsfind is
    --    of Ada.Wide_Wide_Text_IO.
 
    --    Names of the form Interfaces_xxx are first level children of
-   --    Interfaces_CPP refers to package Interfaces.CPP
+   --    Interfaces. For example, the name Interfaces_Packed_Decimal refers to
+   --    package Interfaces.Packed_Decimal.
 
    --    Names of the form System_xxx are first level children of System, whose
    --    name is System.xxx. For example, the name System_Str_Concat refers to
@@ -202,7 +203,6 @@ package Rtsfind is
 
       --  Children of Interfaces
 
-      Interfaces_CPP,
       Interfaces_Packed_Decimal,
 
       --  Package System
@@ -466,7 +466,7 @@ package Rtsfind is
            Ada_Wide_Wide_Text_IO_Modular_IO;
 
    subtype Interfaces_Child is RTU_Id
-     range Interfaces_CPP .. Interfaces_Packed_Decimal;
+     range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal;
    --  Range of values for children of Interfaces
 
    subtype System_Child is RTU_Id
diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb
index a2ff687..77fb65b 100644
--- a/gcc/ada/s-tassta.adb
+++ b/gcc/ada/s-tassta.adb
@@ -545,8 +545,8 @@ package body System.Tasking.Stages is
 
       else
          --  When the application code says nothing about the task affinity
-         --  (task without CPU aspect) then the compiler inserts the
-         --  Unspecified_CPU value which indicates to the run-time library that
+         --  (task without CPU aspect) then the compiler inserts the value
+         --  Unspecified_CPU which indicates to the run-time library that
          --  the task will activate and execute on the same processor as its
          --  activating task if the activating task is assigned a processor
          --  (RM D.16(14/3)).
@@ -557,8 +557,8 @@ package body System.Tasking.Stages is
             else System.Multiprocessors.CPU_Range (CPU));
       end if;
 
-      --  Find parent P of new Task, via master level number. Independent tasks
-      --  should have Parent = Environment_Task, and all tasks created
+      --  Find parent P of new Task, via master level number. Independent
+      --  tasks should have Parent = Environment_Task, and all tasks created
       --  by independent tasks are also independent. See, for example,
       --  s-interr.adb, where Interrupt_Manager does "new Server_Task". The
       --  access type is at library level, so the parent of the Server_Task
diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb
index 40446fc..1a64448 100644
--- a/gcc/ada/s-tasuti.adb
+++ b/gcc/ada/s-tasuti.adb
@@ -477,8 +477,7 @@ package body System.Tasking.Utilities is
             (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M'));
 
          --  If parent is in Master_Completion_Sleep, it cannot be on a
-         --  terminate alternative, hence it cannot have Wait_Count of
-         --  zero.
+         --  terminate alternative, hence it cannot have Wait_Count of zero.
 
          pragma Assert (P.Common.Wait_Count > 0);
          P.Common.Wait_Count := P.Common.Wait_Count - 1;
@@ -489,8 +488,7 @@ package body System.Tasking.Utilities is
 
       else
          pragma Debug
-           (Debug.Trace
-             (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
+           (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
          null;
       end if;
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index fee781c..122d47c 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -5258,9 +5258,7 @@ package body Sem_Prag is
             --  The copy is needed because the pragma is expanded into other
             --  constructs which are not acceptable in the N_Contract node.
 
-            if Acts_As_Spec (PO)
-              and then GNATprove_Mode
-            then
+            if Acts_As_Spec (PO) and then GNATprove_Mode then
                declare
                   Prag : constant Node_Id := New_Copy_Tree (N);
 
@@ -5269,7 +5267,7 @@ package body Sem_Prag is
 
                   Preanalyze_Assert_Expression
                     (Get_Pragma_Arg
-                      (First (Pragma_Argument_Associations (Prag))),
+                       (First (Pragma_Argument_Associations (Prag))),
                      Standard_Boolean);
 
                   --  Preanalyze the corresponding aspect (if any)
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 55669c7..3eb4869 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -58,6 +58,10 @@ package body Sprint is
    --  requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
    --  value. The call clears it back to Empty.
 
+   First_Debug_Sloc : Source_Ptr;
+   --  Sloc of first byte of the current output file if we are generating a
+   --  source debug file.
+
    Debug_Sloc : Source_Ptr;
    --  Sloc of first byte of line currently being written if we are
    --  generating a source debug file.
@@ -512,7 +516,38 @@ package body Sprint is
    procedure Set_Debug_Sloc is
    begin
       if Debug_Generated_Code and then Present (Dump_Node) then
-         Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
+         declare
+            Loc : constant Source_Ptr := Sloc (Dump_Node);
+
+         begin
+            --  Do not change the location of nodes defined in package Standard
+            --  and nodes of pragmas scanned by Targparm.
+
+            if Loc <= Standard_Location then
+               null;
+
+            --  Update the location of a node which is part of the current .dg
+            --  output. This situation occurs in comma separated parameter
+            --  declarations since each parameter references the same parameter
+            --  type node (ie. obj1, obj2 : <param-type>).
+
+            --  Note: This case is needed here since we cannot use the routine
+            --  In_Extended_Main_Code_Unit with nodes whose location is a .dg
+            --  file.
+
+            elsif Loc >= First_Debug_Sloc then
+               Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
+
+            --  Do not change the location of nodes which are not part of the
+            --  generated code
+
+            elsif not In_Extended_Main_Code_Unit (Loc) then
+               null;
+
+            else
+               Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
+            end if;
+         end;
 
          --  We do not know the actual end location in the generated code and
          --  it could be much closer than in the source code, so play safe.
@@ -581,6 +616,7 @@ package body Sprint is
          Debug_Flag_G := False;
          Debug_Flag_O := False;
          Debug_Flag_S := False;
+         First_Debug_Sloc := No_Location;
 
          --  Dump requested units
 
@@ -598,6 +634,7 @@ package body Sprint is
                if Debug_Generated_Code then
                   Set_Special_Output (Print_Debug_Line'Access);
                   Create_Debug_Source (Source_Index (U), Debug_Sloc);
+                  First_Debug_Sloc := Debug_Sloc;
                   Write_Source_Line (1);
                   Last_Line_Printed := 1;
                   Sprint_Node (Cunit (U));
@@ -1358,10 +1395,55 @@ package body Sprint is
             Sprint_Node (Component_Definition (Node));
 
          --  A contract node should not appear in the tree. It is a semantic
-         --  node attached to entry and [generic] subprogram entities.
+         --  node attached to entry and [generic] subprogram entities. But we
+         --  still provide meaningful output, in case called from the debugger.
 
          when N_Contract =>
-            raise Program_Error;
+            declare
+               P : Node_Id;
+
+            begin
+               Indent_Begin;
+               Write_Str ("N_Contract node");
+               Write_Eol;
+
+               Write_Indent_Str ("Pre_Post_Conditions");
+               Indent_Begin;
+
+               P := Pre_Post_Conditions (Node);
+               while Present (P) loop
+                  Sprint_Node (P);
+                  P := Next_Pragma (P);
+               end loop;
+
+               Write_Eol;
+               Indent_End;
+
+               Write_Indent_Str ("Contract_Test_Cases");
+               Indent_Begin;
+
+               P := Contract_Test_Cases (Node);
+               while Present (P) loop
+                  Sprint_Node (P);
+                  P := Next_Pragma (P);
+               end loop;
+
+               Write_Eol;
+               Indent_End;
+
+               Write_Indent_Str ("Classifications");
+               Indent_Begin;
+
+               P := Classifications (Node);
+               while Present (P) loop
+                  Sprint_Node (P);
+                  P := Next_Pragma (P);
+               end loop;
+
+               Write_Eol;
+               Indent_End;
+               Indent_End;
+            end;
 
          when N_Decimal_Fixed_Point_Definition =>
             Write_Str_With_Col_Check_Sloc (" delta ");