sprint.ads, sprint.adb (Sprint_Node_Actual): Output aggregate for exceptions.

2007-04-20  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* sprint.ads, sprint.adb (Sprint_Node_Actual): Output aggregate for
	exceptions.
	(Write_Itype): Handle case of string literal subtype, which
	comes up in this context.
	(Update_Itype): when debugging expanded code, update sloc of itypes
	associated with defining_identifiers and ranges, for gdb use.
	(Sprint_Node_Actual): Add static keyword to object or exception
	declaration output if Is_Statically_Allocated is True.
	(Sprint_End_Label): Set entity of end marker for a subprogram, package,
	or task body, so that the tree carries the proper Sloc information for
	debugging use.
	(Write_Indent): In Dump_Source_Text mode, ignore implicit label nodes

From-SVN: r125463

2 files changed, 164 insertions, 41 deletions

diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 51131e3..23b284b 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -192,6 +192,15 @@ package body Sprint is
    procedure Sprint_Bar_List (List : List_Id);
    --  Print the given list with items separated by vertical bars
 
+   procedure Sprint_End_Label
+     (Node    : Node_Id;
+      Default : Node_Id);
+   --  Print the end label for a Handled_Sequence_Of_Statements in a body.
+   --  If there is not end label, use the defining identifier of the enclosing
+   --  construct. If the end label is present, treat it as a reference to the
+   --  defining entity of the construct: this guarantees that it carries the
+   --  proper sloc information for debugging purposes.
+
    procedure Sprint_Node_Actual (Node : Node_Id);
    --  This routine prints its node argument. It is a lower level routine than
    --  Sprint_Node, in that it does not bother about rewritten trees.
@@ -202,6 +211,12 @@ package body Sprint is
    --  of the sprinted node Node. Note that this is done after printing
    --  Node, so that the Sloc is the proper updated value for the debug file.
 
+   procedure Update_Itype (Node : Node_Id);
+   --  Update the Sloc of an itype that is not attached to the tree, when
+   --  debugging expanded code. This routine is called from nodes whose
+   --  type can be an Itype, such as defining_identifiers that may be of
+   --  an anonymous access type, or ranges in slices.
+
    procedure Write_Char_Sloc (C : Character);
    --  Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
    --  called to ensure that the current node has a proper Sloc set.
@@ -411,12 +426,22 @@ package body Sprint is
    -- pg --
    --------
 
-   procedure pg (Node : Node_Id) is
+   procedure pg (Arg : Union_Id) is
    begin
       Dump_Generated_Only := True;
       Dump_Original_Only := False;
       Current_Source_File := No_Source_File;
-      Sprint_Node (Node);
+
+      if Arg in List_Range then
+         Sprint_Node_List (List_Id (Arg));
+
+      elsif Arg in Node_Range then
+         Sprint_Node (Node_Id (Arg));
+
+      else
+         null;
+      end if;
+
       Write_Eol;
    end pg;
 
@@ -424,12 +449,22 @@ package body Sprint is
    -- po --
    --------
 
-   procedure po (Node : Node_Id) is
+   procedure po (Arg : Union_Id) is
    begin
       Dump_Generated_Only := False;
       Dump_Original_Only := True;
       Current_Source_File := No_Source_File;
-      Sprint_Node (Node);
+
+      if Arg in List_Range then
+         Sprint_Node_List (List_Id (Arg));
+
+      elsif Arg in Node_Range then
+         Sprint_Node (Node_Id (Arg));
+
+      else
+         null;
+      end if;
+
       Write_Eol;
    end po;
 
@@ -461,12 +496,22 @@ package body Sprint is
    -- ps --
    --------
 
-   procedure ps (Node : Node_Id) is
+   procedure ps (Arg : Union_Id) is
    begin
       Dump_Generated_Only := False;
       Dump_Original_Only := False;
       Current_Source_File := No_Source_File;
