From 36b59c4c18f2cac5f312f1864f1320e0ddb9b680 Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 6 Jun 2007 10:47:54 +0000 Subject: [PATCH] 2007-04-20 Ed Schonberg Robert Dewar * 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 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125463 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/sprint.adb | 181 ++++++++++++++++++++++++++++++++++++++++++++--------- gcc/ada/sprint.ads | 24 ++++--- 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; -- 2.7.4