-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Casing; use Casing;
+with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Lib; use Lib;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
+with Sinput.D; use Sinput.D;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
Dump_Generated_Only : Boolean;
-- Set True if the -gnatG (dump generated tree) debug flag is set
- -- or for Print_Generated_Code (-gnatG) or Dump_Gnerated_Code (-gnatD).
+ -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD).
Dump_Freeze_Null : Boolean;
-- Set True if freeze nodes and non-source null statements output
-- Keep track of freeze indent level (controls blank lines before
-- procedures within expression freeze actions)
+ -------------------------------
+ -- Operator Precedence Table --
+ -------------------------------
+
+ -- This table is used to decide whether a subexpression needs to be
+ -- parenthesized. The rule is that if an operand of an operator (which
+ -- for this purpose includes AND THEN and OR ELSE) is itself an operator
+ -- with a lower precedence than the operator (or equal precedence if
+ -- appearing as the right operand), then parentheses are required.
+
+ Op_Prec : constant array (N_Subexpr) of Short_Short_Integer :=
+ (N_Op_And => 1,
+ N_Op_Or => 1,
+ N_Op_Xor => 1,
+ N_And_Then => 1,
+ N_Or_Else => 1,
+
+ N_In => 2,
+ N_Not_In => 2,
+ N_Op_Eq => 2,
+ N_Op_Ge => 2,
+ N_Op_Gt => 2,
+ N_Op_Le => 2,
+ N_Op_Lt => 2,
+ N_Op_Ne => 2,
+
+ N_Op_Add => 3,
+ N_Op_Concat => 3,
+ N_Op_Subtract => 3,
+ N_Op_Plus => 3,
+ N_Op_Minus => 3,
+
+ N_Op_Divide => 4,
+ N_Op_Mod => 4,
+ N_Op_Rem => 4,
+ N_Op_Multiply => 4,
+
+ N_Op_Expon => 5,
+ N_Op_Abs => 5,
+ N_Op_Not => 5,
+
+ others => 6);
+
+ procedure Sprint_Left_Opnd (N : Node_Id);
+ -- Print left operand of operator, parenthesizing if necessary
+
+ procedure Sprint_Right_Opnd (N : Node_Id);
+ -- Print right operand of operator, parenthesizing if necessary
+
-----------------------
-- Local Subprograms --
-----------------------
procedure Indent_End;
-- Decrease indentation level
- procedure Print_Eol;
- -- Terminate current line in line buffer
+ procedure Print_Debug_Line (S : String);
+ -- Used to print output lines in Debug_Generated_Code mode (this is used
+ -- as the argument for a call to Set_Special_Output in package Output).
procedure Process_TFAI_RR_Flags (Nod : Node_Id);
-- Given a divide, multiplication or division node, check the flags
-- that is currently being written. Note that Debug_Node is always empty
-- if a debug source file is not being written.
+ procedure Sprint_And_List (List : List_Id);
+ -- Print the given list with items separated by vertical "and"
+
procedure Sprint_Bar_List (List : List_Id);
-- Print the given list with items separated by vertical bars
-- 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.
+ procedure Write_Condition_And_Reason (Node : Node_Id);
+ -- Write Condition and Reason codes of Raise_xxx_Error node
+
procedure Write_Discr_Specs (N : Node_Id);
- -- Output discriminant specification for node, which is any of the type
+ -- Ouput discriminant specification for node, which is any of the type
-- declarations that can have discriminants.
procedure Write_Ekind (E : Entity_Id);
end Indent_End;
--------
- -- PG --
+ -- pg --
--------
- procedure PG (Node : Node_Id) is
+ procedure pg (Node : Node_Id) is
begin
Dump_Generated_Only := True;
Dump_Original_Only := False;
Sprint_Node (Node);
- Print_Eol;
- end PG;
+ Write_Eol;
+ end pg;
--------
- -- PO --
+ -- po --
--------
- procedure PO (Node : Node_Id) is
+ procedure po (Node : Node_Id) is
begin
Dump_Generated_Only := False;
Dump_Original_Only := True;
Sprint_Node (Node);
- Print_Eol;
- end PO;
+ Write_Eol;
+ end po;
- ---------------
- -- Print_Eol --
- ---------------
+ ----------------------
+ -- Print_Debug_Line --
+ ----------------------
- procedure Print_Eol is
+ procedure Print_Debug_Line (S : String) is
begin
- -- If we are writing a debug source file, then grab it from the
- -- Output buffer, and reset the column counter (the routines in
- -- Output never actually write any output for us in this mode,
- -- they just build line images in Buffer).
-
- if Debug_Generated_Code then
- Write_Debug_Line (Buffer (1 .. Natural (Column) - 1), Debug_Sloc);
- Column := 1;
-
- -- In normal mode, we call Write_Eol to write the line normally
-
- else
- Write_Eol;
- end if;
- end Print_Eol;
+ Write_Debug_Line (S, Debug_Sloc);
+ end Print_Debug_Line;
---------------------------
-- Process_TFAI_RR_Flags --
end Process_TFAI_RR_Flags;
--------
- -- PS --
+ -- ps --
--------
- procedure PS (Node : Node_Id) is
+ procedure ps (Node : Node_Id) is
begin
Dump_Generated_Only := False;
Dump_Original_Only := False;
Sprint_Node (Node);
- Print_Eol;
- end PS;
+ Write_Eol;
+ end ps;
--------------------
-- Set_Debug_Sloc --
Col : constant Int := Column;
begin
- Print_Eol;
+ Write_Eol;
while Col > Column loop
Write_Char ('-');
end loop;
- Print_Eol;
+ Write_Eol;
end Underline;
-- Start of processing for Tree_Dump.
if Debug_Flag_Z then
Debug_Flag_Z := False;
- Print_Eol;
- Print_Eol;
+ Write_Eol;
+ Write_Eol;
Write_Str ("Source recreated from tree of Standard (spec)");
Underline;
Sprint_Node (Standard_Package_Node);
- Print_Eol;
- Print_Eol;
+ Write_Eol;
+ Write_Eol;
end if;
if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then
-- If we are generating debug files, setup to write them
if Debug_Generated_Code then
+ Set_Special_Output (Print_Debug_Line'Access);
Create_Debug_Source (Source_Index (U), Debug_Sloc);
Sprint_Node (Cunit (U));
- Print_Eol;
+ Write_Eol;
Close_Debug_Source;
+ Set_Special_Output (null);
-- Normal output to standard output file
end Source_Dump;
---------------------
+ -- Sprint_And_List --
+ ---------------------
+
+ procedure Sprint_And_List (List : List_Id) is
+ Node : Node_Id;
+ begin
+ if Is_Non_Empty_List (List) then
+ Node := First (List);
+ loop
+ Sprint_Node (Node);
+ Next (Node);
+ exit when Node = Empty;
+ Write_Str (" and ");
+ end loop;
+ end if;
+ end Sprint_And_List;
+
+ ---------------------
-- Sprint_Bar_List --
---------------------
procedure Sprint_Bar_List (List : List_Id) is
Node : Node_Id;
-
begin
if Is_Non_Empty_List (List) then
Node := First (List);
-
loop
Sprint_Node (Node);
Next (Node);
begin
if Is_Non_Empty_List (List) then
Node := First (List);
-
loop
Sprint_Node (Node);
Next (Node);
then
Write_Str (", ");
end if;
-
end loop;
end if;
end Sprint_Comma_List;
Indent_End;
end Sprint_Indented_List;
+ ---------------------
+ -- Sprint_Left_Opnd --
+ ---------------------
+
+ procedure Sprint_Left_Opnd (N : Node_Id) is
+ Opnd : constant Node_Id := Left_Opnd (N);
+
+ begin
+ if Paren_Count (Opnd) /= 0
+ or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N))
+ then
+ Sprint_Node (Opnd);
+
+ else
+ Write_Char ('(');
+ Sprint_Node (Opnd);
+ Write_Char (')');
+ end if;
+ end Sprint_Left_Opnd;
+
-----------------
-- Sprint_Node --
-----------------
Write_Char (';');
when N_Access_Definition =>
- Write_Str_With_Col_Check_Sloc ("access ");
- Sprint_Node (Subtype_Mark (Node));
+
+ -- Ada 2005 (AI-254)
+
+ if Present (Access_To_Subprogram_Definition (Node)) then
+ Sprint_Node (Access_To_Subprogram_Definition (Node));
+ else
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
+ Write_Str_With_Col_Check_Sloc ("access ");
+
+ if All_Present (Node) then
+ Write_Str ("all ");
+ elsif Constant_Present (Node) then
+ Write_Str ("constant ");
+ end if;
+
+ Sprint_Node (Subtype_Mark (Node));
+ end if;
when N_Access_Function_Definition =>
+
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
Write_Str_With_Col_Check_Sloc ("access ");
if Protected_Present (Node) then
Write_Str_With_Col_Check ("function");
Write_Param_Specs (Node);
Write_Str_With_Col_Check (" return ");
- Sprint_Node (Subtype_Mark (Node));
+ Sprint_Node (Result_Definition (Node));
when N_Access_Procedure_Definition =>
+
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
Write_Str_With_Col_Check_Sloc ("access ");
if Protected_Present (Node) then
Write_Str_With_Col_Check ("constant ");
end if;
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
Sprint_Node (Subtype_Indication (Node));
when N_Aggregate =>
when N_Allocator =>
Write_Str_With_Col_Check_Sloc ("new ");
+
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
Sprint_Node (Expression (Node));
if Present (Storage_Pool (Node)) then
end if;
when N_And_Then =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" and then ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_At_Clause =>
Write_Indent_Str_Sloc ("for ");
end if;
Write_Char_Sloc (''');
- Write_Char_Code (Char_Literal_Value (Node));
+ Write_Char_Code (UI_To_CC (Char_Literal_Value (Node)));
Write_Char (''');
when N_Code_Statement =>
Set_Debug_Sloc;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
- Sprint_Node (Expression (Node));
+
+ -- Ada 2005 (AI-287): Print the mbox if present
+
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check ("<>");
+ else
+ Sprint_Node (Expression (Node));
+ end if;
when N_Component_Clause =>
Write_Indent;
Sprint_Node (Last_Bit (Node));
Write_Char (';');
- when N_Component_Declaration =>
- if Write_Indent_Identifiers_Sloc (Node) then
- Write_Str (" : ");
+ when N_Component_Definition =>
+ Set_Debug_Sloc;
+
+ -- Ada 2005 (AI-230): Access definition components
+ if Present (Access_Definition (Node)) then
+ Sprint_Node (Access_Definition (Node));
+
+ elsif Present (Subtype_Indication (Node)) then
if Aliased_Present (Node) then
Write_Str_With_Col_Check ("aliased ");
end if;
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str (" not null ");
+ end if;
+
Sprint_Node (Subtype_Indication (Node));
+ else
+ Write_Str (" ??? ");
+ end if;
+
+ when N_Component_Declaration =>
+ if Write_Indent_Identifiers_Sloc (Node) then
+ Write_Str (" : ");
+ Sprint_Node (Component_Definition (Node));
+
if Present (Expression (Node)) then
Write_Str (" := ");
Sprint_Node (Expression (Node));
Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node));
Write_Str (" of ");
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
-
- Sprint_Node (Subtype_Indication (Node));
+ Sprint_Node (Component_Definition (Node));
when N_Decimal_Fixed_Point_Definition =>
Write_Str_With_Col_Check_Sloc (" delta ");
end if;
Write_Str_With_Col_Check_Sloc ("new ");
+
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str_With_Col_Check ("not null ");
+ end if;
+
Sprint_Node (Subtype_Indication (Node));
- if Present (Record_Extension_Part (Node)) then
+ if Present (Interface_List (Node)) then
+ Sprint_And_List (Interface_List (Node));
Write_Str_With_Col_Check (" with ");
+ end if;
+
+ if Present (Record_Extension_Part (Node)) then
+ if No (Interface_List (Node)) then
+ Write_Str_With_Col_Check (" with ");
+ end if;
+
Sprint_Node (Record_Extension_Part (Node));
end if;
if Write_Identifiers (Node) then
Write_Str (" : ");
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
Sprint_Node (Discriminant_Type (Node));
if Present (Expression (Node)) then
Write_Char (';');
+ when N_Expanded_Name =>
+ Sprint_Node (Prefix (Node));
+ Write_Char_Sloc ('.');
+ Sprint_Node (Selector_Name (Node));
+
when N_Explicit_Dereference =>
Sprint_Node (Prefix (Node));
- Write_Char ('.');
+ Write_Char_Sloc ('.');
Write_Str_Sloc ("all");
when N_Extension_Aggregate =>
Write_Str_With_Col_Check (" with private");
end if;
+ when N_Formal_Abstract_Subprogram_Declaration =>
+ Write_Indent_Str_Sloc ("with ");
+ Sprint_Node (Specification (Node));
+
+ Write_Str_With_Col_Check (" is abstract");
+
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check (" <>");
+ elsif Present (Default_Name (Node)) then
+ Write_Str_With_Col_Check (" ");
+ Sprint_Node (Default_Name (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Formal_Concrete_Subprogram_Declaration =>
+ Write_Indent_Str_Sloc ("with ");
+ Sprint_Node (Specification (Node));
+
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check (" is <>");
+ elsif Present (Default_Name (Node)) then
+ Write_Str_With_Col_Check (" is ");
+ Sprint_Node (Default_Name (Node));
+ end if;
+
+ Write_Char (';');
+
when N_Formal_Discrete_Type_Definition =>
Write_Str_With_Col_Check_Sloc ("<>");
when N_Formal_Signed_Integer_Type_Definition =>
Write_Str_With_Col_Check_Sloc ("range <>");
- when N_Formal_Subprogram_Declaration =>
- Write_Indent_Str_Sloc ("with ");
- Sprint_Node (Specification (Node));
-
- if Box_Present (Node) then
- Write_Str_With_Col_Check (" is <>");
- elsif Present (Default_Name (Node)) then
- Write_Str_With_Col_Check (" is ");
- Sprint_Node (Default_Name (Node));
- end if;
-
- Write_Char (';');
-
when N_Formal_Type_Declaration =>
Write_Indent_Str_Sloc ("type ");
Write_Id (Defining_Identifier (Node));
Sprint_Node (Defining_Unit_Name (Node));
Write_Param_Specs (Node);
Write_Str_With_Col_Check (" return ");
- Sprint_Node (Subtype_Mark (Node));
+
+ -- Ada 2005 (AI-231)
+
+ if Nkind (Result_Definition (Node)) /= N_Access_Definition
+ and then Null_Exclusion_Present (Node)
+ then
+ Write_Str (" not null ");
+ end if;
+
+ Sprint_Node (Result_Definition (Node));
when N_Generic_Association =>
Set_Debug_Sloc;
end if;
when N_In =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" in ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Incomplete_Type_Declaration =>
Write_Indent_Str_Sloc ("type ");
Sprint_Node (Expression (Node));
when N_Not_In =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" not in ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Null =>
Write_Str_With_Col_Check_Sloc ("null");
end if;
when N_Object_Declaration =>
+ Set_Debug_Sloc;
- -- Put extra blank line before and after if this is a handler
- -- record or a subprogram descriptor.
-
- declare
- Typ : constant Entity_Id := Etype (Defining_Identifier (Node));
- Exc : constant Boolean :=
- Is_RTE (Typ, RE_Handler_Record)
- or else
- Is_RTE (Typ, RE_Subprogram_Descriptor);
+ if Write_Indent_Identifiers (Node) then
+ Write_Str (" : ");
- begin
- if Exc then
- Write_Indent;
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
end if;
- Set_Debug_Sloc;
-
- if Write_Indent_Identifiers (Node) then
- Write_Str (" : ");
-
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
+ if Constant_Present (Node) then
+ Write_Str_With_Col_Check ("constant ");
+ end if;
- if Constant_Present (Node) then
- Write_Str_With_Col_Check ("constant ");
- end if;
+ -- Ada 2005 (AI-231)
- Sprint_Node (Object_Definition (Node));
+ if Null_Exclusion_Present (Node) then
+ Write_Str_With_Col_Check ("not null ");
+ end if;
- if Present (Expression (Node)) then
- Write_Str (" := ");
- Sprint_Node (Expression (Node));
- end if;
+ Sprint_Node (Object_Definition (Node));
- Write_Char (';');
+ if Present (Expression (Node)) then
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
end if;
- if Exc then
- Write_Indent;
- end if;
- end;
+ Write_Char (';');
+ end if;
when N_Object_Renaming_Declaration =>
Write_Indent;
Set_Debug_Sloc;
Sprint_Node (Defining_Identifier (Node));
Write_Str (" : ");
- Sprint_Node (Subtype_Mark (Node));
+
+ -- Ada 2005 (AI-230): Access renamings
+
+ if Present (Access_Definition (Node)) then
+ Sprint_Node (Access_Definition (Node));
+
+ elsif Present (Subtype_Mark (Node)) then
+ Sprint_Node (Subtype_Mark (Node));
+
+ else
+ Write_Str (" ??? ");
+ end if;
+
Write_Str_With_Col_Check (" renames ");
Sprint_Node (Name (Node));
Write_Char (';');
when N_Op_Abs =>
Write_Operator (Node, "abs ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Add =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " + ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_And =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " and ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Concat =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " & ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Divide =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Char (' ');
Process_TFAI_RR_Flags (Node);
Write_Operator (Node, "/ ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Eq =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " = ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Expon =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " ** ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Ge =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " >= ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Gt =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " > ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Le =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " <= ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Lt =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " < ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Minus =>
Write_Operator (Node, "-");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Mod =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
if Treat_Fixed_As_Integer (Node) then
Write_Str (" #");
end if;
Write_Operator (Node, " mod ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Multiply =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Char (' ');
Process_TFAI_RR_Flags (Node);
Write_Operator (Node, "* ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Ne =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " /= ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Not =>
Write_Operator (Node, "not ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Or =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " or ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Plus =>
Write_Operator (Node, "+");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Rem =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
if Treat_Fixed_As_Integer (Node) then
Write_Str (" #");
end if;
Write_Operator (Node, " rem ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Shift =>
Set_Debug_Sloc;
Write_Char (')');
when N_Op_Subtract =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " - ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Xor =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " xor ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Operator_Symbol =>
Write_Name_With_Col_Check_Sloc (Chars (Node));
Sprint_Opt_Node (Real_Range_Specification (Node));
when N_Or_Else =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" or else ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Others_Choice =>
if All_Others (Node) then
Write_Str_With_Col_Check ("out ");
end if;
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
Sprint_Node (Parameter_Type (Node));
if Present (Expression (Node)) then
Write_Indent_Str_Sloc ("protected type ");
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
- Write_Str (" is");
+
+ if Present (Interface_List (Node)) then
+ Write_Str (" is new ");
+ Sprint_And_List (Interface_List (Node));
+ Write_Str (" with ");
+ else
+ Write_Str (" is");
+ end if;
+
Sprint_Node (Protected_Definition (Node));
Write_Id (Defining_Identifier (Node));
Write_Char (';');
when N_Qualified_Expression =>
Sprint_Node (Subtype_Mark (Node));
Write_Char_Sloc (''');
- Sprint_Node (Expression (Node));
+
+ -- Print expression, make sure we have at least one level of
+ -- parentheses around the expression. For cases of qualified
+ -- expressions in the source, this is always the case, but
+ -- for generated qualifications, there may be no explicit
+ -- parentheses present.
+
+ if Paren_Count (Expression (Node)) /= 0 then
+ Sprint_Node (Expression (Node));
+ else
+ Write_Char ('(');
+ Sprint_Node (Expression (Node));
+ Write_Char (')');
+ end if;
when N_Raise_Constraint_Error =>
end if;
Write_Str_With_Col_Check_Sloc ("[constraint_error");
-
- if Present (Condition (Node)) then
- Write_Str_With_Col_Check (" when ");
- Sprint_Node (Condition (Node));
- end if;
-
- Write_Char (']');
+ Write_Condition_And_Reason (Node);
when N_Raise_Program_Error =>
- Write_Indent;
- Write_Str_With_Col_Check_Sloc ("[program_error");
- if Present (Condition (Node)) then
- Write_Str_With_Col_Check (" when ");
- Sprint_Node (Condition (Node));
+ -- This node can be used either as a subexpression or as a
+ -- statement form. The following test is a reasonably reliable
+ -- way to distinguish the two cases.
+
+ if Is_List_Member (Node)
+ and then Nkind (Parent (Node)) not in N_Subexpr
+ then
+ Write_Indent;
end if;
- Write_Char (']');
+ Write_Str_With_Col_Check_Sloc ("[program_error");
+ Write_Condition_And_Reason (Node);
when N_Raise_Storage_Error =>
- Write_Indent;
- Write_Str_With_Col_Check_Sloc ("[storage_error");
- if Present (Condition (Node)) then
- Write_Str_With_Col_Check (" when ");
- Sprint_Node (Condition (Node));
+ -- This node can be used either as a subexpression or as a
+ -- statement form. The following test is a reasonably reliable
+ -- way to distinguish the two cases.
+
+ if Is_List_Member (Node)
+ and then Nkind (Parent (Node)) not in N_Subexpr
+ then
+ Write_Indent;
end if;
- Write_Char (']');
+ Write_Str_With_Col_Check_Sloc ("[storage_error");
+ Write_Condition_And_Reason (Node);
when N_Raise_Statement =>
Write_Indent_Str_Sloc ("raise ");
Write_Char (';');
- when N_Selected_Component | N_Expanded_Name =>
+ when N_Selected_Component =>
Sprint_Node (Prefix (Node));
Write_Char_Sloc ('.');
Sprint_Node (Selector_Name (Node));
when N_Subprogram_Declaration =>
Write_Indent;
Sprint_Node_Sloc (Specification (Node));
+
+ if Nkind (Specification (Node)) = N_Procedure_Specification
+ and then Null_Present (Specification (Node))
+ then
+ Write_Str_With_Col_Check (" is null");
+ end if;
+
Write_Char (';');
when N_Subprogram_Info =>
Write_Indent_Str_Sloc ("subtype ");
Write_Id (Defining_Identifier (Node));
Write_Str (" is ");
+
+ -- Ada 2005 (AI-231)
+
+ if Null_Exclusion_Present (Node) then
+ Write_Str ("not null ");
+ end if;
+
Sprint_Node (Subtype_Indication (Node));
Write_Char (';');
Write_Indent_Str_Sloc ("separate (");
Sprint_Node (Name (Node));
Write_Char (')');
- Print_Eol;
+ Write_Eol;
Sprint_Node (Proper_Body (Node));
when N_Task_Body =>
Write_Indent_Str_Sloc ("task type ");
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
+
+ if Present (Interface_List (Node)) then
+ Write_Str (" is new ");
+ Sprint_And_List (Interface_List (Node));
+ end if;
+
if Present (Task_Definition (Node)) then
- Write_Str (" is");
+ if No (Interface_List (Node)) then
+ Write_Str (" is");
+ else
+ Write_Str (" with ");
+ end if;
+
Sprint_Node (Task_Definition (Node));
Write_Id (Defining_Identifier (Node));
end if;
end;
Write_Str (") of ");
-
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
-
- Sprint_Node (Subtype_Indication (Node));
+ Sprint_Node (Component_Definition (Node));
when N_Unused_At_Start | N_Unused_At_End =>
Write_Indent_Str ("***** Error, unused node encountered *****");
- Print_Eol;
+ Write_Eol;
when N_Use_Package_Clause =>
Write_Indent_Str_Sloc ("use ");
else
if First_Name (Node) or else not Dump_Original_Only then
- Write_Indent_Str ("with ");
+
+ -- Ada 2005 (AI-50217): Print limited with_clauses
+
+ if Private_Present (Node) and Limited_Present (Node) then
+ Write_Indent_Str ("limited private with ");
+
+ elsif Private_Present (Node) then
+ Write_Indent_Str ("private with ");
+
+ elsif Limited_Present (Node) then
+ Write_Indent_Str ("limited with ");
+
+ else
+ Write_Indent_Str ("with ");
+ end if;
+
else
Write_Str (", ");
end if;
end if;
when N_With_Type_Clause =>
-
Write_Indent_Str ("with type ");
Sprint_Node_Sloc (Name (Node));
end if;
end Sprint_Paren_Comma_List;
+ ----------------------
+ -- Sprint_Right_Opnd --
+ ----------------------
+
+ procedure Sprint_Right_Opnd (N : Node_Id) is
+ Opnd : constant Node_Id := Right_Opnd (N);
+
+ begin
+ if Paren_Count (Opnd) /= 0
+ or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N))
+ then
+ Sprint_Node (Opnd);
+
+ else
+ Write_Char ('(');
+ Sprint_Node (Opnd);
+ Write_Char (')');
+ end if;
+ end Sprint_Right_Opnd;
+
---------------------
-- Write_Char_Sloc --
---------------------
Write_Char (C);
end Write_Char_Sloc;
- ------------------------
- -- Write_Discr_Specs --
- ------------------------
+ --------------------------------
+ -- Write_Condition_And_Reason --
+ --------------------------------
+
+ procedure Write_Condition_And_Reason (Node : Node_Id) is
+ Image : constant String := RT_Exception_Code'Image
+ (RT_Exception_Code'Val
+ (UI_To_Int (Reason (Node))));
+
+ begin
+ if Present (Condition (Node)) then
+ Write_Str_With_Col_Check (" when ");
+ Sprint_Node (Condition (Node));
+ end if;
+
+ Write_Str (" """);
+
+ for J in 4 .. Image'Last loop
+ if Image (J) = '_' then
+ Write_Char (' ');
+ else
+ Write_Char (Fold_Lower (Image (J)));
+ end if;
+ end loop;
+
+ Write_Str ("""]");
+ end Write_Condition_And_Reason;
+
+ -----------------------
+ -- Write_Discr_Specs --
+ -----------------------
procedure Write_Discr_Specs (N : Node_Id) is
- Specs : List_Id;
- Spec : Node_Id;
+ Specs : List_Id;
+ Spec : Node_Id;
begin
Specs := Discriminant_Specifications (N);
then
Write_Id (Entity (Parent (N)));
- -- For any other kind of node with an associated entity, output it.
+ -- For any other node with an associated entity, output it
elsif Nkind (N) in N_Has_Entity
- and then Present (Entity (N))
+ and then Present (Entity_Or_Associated_Node (N))
+ and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity
then
Write_Id (Entity (N));
if Indent_Annull_Flag then
Indent_Annull_Flag := False;
else
- Print_Eol;
+ Write_Eol;
+
for J in 1 .. Indent loop
Write_Char (' ');
end loop;
T : Natural := S'Last;
begin
- if S (F) = ' ' then
- Write_Char (' ');
- F := F + 1;
- end if;
+ -- If no overflow check, just write string out, and we are done
- if S (T) = ' ' then
- T := T - 1;
- end if;
+ if not Do_Overflow_Check (N) then
+ Write_Str_Sloc (S);
+
+ -- If overflow check, we want to surround the operator with curly
+ -- brackets, but not include spaces within the brackets.
+
+ else
+ if S (F) = ' ' then
+ Write_Char (' ');
+ F := F + 1;
+ end if;
+
+ if S (T) = ' ' then
+ T := T - 1;
+ end if;
- if Do_Overflow_Check (N) then
Write_Char ('{');
Write_Str_Sloc (S (F .. T));
Write_Char ('}');
- else
- Write_Str_Sloc (S);
- end if;
- if S (S'Last) = ' ' then
- Write_Char (' ');
+ if S (S'Last) = ' ' then
+ Write_Char (' ');
+ end if;
end if;
end Write_Operator;
OSDN Git Service