-      Sprint_Node (Node);
+
+      if Arg in List_Range then
+         Sprint_Node_List (List_Id (Arg));
+
+      elsif Arg in Node_Range then
+         Sprint_Node (Node_Id (Arg));
+
+      else
+         null;
+      end if;
+
       Write_Eol;
    end ps;
 
@@ -617,6 +662,34 @@ package body Sprint is
       end if;
    end Sprint_Bar_List;
 
+   ----------------------
+   -- Sprint_End_Label --
+   ----------------------
+
+   procedure Sprint_End_Label
+     (Node    : Node_Id;
+      Default : Node_Id)
+   is
+   begin
+      if Present (Node)
+        and then Present (End_Label (Node))
+        and then Is_Entity_Name (End_Label (Node))
+      then
+         Set_Entity (End_Label (Node), Default);
+
+         --  For a function whose name is an operator, use the qualified name
+         --  created for the defining entity.
+
+         if Nkind (End_Label (Node)) = N_Operator_Symbol then
+            Set_Chars (End_Label (Node), Chars (Default));
+         end if;
+
+         Sprint_Node (End_Label (Node));
+      else
+         Sprint_Node (Default);
+      end if;
+   end Sprint_End_Label;
+
    -----------------------
    -- Sprint_Comma_List --
    -----------------------
@@ -1400,7 +1473,19 @@ package body Sprint is
          when N_Exception_Declaration =>
             if Write_Indent_Identifiers (Node) then
                Write_Str_With_Col_Check (" : ");
-               Write_Str_Sloc ("exception;");
+
+               if Is_Statically_Allocated (Defining_Identifier (Node)) then
+                  Write_Str_With_Col_Check ("static ");
+               end if;
+
+               Write_Str_Sloc ("exception");
+
+               if Present (Expression (Node)) then
+                  Write_Str (" := ");
+                  Sprint_Node (Expression (Node));
+               end if;
+
+               Write_Char (';');
             end if;
 
          when N_Exception_Handler =>
@@ -1649,7 +1734,7 @@ package body Sprint is
 
          when N_Full_Type_Declaration =>
             Write_Indent_Str_Sloc ("type ");
-            Write_Id (Defining_Identifier (Node));
+            Sprint_Node (Defining_Identifier (Node));
             Write_Discr_Specs (Node);
             Write_Str_With_Col_Check (" is ");
             Sprint_Node (Type_Definition (Node));
@@ -1920,7 +2005,11 @@ package body Sprint is
             Set_Debug_Sloc;
 
             if Write_Indent_Identifiers (Node) then
-               Write_Str (" : ");
+               Write_Str_With_Col_Check (" : ");
+
+               if Is_Statically_Allocated (Defining_Identifier (Node)) then
+                  Write_Str_With_Col_Check ("static ");
+               end if;
 
                if Aliased_Present (Node) then
                   Write_Str_With_Col_Check ("aliased ");
@@ -2133,7 +2222,8 @@ package body Sprint is
             end if;
 
             Write_Indent_Str ("end ");
-            Sprint_Node (Defining_Unit_Name (Node));
+            Sprint_End_Label
+              (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node));
             Write_Char (';');
 
          when N_Package_Body_Stub =>
@@ -2359,7 +2449,7 @@ package body Sprint is
 
          when N_Protected_Type_Declaration =>
             Write_Indent_Str_Sloc ("protected type ");
-            Write_Id (Defining_Identifier (Node));
+            Sprint_Node (Defining_Identifier (Node));
             Write_Discr_Specs (Node);
 
             if Present (Interface_List (Node)) then
@@ -2446,6 +2536,7 @@ package body Sprint is
             Sprint_Node (Low_Bound (Node));
             Write_Str_Sloc (" .. ");
             Sprint_Node (High_Bound (Node));
+            Update_Itype (Node);
 
          when N_Range_Constraint =>
             Write_Str_With_Col_Check_Sloc ("range ");
