-- --
-- 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- --
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.
-- 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.
-- 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;
-- 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;
-- 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;
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 --
-----------------------
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 =>
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));
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 ");
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 =>
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
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 ");
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 (';');
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)
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)
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 =>
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
end if;
Sprint_Node (Task_Definition (Node));
- Write_Id (Defining_Identifier (Node));
end if;
Write_Char (';');
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
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 --
---------------------
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
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)));
return
not Dump_Original_Only or else not More_Ids (Node);
-
end Write_Indent_Identifiers;
-----------------------------------
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 =>
-- --
-- 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- --
-- 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)
-- 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)
-- 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;
projects / platform / upstream / linaro-gcc.git / commitdiff