From d3e16619ae38fba5a464064046114a6638d1816f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 30 Jul 2014 15:53:11 +0200 Subject: [PATCH] [multiple changes] 2014-07-30 Vincent Celier * debug.adb: Minor comment update. 2014-07-30 Robert Dewar * 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 * a-tags.ads: Complete comments about performance. 2014-07-30 Fedor Rybin * 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 * 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 --- gcc/ada/ChangeLog | 29 ++++++++++++++ gcc/ada/Makefile.rtl | 1 - gcc/ada/a-tags.ads | 4 +- gcc/ada/debug.adb | 4 +- gcc/ada/exp_prag.adb | 33 +++++++--------- gcc/ada/freeze.adb | 44 +++++++++++++++++++--- gcc/ada/gnat_rm.texi | 17 +-------- gcc/ada/gnat_ugn.texi | 8 +++- gcc/ada/i-cpp.adb | 35 ----------------- gcc/ada/i-cpp.ads | 50 ------------------------ gcc/ada/impunit.adb | 1 - gcc/ada/rtsfind.ads | 6 +-- gcc/ada/s-tassta.adb | 8 ++-- gcc/ada/s-tasuti.adb | 6 +-- gcc/ada/sem_prag.adb | 6 +-- gcc/ada/sprint.adb | 88 +++++++++++++++++++++++++++++++++++++++++-- 16 files changed, 190 insertions(+), 150 deletions(-) delete mode 100644 gcc/ada/i-cpp.adb delete mode 100644 gcc/ada/i-cpp.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 073f8c05b76..81d1faa3ffc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2014-07-30 Vincent Celier + + * debug.adb: Minor comment update. + +2014-07-30 Robert Dewar + + * 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 + + * a-tags.ads: Complete comments about performance. + +2014-07-30 Fedor Rybin + + * 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 + + * 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 * s-taasde.adb (Timer_Queue): Don't use a diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index fdac70c2297..a959d3c8e57 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 9239c998585..a9141d2d970 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 b96ce833c8b..a93af0f6a30 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 fef09c4d12d..696d0635065 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 d6acef9163a..f44cfb16aae 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 36444ec0102..18673029661 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 3ed4f15ee2d..0c08f0e936e 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 f7a48608877..00000000000 --- 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 -- --- . -- --- -- --- 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 27db1c2b1fd..00000000000 --- 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 -- --- . -- --- -- --- 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 7b5c0fbaf51..69356cbfb34 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 72bbd025db8..bb57b1c0f8b 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 a2ff687e63a..77fb65b250f 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 40446fc1e65..1a6444838a7 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 fee781caac4..122d47ce312 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 55669c7f3b5..3eb4869f8f8 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 : ). + + -- 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 ");