@@ -2557,12 +2648,11 @@ package body Sprint is
 
          when N_Single_Task_Declaration =>
             Write_Indent_Str_Sloc ("task ");
-            Write_Id (Defining_Identifier (Node));
+            Sprint_Node (Defining_Identifier (Node));
 
             if Present (Task_Definition (Node)) then
                Write_Str (" is");
                Sprint_Node (Task_Definition (Node));
-               Write_Id (Defining_Identifier (Node));
             end if;
 
             Write_Char (';');
@@ -2604,7 +2694,10 @@ package body Sprint is
             Sprint_Node (Handled_Statement_Sequence (Node));
 
             Write_Indent_Str ("end ");
-            Sprint_Node (Defining_Unit_Name (Specification (Node)));
+
+            Sprint_End_Label
+              (Handled_Statement_Sequence (Node),
+                 Defining_Unit_Name (Specification (Node)));
             Write_Char (';');
 
             if Is_List_Member (Node)
@@ -2644,7 +2737,7 @@ package body Sprint is
 
          when N_Subtype_Declaration =>
             Write_Indent_Str_Sloc ("subtype ");
-            Write_Id (Defining_Identifier (Node));
+            Sprint_Node (Defining_Identifier (Node));
             Write_Str (" is ");
 
             --  Ada 2005 (AI-231)
@@ -2676,7 +2769,8 @@ package body Sprint is
             Write_Indent_Str ("begin");
             Sprint_Node (Handled_Statement_Sequence (Node));
             Write_Indent_Str ("end ");
-            Write_Id (Defining_Identifier (Node));
+            Sprint_End_Label
+              (Handled_Statement_Sequence (Node), Defining_Identifier (Node));
             Write_Char (';');
 
          when N_Task_Body_Stub =>
@@ -2694,10 +2788,11 @@ package body Sprint is
             end if;
 
             Write_Indent_Str ("end ");
+            Sprint_End_Label (Node, Defining_Identifier (Parent (Node)));
 
          when N_Task_Type_Declaration =>
             Write_Indent_Str_Sloc ("task type ");
-            Write_Id (Defining_Identifier (Node));
+            Sprint_Node (Defining_Identifier (Node));
             Write_Discr_Specs (Node);
 
             if Present (Interface_List (Node)) then
@@ -2713,7 +2808,6 @@ package body Sprint is
                end if;
 
                Sprint_Node (Task_Definition (Node));
-               Write_Id (Defining_Identifier (Node));
             end if;
 
             Write_Char (';');
@@ -2879,16 +2973,6 @@ package body Sprint is
                end if;
             end if;
 
-         when N_With_Type_Clause =>
-            Write_Indent_Str ("with type ");
-            Sprint_Node_Sloc (Name (Node));
-
-            if Tagged_Present (Node) then
-               Write_Str (" is tagged;");
-            else
-               Write_Str (" is access;");
-            end if;
-
       end case;
 
       if Nkind (Node) in N_Subexpr
@@ -3026,6 +3110,20 @@ package body Sprint is
       end if;
    end Sprint_Right_Opnd;
 
+   ------------------
+   -- Update_Itype --
+   ------------------
+
+   procedure Update_Itype (Node : Node_Id) is
+   begin
+      if Present (Etype (Node))
+        and then Is_Itype (Etype (Node))
+        and then Debug_Generated_Code
+      then
+         Set_Sloc (Etype (Node), Sloc (Node));
+      end if;
+   end Update_Itype;
+
    ---------------------
    -- Write_Char_Sloc --
    ---------------------
@@ -3300,6 +3398,7 @@ package body Sprint is
    function Write_Identifiers (Node : Node_Id) return Boolean is
    begin
       Sprint_Node (Defining_Identifier (Node));
+      Update_Itype (Defining_Identifier (Node));
 
       --  The remainder of the declaration must be printed unless we are
       --  printing the original tree and this is not the last identifier
@@ -3367,7 +3466,14 @@ package body Sprint is
       if Indent_Annull_Flag then
          Indent_Annull_Flag := False;
       else
-         if Dump_Source_Text and then Loc > No_Location then
+         --  Deal with Dump_Source_Text output. Note that we ignore implicit
+         --  label declarations, since they typically have the sloc of the
+         --  corresponding label, which really messes up the -gnatL output.
+
+         if Dump_Source_Text
+           and then Loc > No_Location
+           and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration
+         then
             if Get_Source_File_Index (Loc) = Current_Source_File then
                Write_Source_Lines
                  (Get_Physical_Line_Number (Sloc (Dump_Node)));
@@ -3410,7 +3516,6 @@ package body Sprint is
 
       return
          not Dump_Original_Only or else not More_Ids (Node);
-
    end Write_Indent_Identifiers;
 
    -----------------------------------
@@ -3784,6 +3889,20 @@ package body Sprint is
                         Write_Id (Etype (Typ));
                      end if;
 
+                  when E_String_Literal_Subtype =>
+                     declare
+                        LB  : constant Uint :=
+                                Intval (String_Literal_Low_Bound (Typ));
+                        Len : constant Uint :=
+                                String_Literal_Length (Typ);
+                     begin
+                        Write_Str ("String (");
+                        Write_Int (UI_To_Int (LB));
+                        Write_Str (" .. ");
+                        Write_Int (UI_To_Int (LB + Len) - 1);
+                        Write_Str (");");
+                     end;
+
                   --  For all other Itypes, print ??? (fill in later)
 
                   when others =>
diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads
index 66aeea8..2fc17e2 100644
--- a/gcc/ada/sprint.ads
+++ b/gcc/ada/sprint.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -44,6 +44,8 @@ package Sprint is
    --  purely for the purposes of this printout (they are not recognized by the
    --  parser)
 
+   --  Could use more documentation for all of these ???
+
    --    Allocator                           new xxx [storage_pool = xxx]
    --    Cleanup action                      at end procedure name;
    --    Conditional expression              (if expr then expr else expr)
@@ -75,6 +77,7 @@ package Sprint is
    --    Rem wi Treat_Fixed_As_Integer       x #rem y
    --    Reference                           expression'reference
    --    Shift nodes                         shift_name!(expr, count)
+   --    Static declaration                  name : static xxx
    --    Subprogram_Info                     subprog'Subprogram_Info
    --    Unchecked conversion                target_type!(source_expression)
    --    Unchecked expression                `(expression)
@@ -136,19 +139,20 @@ package Sprint is
    --  Same as normal Sprint_Node procedure, except that one leading
    --  blank is output before the node if it is non-empty.
 
-   procedure pg (Node : Node_Id);
+   procedure pg (Arg : Union_Id);
    pragma Export (Ada, pg);
-   --  Print generated source for node N (like -gnatdg output). This is
-   --  intended only for use from gdb for debugging purposes.
+   --  Print generated source for argument N (like -gnatdg output). Intended
+   --  only for use from gdb for debugging purposes. Currently, Arg may be a
+   --  List_Id or a Node_Id (anything else outputs a blank line).
 
-   procedure po (Node : Node_Id);
+   procedure po (Arg : Union_Id);
    pragma Export (Ada, po);
-   --  Print original source for node N (like -gnatdo output). This is
-   --  intended only for use from gdb for debugging purposes.
+   --  Like pg, but prints original source for the argument (like -gnatdo
+   --  output). Intended only for use from gdb for debugging purposes.
 
-   procedure ps (Node : Node_Id);
+   procedure ps (Arg : Union_Id);
    pragma Export (Ada, ps);
-   --  Print generated and original source for node N (like -gnatds output).
-   --  This is intended only for use from gdb for debugging purposes.
+   --  Like pg, but prints generated and original source for the argument (like
+   --  -gnatds output). Intended only for use from gdb for debugging purposes.
 
 end Sprint;