diff options
| author | Dan Albert <danalbert@google.com> | 2015-06-17 11:09:54 -0700 |
|---|---|---|
| committer | Dan Albert <danalbert@google.com> | 2015-06-17 14:15:22 -0700 |
| commit | f378ebf14df0952eae870c9865bab8326aa8f137 (patch) | |
| tree | 31794503eb2a8c64ea5f313b93100f1163afcffb /gcc-4.2.1/gcc/ada/sprint.adb | |
| parent | 2c58169824949d3a597d9fa81931e001ef9b1bd0 (diff) | |
| download | toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.tar.gz toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.tar.bz2 toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.zip | |
Delete old versions of GCC.
Change-Id: I710f125d905290e1024cbd67f48299861790c66c
Diffstat (limited to 'gcc-4.2.1/gcc/ada/sprint.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/sprint.adb | 3764 |
1 files changed, 0 insertions, 3764 deletions
diff --git a/gcc-4.2.1/gcc/ada/sprint.adb b/gcc-4.2.1/gcc/ada/sprint.adb deleted file mode 100644 index 761c7cf04..000000000 --- a/gcc-4.2.1/gcc/ada/sprint.adb +++ /dev/null @@ -1,3764 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S P R I N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2006, 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 2, 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. 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- 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 Fname; use Fname; -with Lib; use Lib; -with Namet; use Namet; -with Nlists; use Nlists; -with Opt; use Opt; -with Output; use Output; -with Rtsfind; use Rtsfind; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Sinput.D; use Sinput.D; -with Snames; use Snames; -with Stand; use Stand; -with Stringt; use Stringt; -with Uintp; use Uintp; -with Uname; use Uname; -with Urealp; use Urealp; - -package body Sprint is - - Debug_Node : Node_Id := Empty; - -- If we are in Debug_Generated_Code mode, then this location is set - -- to the current node requiring Sloc fixup, until Set_Debug_Sloc is - -- called to set the proper value. The call clears it back to Empty. - - Debug_Sloc : Source_Ptr; - -- Sloc of first byte of line currently being written if we are - -- generating a source debug file. - - Dump_Original_Only : Boolean; - -- Set True if the -gnatdo (dump original tree) flag is set - - Dump_Generated_Only : Boolean; - -- Set True if the -gnatG (dump generated tree) debug flag is set - -- 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 - - Indent : Int := 0; - -- Number of columns for current line output indentation - - Indent_Annull_Flag : Boolean := False; - -- Set True if subsequent Write_Indent call to be ignored, gets reset - -- by this call, so it is only active to suppress a single indent call. - - Line_Limit : constant := 72; - -- Limit value for chopping long lines - - Freeze_Indent : Int := 0; - -- 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 Col_Check (N : Nat); - -- Check that at least N characters remain on current line, and if not, - -- then start an extra line with two characters extra indentation for - -- continuing text on the next line. - - procedure Indent_Annull; - -- Causes following call to Write_Indent to be ignored. This is used when - -- a higher level node wants to stop a lower level node from starting a - -- new line, when it would otherwise be inclined to do so (e.g. the case - -- of an accept statement called from an accept alternative with a guard) - - procedure Indent_Begin; - -- Increase indentation level - - procedure Indent_End; - -- Decrease indentation level - - procedure Note_Implicit_Run_Time_Call (N : Node_Id); - -- N is the Name field of a function call or procedure statement call. - -- The effect of the call is to output a $ if the call is identified as - -- an implicit call to a run time routine. - - 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 - -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the - -- appropriate special syntax characters (# and @). - - procedure Set_Debug_Sloc; - -- If Debug_Node is non-empty, this routine sets the appropriate value - -- in its Sloc field, from the current location in the debug source file - -- 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 - - 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. - - procedure Sprint_Node_Sloc (Node : Node_Id); - -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode, - -- sets the Sloc of the current debug node to be a copy of the Sloc - -- 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 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. - - 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); - -- Ouput discriminant specification for node, which is any of the type - -- declarations that can have discriminants. - - procedure Write_Ekind (E : Entity_Id); - -- Write the String corresponding to the Ekind without "E_" - - procedure Write_Id (N : Node_Id); - -- N is a node with a Chars field. This procedure writes the name that - -- will be used in the generated code associated with the name. For a - -- node with no associated entity, this is simply the Chars field. For - -- the case where there is an entity associated with the node, we print - -- the name associated with the entity (since it may have been encoded). - -- One other special case is that an entity has an active external name - -- (i.e. an external name present with no address clause), then this - -- external name is output. This procedure also deals with outputting - -- declarations of referenced itypes, if not output earlier. - - function Write_Identifiers (Node : Node_Id) return Boolean; - -- Handle node where the grammar has a list of defining identifiers, but - -- the tree has a separate declaration for each identifier. Handles the - -- printing of the defining identifier, and returns True if the type and - -- initialization information is to be printed, False if it is to be - -- skipped (the latter case happens when printing defining identifiers - -- other than the first in the original tree output case). - - procedure Write_Implicit_Def (E : Entity_Id); - pragma Warnings (Off, Write_Implicit_Def); - -- Write the definition of the implicit type E according to its Ekind - -- For now a debugging procedure, but might be used in the future. - - procedure Write_Indent; - -- Start a new line and write indentation spacing - - function Write_Indent_Identifiers (Node : Node_Id) return Boolean; - -- Like Write_Identifiers except that each new printed declaration - -- is at the start of a new line. - - function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean; - -- Like Write_Indent_Identifiers except that in Debug_Generated_Code - -- mode, the Sloc of the current debug node is set to point ot the - -- first output identifier. - - procedure Write_Indent_Str (S : String); - -- Start a new line and write indent spacing followed by given string - - procedure Write_Indent_Str_Sloc (S : String); - -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode, - -- the Sloc of the current node is set to the first non-blank character - -- in the string S. - - procedure Write_Itype (Typ : Entity_Id); - -- If Typ is an Itype that has not been written yet, write it. If Typ is - -- any other kind of entity or tree node, the call is ignored. - - procedure Write_Name_With_Col_Check (N : Name_Id); - -- Write name (using Write_Name) with initial column check, and possible - -- initial Write_Indent (to get new line) if current line is too full. - - procedure Write_Name_With_Col_Check_Sloc (N : Name_Id); - -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code - -- mode, sets Sloc of current debug node to first character of name. - - procedure Write_Operator (N : Node_Id; S : String); - -- Like Write_Str_Sloc, used for operators, encloses the string in - -- characters {} if the Do_Overflow flag is set on the node N. - - procedure Write_Param_Specs (N : Node_Id); - -- Output parameter specifications for node (which is either a function - -- or procedure specification with a Parameter_Specifications field) - - procedure Write_Rewrite_Str (S : String); - -- Writes out a string (typically containing <<< or >>>}) for a node - -- created by rewriting the tree. Suppressed if we are outputting the - -- generated code only, since in this case we don't specially mark nodes - -- created by rewriting). - - procedure Write_Str_Sloc (S : String); - -- Like Write_Str, but sets debug Sloc of current debug node to first - -- non-blank character if a current debug node is active. - - procedure Write_Str_With_Col_Check (S : String); - -- Write string (using Write_Str) with initial column check, and possible - -- initial Write_Indent (to get new line) if current line is too full. - - procedure Write_Str_With_Col_Check_Sloc (S : String); - -- Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug - -- node to first non-blank character if a current debug node is active. - - procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format); - -- Write Uint (using UI_Write) with initial column check, and possible - -- initial Write_Indent (to get new line) if current line is too full. - -- The format parameter determines the output format (see UI_Write). - - procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format); - -- Write Uint (using UI_Write) with initial column check, and possible - -- initial Write_Indent (to get new line) if current line is too full. - -- The format parameter determines the output format (see UI_Write). - -- In addition, in Debug_Generated_Code mode, sets the current node - -- Sloc to the first character of the output value. - - procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal); - -- Write Ureal (using same output format as UR_Write) with column checks - -- and a possible initial Write_Indent (to get new line) if current line - -- is too full. In addition, in Debug_Generated_Code mode, sets the - -- current node Sloc to the first character of the output value. - - --------------- - -- Col_Check -- - --------------- - - procedure Col_Check (N : Nat) is - begin - if N + Column > Line_Limit then - Write_Indent_Str (" "); - end if; - end Col_Check; - - ------------------- - -- Indent_Annull -- - ------------------- - - procedure Indent_Annull is - begin - Indent_Annull_Flag := True; - end Indent_Annull; - - ------------------ - -- Indent_Begin -- - ------------------ - - procedure Indent_Begin is - begin - Indent := Indent + 3; - end Indent_Begin; - - ---------------- - -- Indent_End -- - ---------------- - - procedure Indent_End is - begin - Indent := Indent - 3; - end Indent_End; - - --------------------------------- - -- Note_Implicit_Run_Time_Call -- - --------------------------------- - - procedure Note_Implicit_Run_Time_Call (N : Node_Id) is - begin - if not Comes_From_Source (N) - and then Is_Entity_Name (N) - then - declare - Ent : constant Entity_Id := Entity (N); - begin - if not In_Extended_Main_Source_Unit (Ent) - and then - Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Ent))) - then - Col_Check (Length_Of_Name (Chars (Ent))); - Write_Char ('$'); - end if; - end; - end if; - end Note_Implicit_Run_Time_Call; - - -------- - -- pg -- - -------- - - procedure pg (Node : Node_Id) is - begin - Dump_Generated_Only := True; - Dump_Original_Only := False; - Sprint_Node (Node); - Write_Eol; - end pg; - - -------- - -- po -- - -------- - - procedure po (Node : Node_Id) is - begin - Dump_Generated_Only := False; - Dump_Original_Only := True; - Sprint_Node (Node); - Write_Eol; - end po; - - ---------------------- - -- Print_Debug_Line -- - ---------------------- - - procedure Print_Debug_Line (S : String) is - begin - Write_Debug_Line (S, Debug_Sloc); - end Print_Debug_Line; - - --------------------------- - -- Process_TFAI_RR_Flags -- - --------------------------- - - procedure Process_TFAI_RR_Flags (Nod : Node_Id) is - begin - if Treat_Fixed_As_Integer (Nod) then - Write_Char ('#'); - end if; - - if Rounded_Result (Nod) then - Write_Char ('@'); - end if; - end Process_TFAI_RR_Flags; - - -------- - -- ps -- - -------- - - procedure ps (Node : Node_Id) is - begin - Dump_Generated_Only := False; - Dump_Original_Only := False; - Sprint_Node (Node); - Write_Eol; - end ps; - - -------------------- - -- Set_Debug_Sloc -- - -------------------- - - procedure Set_Debug_Sloc is - begin - if Present (Debug_Node) then - Set_Sloc (Debug_Node, Debug_Sloc + Source_Ptr (Column - 1)); - Debug_Node := Empty; - end if; - end Set_Debug_Sloc; - - ----------------- - -- Source_Dump -- - ----------------- - - procedure Source_Dump is - - procedure Underline; - -- Put underline under string we just printed - - procedure Underline is - Col : constant Int := Column; - - begin - Write_Eol; - - while Col > Column loop - Write_Char ('-'); - end loop; - - Write_Eol; - end Underline; - - -- Start of processing for Tree_Dump - - begin - Dump_Generated_Only := Debug_Flag_G or - Print_Generated_Code or - Debug_Generated_Code; - Dump_Original_Only := Debug_Flag_O; - Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G; - - -- Note that we turn off the tree dump flags immediately, before - -- starting the dump. This avoids generating two copies of the dump - -- if an abort occurs after printing the dump, and more importantly, - -- avoids an infinite loop if an abort occurs during the dump. - - if Debug_Flag_Z then - Debug_Flag_Z := False; - Write_Eol; - Write_Eol; - Write_Str ("Source recreated from tree of Standard (spec)"); - Underline; - Sprint_Node (Standard_Package_Node); - Write_Eol; - Write_Eol; - end if; - - if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then - Debug_Flag_G := False; - Debug_Flag_O := False; - Debug_Flag_S := False; - - -- Dump requested units - - for U in Main_Unit .. Last_Unit loop - - -- Dump all units if -gnatdf set, otherwise we dump only - -- the source files that are in the extended main source. - - if Debug_Flag_F - or else In_Extended_Main_Source_Unit (Cunit_Entity (U)) - 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)); - Write_Eol; - Close_Debug_Source; - Set_Special_Output (null); - - -- Normal output to standard output file - - else - Write_Str ("Source recreated from tree for "); - Write_Unit_Name (Unit_Name (U)); - Underline; - Sprint_Node (Cunit (U)); - Write_Eol; - Write_Eol; - end if; - end if; - end loop; - end if; - 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); - exit when Node = Empty; - Write_Str (" | "); - end loop; - end if; - end Sprint_Bar_List; - - ----------------------- - -- Sprint_Comma_List -- - ----------------------- - - procedure Sprint_Comma_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; - - if not Is_Rewrite_Insertion (Node) - or else not Dump_Original_Only - then - Write_Str (", "); - end if; - end loop; - end if; - end Sprint_Comma_List; - - -------------------------- - -- Sprint_Indented_List -- - -------------------------- - - procedure Sprint_Indented_List (List : List_Id) is - begin - Indent_Begin; - Sprint_Node_List (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 -- - ----------------- - - procedure Sprint_Node (Node : Node_Id) is - begin - if Is_Rewrite_Insertion (Node) then - if not Dump_Original_Only then - - -- For special cases of nodes that always output <<< >>> - -- do not duplicate the output at this point. - - if Nkind (Node) = N_Freeze_Entity - or else Nkind (Node) = N_Implicit_Label_Declaration - then - Sprint_Node_Actual (Node); - - -- Normal case where <<< >>> may be required - - else - Write_Rewrite_Str ("<<<"); - Sprint_Node_Actual (Node); - Write_Rewrite_Str (">>>"); - end if; - end if; - - elsif Is_Rewrite_Substitution (Node) then - - -- Case of dump generated only - - if Dump_Generated_Only then - Sprint_Node_Actual (Node); - - -- Case of dump original only - - elsif Dump_Original_Only then - Sprint_Node_Actual (Original_Node (Node)); - - -- Case of both being dumped - - else - Sprint_Node_Actual (Original_Node (Node)); - Write_Rewrite_Str ("<<<"); - Sprint_Node_Actual (Node); - Write_Rewrite_Str (">>>"); - end if; - - else - Sprint_Node_Actual (Node); - end if; - end Sprint_Node; - - ------------------------ - -- Sprint_Node_Actual -- - ------------------------ - - procedure Sprint_Node_Actual (Node : Node_Id) is - Save_Debug_Node : constant Node_Id := Debug_Node; - - begin - if Node = Empty then - return; - end if; - - for J in 1 .. Paren_Count (Node) loop - Write_Str_With_Col_Check ("("); - end loop; - - -- Setup node for Sloc fixup if writing a debug source file. Note - -- that we take care of any previous node not yet properly set. - - if Debug_Generated_Code then - Debug_Node := Node; - end if; - - if Nkind (Node) in N_Subexpr - and then Do_Range_Check (Node) - then - Write_Str_With_Col_Check ("{"); - end if; - - -- Select print circuit based on node kind - - case Nkind (Node) is - - when N_Abort_Statement => - Write_Indent_Str_Sloc ("abort "); - Sprint_Comma_List (Names (Node)); - Write_Char (';'); - - when N_Abortable_Part => - Set_Debug_Sloc; - Write_Str_Sloc ("abort "); - Sprint_Indented_List (Statements (Node)); - - when N_Abstract_Subprogram_Declaration => - Write_Indent; - Sprint_Node (Specification (Node)); - Write_Str_With_Col_Check (" is "); - Write_Str_Sloc ("abstract;"); - - when N_Accept_Alternative => - Sprint_Node_List (Pragmas_Before (Node)); - - if Present (Condition (Node)) then - Write_Indent_Str ("when "); - Sprint_Node (Condition (Node)); - Write_Str (" => "); - Indent_Annull; - end if; - - Sprint_Node_Sloc (Accept_Statement (Node)); - Sprint_Node_List (Statements (Node)); - - when N_Accept_Statement => - Write_Indent_Str_Sloc ("accept "); - Write_Id (Entry_Direct_Name (Node)); - - if Present (Entry_Index (Node)) then - Write_Str_With_Col_Check (" ("); - Sprint_Node (Entry_Index (Node)); - Write_Char (')'); - end if; - - Write_Param_Specs (Node); - - if Present (Handled_Statement_Sequence (Node)) then - Write_Str_With_Col_Check (" do"); - Sprint_Node (Handled_Statement_Sequence (Node)); - Write_Indent_Str ("end "); - Write_Id (Entry_Direct_Name (Node)); - end if; - - Write_Char (';'); - - when N_Access_Definition => - - -- 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 ("protected "); - end if; - - Write_Str_With_Col_Check ("function"); - Write_Param_Specs (Node); - Write_Str_With_Col_Check (" return "); - 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 ("protected "); - end if; - - Write_Str_With_Col_Check ("procedure"); - Write_Param_Specs (Node); - - when N_Access_To_Object_Definition => - Write_Str_With_Col_Check_Sloc ("access "); - - if All_Present (Node) then - Write_Str_With_Col_Check ("all "); - elsif Constant_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 => - if Null_Record_Present (Node) then - Write_Str_With_Col_Check_Sloc ("(null record)"); - - else - Write_Str_With_Col_Check_Sloc ("("); - - if Present (Expressions (Node)) then - Sprint_Comma_List (Expressions (Node)); - - if Present (Component_Associations (Node)) then - Write_Str (", "); - end if; - end if; - - if Present (Component_Associations (Node)) then - Indent_Begin; - - declare - Nd : Node_Id; - - begin - Nd := First (Component_Associations (Node)); - - loop - Write_Indent; - Sprint_Node (Nd); - Next (Nd); - exit when No (Nd); - - if not Is_Rewrite_Insertion (Nd) - or else not Dump_Original_Only - then - Write_Str (", "); - end if; - end loop; - end; - - Indent_End; - end if; - - Write_Char (')'); - end if; - - 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 - Write_Str_With_Col_Check ("[storage_pool = "); - Sprint_Node (Storage_Pool (Node)); - Write_Char (']'); - end if; - - when N_And_Then => - Sprint_Left_Opnd (Node); - Write_Str_Sloc (" and then "); - Sprint_Right_Opnd (Node); - - when N_At_Clause => - Write_Indent_Str_Sloc ("for "); - Write_Id (Identifier (Node)); - Write_Str_With_Col_Check (" use at "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - - when N_Assignment_Statement => - Write_Indent; - Sprint_Node (Name (Node)); - Write_Str_Sloc (" := "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - - when N_Asynchronous_Select => - Write_Indent_Str_Sloc ("select"); - Indent_Begin; - Sprint_Node (Triggering_Alternative (Node)); - Indent_End; - - -- Note: let the printing of Abortable_Part handle outputting - -- the ABORT keyword, so that the Slco can be set correctly. - - Write_Indent_Str ("then "); - Sprint_Node (Abortable_Part (Node)); - Write_Indent_Str ("end select;"); - - when N_Attribute_Definition_Clause => - Write_Indent_Str_Sloc ("for "); - Sprint_Node (Name (Node)); - Write_Char ('''); - Write_Name_With_Col_Check (Chars (Node)); - Write_Str_With_Col_Check (" use "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - - when N_Attribute_Reference => - if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then - Write_Indent; - end if; - - Sprint_Node (Prefix (Node)); - Write_Char_Sloc ('''); - Write_Name_With_Col_Check (Attribute_Name (Node)); - Sprint_Paren_Comma_List (Expressions (Node)); - - if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then - Write_Char (';'); - end if; - - when N_Block_Statement => - Write_Indent; - - if Present (Identifier (Node)) - and then (not Has_Created_Identifier (Node) - or else not Dump_Original_Only) - then - Write_Rewrite_Str ("<<<"); - Write_Id (Identifier (Node)); - Write_Str (" : "); - Write_Rewrite_Str (">>>"); - end if; - - if Present (Declarations (Node)) then - Write_Str_With_Col_Check_Sloc ("declare"); - Sprint_Indented_List (Declarations (Node)); - Write_Indent; - end if; - - Write_Str_With_Col_Check_Sloc ("begin"); - Sprint_Node (Handled_Statement_Sequence (Node)); - Write_Indent_Str ("end"); - - if Present (Identifier (Node)) - and then (not Has_Created_Identifier (Node) - or else not Dump_Original_Only) - then - Write_Rewrite_Str ("<<<"); - Write_Char (' '); - Write_Id (Identifier (Node)); - Write_Rewrite_Str (">>>"); - end if; - - Write_Char (';'); - - when N_Case_Statement => - Write_Indent_Str_Sloc ("case "); - Sprint_Node (Expression (Node)); - Write_Str (" is"); - Sprint_Indented_List (Alternatives (Node)); - Write_Indent_Str ("end case;"); - - when N_Case_Statement_Alternative => - Write_Indent_Str_Sloc ("when "); - Sprint_Bar_List (Discrete_Choices (Node)); - Write_Str (" => "); - Sprint_Indented_List (Statements (Node)); - - when N_Character_Literal => - if Column > 70 then - Write_Indent_Str (" "); - end if; - - Write_Char_Sloc ('''); - Write_Char_Code (UI_To_CC (Char_Literal_Value (Node))); - Write_Char ('''); - - when N_Code_Statement => - Write_Indent; - Set_Debug_Sloc; - Sprint_Node (Expression (Node)); - Write_Char (';'); - - when N_Compilation_Unit => - Sprint_Node_List (Context_Items (Node)); - Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node))); - - if Private_Present (Node) then - Write_Indent_Str ("private "); - Indent_Annull; - end if; - - Sprint_Node_Sloc (Unit (Node)); - - if Present (Actions (Aux_Decls_Node (Node))) - or else - Present (Pragmas_After (Aux_Decls_Node (Node))) - then - Write_Indent; - end if; - - Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node))); - Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node))); - - when N_Compilation_Unit_Aux => - null; -- nothing to do, never used, see above - - when N_Component_Association => - Set_Debug_Sloc; - Sprint_Bar_List (Choices (Node)); - Write_Str (" => "); - - -- Ada 2005 (AI-287): Print the box 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 (Component_Name (Node)); - Write_Str_Sloc (" at "); - Sprint_Node (Position (Node)); - Write_Char (' '); - Write_Str_With_Col_Check ("range "); - Sprint_Node (First_Bit (Node)); - Write_Str (" .. "); - Sprint_Node (Last_Bit (Node)); - Write_Char (';'); - - 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)); - end if; - - Write_Char (';'); - end if; - - when N_Component_List => - if Null_Present (Node) then - Indent_Begin; - Write_Indent_Str_Sloc ("null"); - Write_Char (';'); - Indent_End; - - else - Set_Debug_Sloc; - Sprint_Indented_List (Component_Items (Node)); - Sprint_Node (Variant_Part (Node)); - end if; - - when N_Conditional_Entry_Call => - Write_Indent_Str_Sloc ("select"); - Indent_Begin; - Sprint_Node (Entry_Call_Alternative (Node)); - Indent_End; - Write_Indent_Str ("else"); - Sprint_Indented_List (Else_Statements (Node)); - Write_Indent_Str ("end select;"); - - when N_Conditional_Expression => - declare - Condition : constant Node_Id := First (Expressions (Node)); - Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); - begin - Write_Str_With_Col_Check_Sloc ("(if "); - Sprint_Node (Condition); - Write_Str_With_Col_Check (" then "); - Sprint_Node (Then_Expr); - Write_Str_With_Col_Check (" else "); - Sprint_Node (Else_Expr); - Write_Char (')'); - end; - - when N_Constrained_Array_Definition => - Write_Str_With_Col_Check_Sloc ("array "); - Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node)); - Write_Str (" of "); - - Sprint_Node (Component_Definition (Node)); - - when N_Decimal_Fixed_Point_Definition => - Write_Str_With_Col_Check_Sloc (" delta "); - Sprint_Node (Delta_Expression (Node)); - Write_Str_With_Col_Check ("digits "); - Sprint_Node (Digits_Expression (Node)); - Sprint_Opt_Node (Real_Range_Specification (Node)); - - when N_Defining_Character_Literal => - Write_Name_With_Col_Check_Sloc (Chars (Node)); - - when N_Defining_Identifier => - Set_Debug_Sloc; - Write_Id (Node); - - when N_Defining_Operator_Symbol => - Write_Name_With_Col_Check_Sloc (Chars (Node)); - - when N_Defining_Program_Unit_Name => - Set_Debug_Sloc; - Sprint_Node (Name (Node)); - Write_Char ('.'); - Write_Id (Defining_Identifier (Node)); - - when N_Delay_Alternative => - Sprint_Node_List (Pragmas_Before (Node)); - - if Present (Condition (Node)) then - Write_Indent; - Write_Str_With_Col_Check ("when "); - Sprint_Node (Condition (Node)); - Write_Str (" => "); - Indent_Annull; - end if; - - Sprint_Node_Sloc (Delay_Statement (Node)); - Sprint_Node_List (Statements (Node)); - - when N_Delay_Relative_Statement => - Write_Indent_Str_Sloc ("delay "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - - when N_Delay_Until_Statement => - Write_Indent_Str_Sloc ("delay until "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - - when N_Delta_Constraint => - Write_Str_With_Col_Check_Sloc ("delta "); - Sprint_Node (Delta_Expression (Node)); - Sprint_Opt_Node (Range_Constraint (Node)); - - when N_Derived_Type_Definition => - if Abstract_Present (Node) then - Write_Str_With_Col_Check ("abstract "); - 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 (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; - - when N_Designator => - Sprint_Node (Name (Node)); - Write_Char_Sloc ('.'); - Write_Id (Identifier (Node)); - - when N_Digits_Constraint => - Write_Str_With_Col_Check_Sloc ("digits "); - Sprint_Node (Digits_Expression (Node)); - Sprint_Opt_Node (Range_Constraint (Node)); - - when N_Discriminant_Association => - Set_Debug_Sloc; - - if Present (Selector_Names (Node)) then - Sprint_Bar_List (Selector_Names (Node)); - Write_Str (" => "); - end if; - - Set_Debug_Sloc; - Sprint_Node (Expression (Node)); - - when N_Discriminant_Specification => - Set_Debug_Sloc; - - 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_Str (" := "); - Sprint_Node (Expression (Node)); - end if; - else - Write_Str (", "); - end if; - - when N_Elsif_Part => - Write_Indent_Str_Sloc ("elsif "); - Sprint_Node (Condition (Node)); - Write_Str_With_Col_Check (" then"); - Sprint_Indented_List (Then_Statements (Node)); - - when N_Empty => - null; - - when N_Entry_Body => - Write_Indent_Str_Sloc ("entry "); - Write_Id (Defining_Identifier (Node)); - Sprint_Node (Entry_Body_Formal_Part (Node)); - Write_Str_With_Col_Check (" is"); - Sprint_Indented_List (Declarations (Node)); - Write_Indent_Str ("begin"); - Sprint_Node (Handled_Statement_Sequence (Node)); - Write_Indent_Str ("end "); - Write_Id (Defining_Identifier (Node)); - Write_Char (';'); - - when N_Entry_Body_Formal_Part => - if Present (Entry_Index_Specification (Node)) then - Write_Str_With_Col_Check_Sloc (" ("); - Sprint_Node (Entry_Index_Specification (Node)); - Write_Char (')'); - end if; - - Write_Param_Specs (Node); - Write_Str_With_Col_Check_Sloc (" when "); - Sprint_Node (Condition (Node)); - - when N_Entry_Call_Alternative => - Sprint_Node_List (Pragmas_Before (Node)); - Sprint_Node_Sloc (Entry_Call_Statement (Node)); - Sprint_Node_List (Statements (Node)); - - when N_Entry_Call_Statement => - Write_Indent; - Sprint_Node_Sloc (Name (Node)); - Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); - Write_Char (';'); - - when N_Entry_Declaration => - Write_Indent_Str_Sloc ("entry "); - Write_Id (Defining_Identifier (Node)); - - if Present (Discrete_Subtype_Definition (Node)) then - Write_Str_With_Col_Check (" ("); - Sprint_Node (Discrete_Subtype_Definition (Node)); - Write_Char (')'); - end if; - - Write_Param_Specs (Node); - Write_Char (';'); - - when N_Entry_Index_Specification => - Write_Str_With_Col_Check_Sloc ("for "); - Write_Id (Defining_Identifier (Node)); - Write_Str_With_Col_Check (" in "); - Sprint_Node (Discrete_Subtype_Definition (Node)); - - when N_Enumeration_Representation_Clause => - Write_Indent_Str_Sloc ("for "); - Write_Id (Identifier (Node)); - Write_Str_With_Col_Check (" use "); - Sprint_Node (Array_Aggregate (Node)); - Write_Char (';'); - - when N_Enumeration_Type_Definition => - Set_Debug_Sloc; - - -- Skip attempt to print Literals field if it's not there and - -- we are in package Standard (case of Character, which is - -- handled specially (without an explicit literals list). - - if Sloc (Node) > Standard_Location - or else Present (Literals (Node)) - then - Sprint_Paren_Comma_List (Literals (Node)); - end if; - - when N_Error => - Write_Str_With_Col_Check_Sloc ("<error>"); - - when N_Exception_Declaration => - if Write_Indent_Identifiers (Node) then - Write_Str_With_Col_Check (" : "); - Write_Str_Sloc ("exception;"); - end if; - - when N_Exception_Handler => - Write_Indent_Str_Sloc ("when "); - - if Present (Choice_Parameter (Node)) then - Sprint_Node (Choice_Parameter (Node)); - Write_Str (" : "); - end if; - - Sprint_Bar_List (Exception_Choices (Node)); - Write_Str (" => "); - Sprint_Indented_List (Statements (Node)); - - when N_Exception_Renaming_Declaration => - Write_Indent; - Set_Debug_Sloc; - Sprint_Node (Defining_Identifier (Node)); - Write_Str_With_Col_Check (" : exception renames "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - when N_Exit_Statement => - Write_Indent_Str_Sloc ("exit"); - Sprint_Opt_Node (Name (Node)); - - if Present (Condition (Node)) then - Write_Str_With_Col_Check (" when "); - Sprint_Node (Condition (Node)); - end if; - - 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_Sloc ('.'); - Write_Str_Sloc ("all"); - - when N_Extension_Aggregate => - Write_Str_With_Col_Check_Sloc ("("); - Sprint_Node (Ancestor_Part (Node)); - Write_Str_With_Col_Check (" with "); - - if Null_Record_Present (Node) then - Write_Str_With_Col_Check ("null record"); - else - if Present (Expressions (Node)) then - Sprint_Comma_List (Expressions (Node)); - - if Present (Component_Associations (Node)) then - Write_Str (", "); - end if; - end if; - - if Present (Component_Associations (Node)) then - Sprint_Comma_List (Component_Associations (Node)); - end if; - end if; - - Write_Char (')'); - - when N_Floating_Point_Definition => - Write_Str_With_Col_Check_Sloc ("digits "); - Sprint_Node (Digits_Expression (Node)); - Sprint_Opt_Node (Real_Range_Specification (Node)); - - when N_Formal_Decimal_Fixed_Point_Definition => - Write_Str_With_Col_Check_Sloc ("delta <> digits <>"); - - when N_Formal_Derived_Type_Definition => - Write_Str_With_Col_Check_Sloc ("new "); - Sprint_Node (Subtype_Mark (Node)); - - if Private_Present (Node) then - 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_Floating_Point_Definition => - Write_Str_With_Col_Check_Sloc ("digits <>"); - - when N_Formal_Modular_Type_Definition => - Write_Str_With_Col_Check_Sloc ("mod <>"); - - when N_Formal_Object_Declaration => - Set_Debug_Sloc; - - if Write_Indent_Identifiers (Node) then - Write_Str (" : "); - - if In_Present (Node) then - Write_Str_With_Col_Check ("in "); - end if; - - if Out_Present (Node) then - Write_Str_With_Col_Check ("out "); - end if; - - Sprint_Node (Subtype_Mark (Node)); - - if Present (Expression (Node)) then - Write_Str (" := "); - Sprint_Node (Expression (Node)); - end if; - - Write_Char (';'); - end if; - - when N_Formal_Ordinary_Fixed_Point_Definition => - Write_Str_With_Col_Check_Sloc ("delta <>"); - - when N_Formal_Package_Declaration => - Write_Indent_Str_Sloc ("with package "); - Write_Id (Defining_Identifier (Node)); - Write_Str_With_Col_Check (" is new "); - Sprint_Node (Name (Node)); - Write_Str_With_Col_Check (" (<>);"); - - when N_Formal_Private_Type_Definition => - if Abstract_Present (Node) then - Write_Str_With_Col_Check ("abstract "); - end if; - - if Tagged_Present (Node) then - Write_Str_With_Col_Check ("tagged "); - end if; - - if Limited_Present (Node) then - Write_Str_With_Col_Check ("limited "); - end if; - - Write_Str_With_Col_Check_Sloc ("private"); - - when N_Formal_Signed_Integer_Type_Definition => - Write_Str_With_Col_Check_Sloc ("range <>"); - - when N_Formal_Type_Declaration => - Write_Indent_Str_Sloc ("type "); - Write_Id (Defining_Identifier (Node)); - - if Present (Discriminant_Specifications (Node)) then - Write_Discr_Specs (Node); - elsif Unknown_Discriminants_Present (Node) then - Write_Str_With_Col_Check ("(<>)"); - end if; - - Write_Str_With_Col_Check (" is "); - Sprint_Node (Formal_Type_Definition (Node)); - Write_Char (';'); - - when N_Free_Statement => - Write_Indent_Str_Sloc ("free "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - - when N_Freeze_Entity => - if Dump_Original_Only then - null; - - elsif Present (Actions (Node)) or else Dump_Freeze_Null then - Write_Indent; - Write_Rewrite_Str ("<<<"); - Write_Str_With_Col_Check_Sloc ("freeze "); - Write_Id (Entity (Node)); - Write_Str (" ["); - - if No (Actions (Node)) then - Write_Char (']'); - - else - Freeze_Indent := Freeze_Indent + 1; - Sprint_Indented_List (Actions (Node)); - Freeze_Indent := Freeze_Indent - 1; - Write_Indent_Str ("]"); - end if; - - Write_Rewrite_Str (">>>"); - end if; - - when N_Full_Type_Declaration => - Write_Indent_Str_Sloc ("type "); - Write_Id (Defining_Identifier (Node)); - Write_Discr_Specs (Node); - Write_Str_With_Col_Check (" is "); - Sprint_Node (Type_Definition (Node)); - Write_Char (';'); - - when N_Function_Call => - Set_Debug_Sloc; - Note_Implicit_Run_Time_Call (Name (Node)); - Sprint_Node (Name (Node)); - Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); - - when N_Function_Instantiation => - Write_Indent_Str_Sloc ("function "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str_With_Col_Check (" is new "); - Sprint_Node (Name (Node)); - Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); - Write_Char (';'); - - when N_Function_Specification => - Write_Str_With_Col_Check_Sloc ("function "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Param_Specs (Node); - Write_Str_With_Col_Check (" return "); - - -- 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; - - if Present (Selector_Name (Node)) then - Sprint_Node (Selector_Name (Node)); - Write_Str (" => "); - end if; - - Sprint_Node (Explicit_Generic_Actual_Parameter (Node)); - - when N_Generic_Function_Renaming_Declaration => - Write_Indent_Str_Sloc ("generic function "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str_With_Col_Check (" renames "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - when N_Generic_Package_Declaration => - Write_Indent; - Write_Indent_Str_Sloc ("generic "); - Sprint_Indented_List (Generic_Formal_Declarations (Node)); - Write_Indent; - Sprint_Node (Specification (Node)); - Write_Char (';'); - - when N_Generic_Package_Renaming_Declaration => - Write_Indent_Str_Sloc ("generic package "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str_With_Col_Check (" renames "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - when N_Generic_Procedure_Renaming_Declaration => - Write_Indent_Str_Sloc ("generic procedure "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str_With_Col_Check (" renames "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - when N_Generic_Subprogram_Declaration => - Write_Indent; - Write_Indent_Str_Sloc ("generic "); - Sprint_Indented_List (Generic_Formal_Declarations (Node)); - Write_Indent; - Sprint_Node (Specification (Node)); - Write_Char (';'); - - when N_Goto_Statement => - Write_Indent_Str_Sloc ("goto "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - if Nkind (Next (Node)) = N_Label then - Write_Indent; - end if; - - when N_Handled_Sequence_Of_Statements => - Set_Debug_Sloc; - Sprint_Indented_List (Statements (Node)); - - if Present (Exception_Handlers (Node)) then - Write_Indent_Str ("exception"); - Indent_Begin; - Sprint_Node_List (Exception_Handlers (Node)); - Indent_End; - end if; - - if Present (At_End_Proc (Node)) then - Write_Indent_Str ("at end"); - Indent_Begin; - Write_Indent; - Sprint_Node (At_End_Proc (Node)); - Write_Char (';'); - Indent_End; - end if; - - when N_Identifier => - Set_Debug_Sloc; - Write_Id (Node); - - when N_If_Statement => - Write_Indent_Str_Sloc ("if "); - Sprint_Node (Condition (Node)); - Write_Str_With_Col_Check (" then"); - Sprint_Indented_List (Then_Statements (Node)); - Sprint_Opt_Node_List (Elsif_Parts (Node)); - - if Present (Else_Statements (Node)) then - Write_Indent_Str ("else"); - Sprint_Indented_List (Else_Statements (Node)); - end if; - - Write_Indent_Str ("end if;"); - - when N_Implicit_Label_Declaration => - if not Dump_Original_Only then - Write_Indent; - Write_Rewrite_Str ("<<<"); - Set_Debug_Sloc; - Write_Id (Defining_Identifier (Node)); - Write_Str (" : "); - Write_Str_With_Col_Check ("label"); - Write_Rewrite_Str (">>>"); - end if; - - when N_In => - Sprint_Left_Opnd (Node); - Write_Str_Sloc (" in "); - Sprint_Right_Opnd (Node); - - when N_Incomplete_Type_Declaration => - Write_Indent_Str_Sloc ("type "); - Write_Id (Defining_Identifier (Node)); - - if Present (Discriminant_Specifications (Node)) then - Write_Discr_Specs (Node); - elsif Unknown_Discriminants_Present (Node) then - Write_Str_With_Col_Check ("(<>)"); - end if; - - Write_Char (';'); - - when N_Index_Or_Discriminant_Constraint => - Set_Debug_Sloc; - Sprint_Paren_Comma_List (Constraints (Node)); - - when N_Indexed_Component => - Sprint_Node_Sloc (Prefix (Node)); - Sprint_Opt_Paren_Comma_List (Expressions (Node)); - - when N_Integer_Literal => - if Print_In_Hex (Node) then - Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex); - else - Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto); - end if; - - when N_Iteration_Scheme => - if Present (Condition (Node)) then - Write_Str_With_Col_Check_Sloc ("while "); - Sprint_Node (Condition (Node)); - else - Write_Str_With_Col_Check_Sloc ("for "); - Sprint_Node (Loop_Parameter_Specification (Node)); - end if; - - Write_Char (' '); - - when N_Itype_Reference => - Write_Indent_Str_Sloc ("reference "); - Write_Id (Itype (Node)); - - when N_Label => - Write_Indent_Str_Sloc ("<<"); - Write_Id (Identifier (Node)); - Write_Str (">>"); - - when N_Loop_Parameter_Specification => - Set_Debug_Sloc; - Write_Id (Defining_Identifier (Node)); - Write_Str_With_Col_Check (" in "); - - if Reverse_Present (Node) then - Write_Str_With_Col_Check ("reverse "); - end if; - - Sprint_Node (Discrete_Subtype_Definition (Node)); - - when N_Loop_Statement => - Write_Indent; - - if Present (Identifier (Node)) - and then (not Has_Created_Identifier (Node) - or else not Dump_Original_Only) - then - Write_Rewrite_Str ("<<<"); - Write_Id (Identifier (Node)); - Write_Str (" : "); - Write_Rewrite_Str (">>>"); - Sprint_Node (Iteration_Scheme (Node)); - Write_Str_With_Col_Check_Sloc ("loop"); - Sprint_Indented_List (Statements (Node)); - Write_Indent_Str ("end loop "); - Write_Rewrite_Str ("<<<"); - Write_Id (Identifier (Node)); - Write_Rewrite_Str (">>>"); - Write_Char (';'); - - else - Sprint_Node (Iteration_Scheme (Node)); - Write_Str_With_Col_Check_Sloc ("loop"); - Sprint_Indented_List (Statements (Node)); - Write_Indent_Str ("end loop;"); - end if; - - when N_Mod_Clause => - Sprint_Node_List (Pragmas_Before (Node)); - Write_Str_With_Col_Check_Sloc ("at mod "); - Sprint_Node (Expression (Node)); - - when N_Modular_Type_Definition => - Write_Str_With_Col_Check_Sloc ("mod "); - Sprint_Node (Expression (Node)); - - when N_Not_In => - Sprint_Left_Opnd (Node); - Write_Str_Sloc (" not in "); - Sprint_Right_Opnd (Node); - - when N_Null => - Write_Str_With_Col_Check_Sloc ("null"); - - when N_Null_Statement => - if Comes_From_Source (Node) - or else Dump_Freeze_Null - or else not Is_List_Member (Node) - or else (No (Prev (Node)) and then No (Next (Node))) - then - Write_Indent_Str_Sloc ("null;"); - end if; - - when N_Number_Declaration => - Set_Debug_Sloc; - - if Write_Indent_Identifiers (Node) then - Write_Str_With_Col_Check (" : constant "); - Write_Str (" := "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - end if; - - when N_Object_Declaration => - 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; - - -- Ada 2005 (AI-231) - - if Null_Exclusion_Present (Node) then - Write_Str_With_Col_Check ("not null "); - end if; - - Sprint_Node (Object_Definition (Node)); - - if Present (Expression (Node)) then - Write_Str (" := "); - Sprint_Node (Expression (Node)); - end if; - - Write_Char (';'); - end if; - - when N_Object_Renaming_Declaration => - Write_Indent; - Set_Debug_Sloc; - Sprint_Node (Defining_Identifier (Node)); - Write_Str (" : "); - - -- 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_Right_Opnd (Node); - - when N_Op_Add => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " + "); - Sprint_Right_Opnd (Node); - - when N_Op_And => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " and "); - Sprint_Right_Opnd (Node); - - when N_Op_Concat => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " & "); - Sprint_Right_Opnd (Node); - - when N_Op_Divide => - Sprint_Left_Opnd (Node); - Write_Char (' '); - Process_TFAI_RR_Flags (Node); - Write_Operator (Node, "/ "); - Sprint_Right_Opnd (Node); - - when N_Op_Eq => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " = "); - Sprint_Right_Opnd (Node); - - when N_Op_Expon => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " ** "); - Sprint_Right_Opnd (Node); - - when N_Op_Ge => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " >= "); - Sprint_Right_Opnd (Node); - - when N_Op_Gt => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " > "); - Sprint_Right_Opnd (Node); - - when N_Op_Le => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " <= "); - Sprint_Right_Opnd (Node); - - when N_Op_Lt => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " < "); - Sprint_Right_Opnd (Node); - - when N_Op_Minus => - Write_Operator (Node, "-"); - Sprint_Right_Opnd (Node); - - when N_Op_Mod => - Sprint_Left_Opnd (Node); - - if Treat_Fixed_As_Integer (Node) then - Write_Str (" #"); - end if; - - Write_Operator (Node, " mod "); - Sprint_Right_Opnd (Node); - - when N_Op_Multiply => - Sprint_Left_Opnd (Node); - Write_Char (' '); - Process_TFAI_RR_Flags (Node); - Write_Operator (Node, "* "); - Sprint_Right_Opnd (Node); - - when N_Op_Ne => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " /= "); - Sprint_Right_Opnd (Node); - - when N_Op_Not => - Write_Operator (Node, "not "); - Sprint_Right_Opnd (Node); - - when N_Op_Or => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " or "); - Sprint_Right_Opnd (Node); - - when N_Op_Plus => - Write_Operator (Node, "+"); - Sprint_Right_Opnd (Node); - - when N_Op_Rem => - Sprint_Left_Opnd (Node); - - if Treat_Fixed_As_Integer (Node) then - Write_Str (" #"); - end if; - - Write_Operator (Node, " rem "); - Sprint_Right_Opnd (Node); - - when N_Op_Shift => - Set_Debug_Sloc; - Write_Id (Node); - Write_Char ('!'); - Write_Str_With_Col_Check ("("); - Sprint_Node (Left_Opnd (Node)); - Write_Str (", "); - Sprint_Node (Right_Opnd (Node)); - Write_Char (')'); - - when N_Op_Subtract => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " - "); - Sprint_Right_Opnd (Node); - - when N_Op_Xor => - Sprint_Left_Opnd (Node); - Write_Operator (Node, " xor "); - Sprint_Right_Opnd (Node); - - when N_Operator_Symbol => - Write_Name_With_Col_Check_Sloc (Chars (Node)); - - when N_Ordinary_Fixed_Point_Definition => - Write_Str_With_Col_Check_Sloc ("delta "); - Sprint_Node (Delta_Expression (Node)); - Sprint_Opt_Node (Real_Range_Specification (Node)); - - when N_Or_Else => - Sprint_Left_Opnd (Node); - Write_Str_Sloc (" or else "); - Sprint_Right_Opnd (Node); - - when N_Others_Choice => - if All_Others (Node) then - Write_Str_With_Col_Check ("all "); - end if; - - Write_Str_With_Col_Check_Sloc ("others"); - - when N_Package_Body => - Write_Indent; - Write_Indent_Str_Sloc ("package body "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str (" is"); - Sprint_Indented_List (Declarations (Node)); - - if Present (Handled_Statement_Sequence (Node)) then - Write_Indent_Str ("begin"); - Sprint_Node (Handled_Statement_Sequence (Node)); - end if; - - Write_Indent_Str ("end "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Char (';'); - - when N_Package_Body_Stub => - Write_Indent_Str_Sloc ("package body "); - Sprint_Node (Defining_Identifier (Node)); - Write_Str_With_Col_Check (" is separate;"); - - when N_Package_Declaration => - Write_Indent; - Write_Indent; - Sprint_Node_Sloc (Specification (Node)); - Write_Char (';'); - - when N_Package_Instantiation => - Write_Indent; - Write_Indent_Str_Sloc ("package "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str (" is new "); - Sprint_Node (Name (Node)); - Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); - Write_Char (';'); - - when N_Package_Renaming_Declaration => - Write_Indent_Str_Sloc ("package "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str_With_Col_Check (" renames "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - when N_Package_Specification => - Write_Str_With_Col_Check_Sloc ("package "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str (" is"); - Sprint_Indented_List (Visible_Declarations (Node)); - - if Present (Private_Declarations (Node)) then - Write_Indent_Str ("private"); - Sprint_Indented_List (Private_Declarations (Node)); - end if; - - Write_Indent_Str ("end "); - Sprint_Node (Defining_Unit_Name (Node)); - - when N_Parameter_Association => - Sprint_Node_Sloc (Selector_Name (Node)); - Write_Str (" => "); - Sprint_Node (Explicit_Actual_Parameter (Node)); - - when N_Parameter_Specification => - Set_Debug_Sloc; - - if Write_Identifiers (Node) then - Write_Str (" : "); - - if In_Present (Node) then - Write_Str_With_Col_Check ("in "); - end if; - - if Out_Present (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_Str (" := "); - Sprint_Node (Expression (Node)); - end if; - else - Write_Str (", "); - end if; - - when N_Pragma => - Write_Indent_Str_Sloc ("pragma "); - Write_Name_With_Col_Check (Chars (Node)); - - if Present (Pragma_Argument_Associations (Node)) then - Sprint_Opt_Paren_Comma_List - (Pragma_Argument_Associations (Node)); - end if; - - Write_Char (';'); - - when N_Pragma_Argument_Association => - Set_Debug_Sloc; - - if Chars (Node) /= No_Name then - Write_Name_With_Col_Check (Chars (Node)); - Write_Str (" => "); - end if; - - Sprint_Node (Expression (Node)); - - when N_Private_Type_Declaration => - Write_Indent_Str_Sloc ("type "); - Write_Id (Defining_Identifier (Node)); - - if Present (Discriminant_Specifications (Node)) then - Write_Discr_Specs (Node); - elsif Unknown_Discriminants_Present (Node) then - Write_Str_With_Col_Check ("(<>)"); - end if; - - Write_Str (" is "); - - if Tagged_Present (Node) then - Write_Str_With_Col_Check ("tagged "); - end if; - - if Limited_Present (Node) then - Write_Str_With_Col_Check ("limited "); - end if; - - Write_Str_With_Col_Check ("private;"); - - when N_Private_Extension_Declaration => - Write_Indent_Str_Sloc ("type "); - Write_Id (Defining_Identifier (Node)); - - if Present (Discriminant_Specifications (Node)) then - Write_Discr_Specs (Node); - elsif Unknown_Discriminants_Present (Node) then - Write_Str_With_Col_Check ("(<>)"); - end if; - - Write_Str_With_Col_Check (" is new "); - Sprint_Node (Subtype_Indication (Node)); - Write_Str_With_Col_Check (" with private;"); - - when N_Procedure_Call_Statement => - Write_Indent; - Set_Debug_Sloc; - Note_Implicit_Run_Time_Call (Name (Node)); - Sprint_Node (Name (Node)); - Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); - Write_Char (';'); - - when N_Procedure_Instantiation => - Write_Indent_Str_Sloc ("procedure "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Str_With_Col_Check (" is new "); - Sprint_Node (Name (Node)); - Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); - Write_Char (';'); - - when N_Procedure_Specification => - Write_Str_With_Col_Check_Sloc ("procedure "); - Sprint_Node (Defining_Unit_Name (Node)); - Write_Param_Specs (Node); - - when N_Protected_Body => - Write_Indent_Str_Sloc ("protected body "); - Write_Id (Defining_Identifier (Node)); - Write_Str (" is"); - Sprint_Indented_List (Declarations (Node)); - Write_Indent_Str ("end "); - Write_Id (Defining_Identifier (Node)); - Write_Char (';'); - - when N_Protected_Body_Stub => - Write_Indent_Str_Sloc ("protected body "); - Write_Id (Defining_Identifier (Node)); - Write_Str_With_Col_Check (" is separate;"); - - when N_Protected_Definition => - Set_Debug_Sloc; - Sprint_Indented_List (Visible_Declarations (Node)); - - if Present (Private_Declarations (Node)) then - Write_Indent_Str ("private"); - Sprint_Indented_List (Private_Declarations (Node)); - end if; - - Write_Indent_Str ("end "); - - when N_Protected_Type_Declaration => - Write_Indent_Str_Sloc ("protected 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)); - 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 ('''); - - -- 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 => - - -- 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_Str_With_Col_Check_Sloc ("[constraint_error"); - Write_Condition_And_Reason (Node); - - when N_Raise_Program_Error => - - -- 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_Str_With_Col_Check_Sloc ("[program_error"); - Write_Condition_And_Reason (Node); - - when N_Raise_Storage_Error => - - -- 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_Str_With_Col_Check_Sloc ("[storage_error"); - Write_Condition_And_Reason (Node); - - when N_Raise_Statement => - Write_Indent_Str_Sloc ("raise "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - when N_Range => - Sprint_Node (Low_Bound (Node)); - Write_Str_Sloc (" .. "); - Sprint_Node (High_Bound (Node)); - - when N_Range_Constraint => - Write_Str_With_Col_Check_Sloc ("range "); - Sprint_Node (Range_Expression (Node)); - - when N_Real_Literal => - Write_Ureal_With_Col_Check_Sloc (Realval (Node)); - - when N_Real_Range_Specification => - Write_Str_With_Col_Check_Sloc ("range "); - Sprint_Node (Low_Bound (Node)); - Write_Str (" .. "); - Sprint_Node (High_Bound (Node)); - - when N_Record_Definition => - if Abstract_Present (Node) then - Write_Str_With_Col_Check ("abstract "); - end if; - - if Tagged_Present (Node) then - Write_Str_With_Col_Check ("tagged "); - end if; - - if Limited_Present (Node) then - Write_Str_With_Col_Check ("limited "); - end if; - - if Null_Present (Node) then - Write_Str_With_Col_Check_Sloc ("null record"); - - else - Write_Str_With_Col_Check_Sloc ("record"); - Sprint_Node (Component_List (Node)); - Write_Indent_Str ("end record"); - end if; - - when N_Record_Representation_Clause => - Write_Indent_Str_Sloc ("for "); - Sprint_Node (Identifier (Node)); - Write_Str_With_Col_Check (" use record "); - - if Present (Mod_Clause (Node)) then - Sprint_Node (Mod_Clause (Node)); - end if; - - Sprint_Indented_List (Component_Clauses (Node)); - Write_Indent_Str ("end record;"); - - when N_Reference => - Sprint_Node (Prefix (Node)); - Write_Str_With_Col_Check_Sloc ("'reference"); - - when N_Requeue_Statement => - Write_Indent_Str_Sloc ("requeue "); - Sprint_Node (Name (Node)); - - if Abort_Present (Node) then - Write_Str_With_Col_Check (" with abort"); - end if; - - Write_Char (';'); - - when N_Return_Statement => - if Present (Expression (Node)) then - Write_Indent_Str_Sloc ("return "); - Sprint_Node (Expression (Node)); - Write_Char (';'); - else - Write_Indent_Str_Sloc ("return;"); - end if; - - when N_Selective_Accept => - Write_Indent_Str_Sloc ("select"); - - declare - Alt_Node : Node_Id; - begin - Alt_Node := First (Select_Alternatives (Node)); - loop - Indent_Begin; - Sprint_Node (Alt_Node); - Indent_End; - Next (Alt_Node); - exit when No (Alt_Node); - Write_Indent_Str ("or"); - end loop; - end; - - if Present (Else_Statements (Node)) then - Write_Indent_Str ("else"); - Sprint_Indented_List (Else_Statements (Node)); - end if; - - Write_Indent_Str ("end select;"); - - when N_Signed_Integer_Type_Definition => - Write_Str_With_Col_Check_Sloc ("range "); - Sprint_Node (Low_Bound (Node)); - Write_Str (" .. "); - Sprint_Node (High_Bound (Node)); - - when N_Single_Protected_Declaration => - Write_Indent_Str_Sloc ("protected "); - Write_Id (Defining_Identifier (Node)); - Write_Str (" is"); - Sprint_Node (Protected_Definition (Node)); - Write_Id (Defining_Identifier (Node)); - Write_Char (';'); - - when N_Single_Task_Declaration => - Write_Indent_Str_Sloc ("task "); - Write_Id (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 (';'); - - when N_Selected_Component => - Sprint_Node (Prefix (Node)); - Write_Char_Sloc ('.'); - Sprint_Node (Selector_Name (Node)); - - when N_Slice => - Set_Debug_Sloc; - Sprint_Node (Prefix (Node)); - Write_Str_With_Col_Check (" ("); - Sprint_Node (Discrete_Range (Node)); - Write_Char (')'); - - when N_String_Literal => - if String_Length (Strval (Node)) + Column > 75 then - Write_Indent_Str (" "); - end if; - - Set_Debug_Sloc; - Write_String_Table_Entry (Strval (Node)); - - when N_Subprogram_Body => - if Freeze_Indent = 0 then - Write_Indent; - end if; - - Write_Indent; - Sprint_Node_Sloc (Specification (Node)); - Write_Str (" is"); - - Sprint_Indented_List (Declarations (Node)); - Write_Indent_Str ("begin"); - Sprint_Node (Handled_Statement_Sequence (Node)); - - Write_Indent_Str ("end "); - Sprint_Node (Defining_Unit_Name (Specification (Node))); - Write_Char (';'); - - if Is_List_Member (Node) - and then Present (Next (Node)) - and then Nkind (Next (Node)) /= N_Subprogram_Body - then - Write_Indent; - end if; - - when N_Subprogram_Body_Stub => - Write_Indent; - Sprint_Node_Sloc (Specification (Node)); - Write_Str_With_Col_Check (" is separate;"); - - 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 => - Sprint_Node (Identifier (Node)); - Write_Str_With_Col_Check_Sloc ("'subprogram_info"); - - when N_Subprogram_Renaming_Declaration => - Write_Indent; - Sprint_Node (Specification (Node)); - Write_Str_With_Col_Check_Sloc (" renames "); - Sprint_Node (Name (Node)); - Write_Char (';'); - - when N_Subtype_Declaration => - 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 (';'); - - when N_Subtype_Indication => - Sprint_Node_Sloc (Subtype_Mark (Node)); - Write_Char (' '); - Sprint_Node (Constraint (Node)); - - when N_Subunit => - Write_Indent_Str_Sloc ("separate ("); - Sprint_Node (Name (Node)); - Write_Char (')'); - Write_Eol; - Sprint_Node (Proper_Body (Node)); - - when N_Task_Body => - Write_Indent_Str_Sloc ("task body "); - Write_Id (Defining_Identifier (Node)); - Write_Str (" is"); - Sprint_Indented_List (Declarations (Node)); - Write_Indent_Str ("begin"); - Sprint_Node (Handled_Statement_Sequence (Node)); - Write_Indent_Str ("end "); - Write_Id (Defining_Identifier (Node)); - Write_Char (';'); - - when N_Task_Body_Stub => - Write_Indent_Str_Sloc ("task body "); - Write_Id (Defining_Identifier (Node)); - Write_Str_With_Col_Check (" is separate;"); - - when N_Task_Definition => - Set_Debug_Sloc; - Sprint_Indented_List (Visible_Declarations (Node)); - - if Present (Private_Declarations (Node)) then - Write_Indent_Str ("private"); - Sprint_Indented_List (Private_Declarations (Node)); - end if; - - Write_Indent_Str ("end "); - - when N_Task_Type_Declaration => - 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 - 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; - - Write_Char (';'); - - when N_Terminate_Alternative => - Sprint_Node_List (Pragmas_Before (Node)); - - Write_Indent; - - if Present (Condition (Node)) then - Write_Str_With_Col_Check ("when "); - Sprint_Node (Condition (Node)); - Write_Str (" => "); - end if; - - Write_Str_With_Col_Check_Sloc ("terminate;"); - Sprint_Node_List (Pragmas_After (Node)); - - when N_Timed_Entry_Call => - Write_Indent_Str_Sloc ("select"); - Indent_Begin; - Sprint_Node (Entry_Call_Alternative (Node)); - Indent_End; - Write_Indent_Str ("or"); - Indent_Begin; - Sprint_Node (Delay_Alternative (Node)); - Indent_End; - Write_Indent_Str ("end select;"); - - when N_Triggering_Alternative => - Sprint_Node_List (Pragmas_Before (Node)); - Sprint_Node_Sloc (Triggering_Statement (Node)); - Sprint_Node_List (Statements (Node)); - - when N_Type_Conversion => - Set_Debug_Sloc; - Sprint_Node (Subtype_Mark (Node)); - Col_Check (4); - - if Conversion_OK (Node) then - Write_Char ('?'); - end if; - - if Float_Truncate (Node) then - Write_Char ('^'); - end if; - - if Rounded_Result (Node) then - Write_Char ('@'); - end if; - - Write_Char ('('); - Sprint_Node (Expression (Node)); - Write_Char (')'); - - when N_Unchecked_Expression => - Col_Check (10); - Write_Str ("`("); - Sprint_Node_Sloc (Expression (Node)); - Write_Char (')'); - - when N_Unchecked_Type_Conversion => - Sprint_Node (Subtype_Mark (Node)); - Write_Char ('!'); - Write_Str_With_Col_Check ("("); - Sprint_Node_Sloc (Expression (Node)); - Write_Char (')'); - - when N_Unconstrained_Array_Definition => - Write_Str_With_Col_Check_Sloc ("array ("); - - declare - Node1 : Node_Id; - begin - Node1 := First (Subtype_Marks (Node)); - loop - Sprint_Node (Node1); - Write_Str_With_Col_Check (" range <>"); - Next (Node1); - exit when Node1 = Empty; - Write_Str (", "); - end loop; - end; - - Write_Str (") of "); - Sprint_Node (Component_Definition (Node)); - - when N_Unused_At_Start | N_Unused_At_End => - Write_Indent_Str ("***** Error, unused node encountered *****"); - Write_Eol; - - when N_Use_Package_Clause => - Write_Indent_Str_Sloc ("use "); - Sprint_Comma_List (Names (Node)); - Write_Char (';'); - - when N_Use_Type_Clause => - Write_Indent_Str_Sloc ("use type "); - Sprint_Comma_List (Subtype_Marks (Node)); - Write_Char (';'); - - when N_Validate_Unchecked_Conversion => - Write_Indent_Str_Sloc ("validate unchecked_conversion ("); - Sprint_Node (Source_Type (Node)); - Write_Str (", "); - Sprint_Node (Target_Type (Node)); - Write_Str (");"); - - when N_Variant => - Write_Indent_Str_Sloc ("when "); - Sprint_Bar_List (Discrete_Choices (Node)); - Write_Str (" => "); - Sprint_Node (Component_List (Node)); - - when N_Variant_Part => - Indent_Begin; - Write_Indent_Str_Sloc ("case "); - Sprint_Node (Name (Node)); - Write_Str (" is "); - Sprint_Indented_List (Variants (Node)); - Write_Indent_Str ("end case"); - Indent_End; - - when N_With_Clause => - - -- Special test, if we are dumping the original tree only, - -- then we want to eliminate the bogus with clauses that - -- correspond to the non-existent children of Text_IO. - - if Dump_Original_Only - and then Is_Text_IO_Kludge_Unit (Name (Node)) - then - null; - - -- Normal case, output the with clause - - else - if First_Name (Node) or else not Dump_Original_Only then - - -- 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; - - Sprint_Node_Sloc (Name (Node)); - - if Last_Name (Node) or else not Dump_Original_Only then - 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 - and then Do_Range_Check (Node) - then - Write_Str ("}"); - end if; - - for J in 1 .. Paren_Count (Node) loop - Write_Char (')'); - end loop; - - pragma Assert (No (Debug_Node)); - Debug_Node := Save_Debug_Node; - end Sprint_Node_Actual; - - ---------------------- - -- Sprint_Node_List -- - ---------------------- - - procedure Sprint_Node_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; - end loop; - end if; - end Sprint_Node_List; - - ---------------------- - -- Sprint_Node_Sloc -- - ---------------------- - - procedure Sprint_Node_Sloc (Node : Node_Id) is - begin - Sprint_Node (Node); - - if Present (Debug_Node) then - Set_Sloc (Debug_Node, Sloc (Node)); - Debug_Node := Empty; - end if; - end Sprint_Node_Sloc; - - --------------------- - -- Sprint_Opt_Node -- - --------------------- - - procedure Sprint_Opt_Node (Node : Node_Id) is - begin - if Present (Node) then - Write_Char (' '); - Sprint_Node (Node); - end if; - end Sprint_Opt_Node; - - -------------------------- - -- Sprint_Opt_Node_List -- - -------------------------- - - procedure Sprint_Opt_Node_List (List : List_Id) is - begin - if Present (List) then - Sprint_Node_List (List); - end if; - end Sprint_Opt_Node_List; - - --------------------------------- - -- Sprint_Opt_Paren_Comma_List -- - --------------------------------- - - procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is - begin - if Is_Non_Empty_List (List) then - Write_Char (' '); - Sprint_Paren_Comma_List (List); - end if; - end Sprint_Opt_Paren_Comma_List; - - ----------------------------- - -- Sprint_Paren_Comma_List -- - ----------------------------- - - procedure Sprint_Paren_Comma_List (List : List_Id) is - N : Node_Id; - Node_Exists : Boolean := False; - - begin - - if Is_Non_Empty_List (List) then - - if Dump_Original_Only then - N := First (List); - while Present (N) loop - if not Is_Rewrite_Insertion (N) then - Node_Exists := True; - exit; - end if; - - Next (N); - end loop; - - if not Node_Exists then - return; - end if; - end if; - - Write_Str_With_Col_Check ("("); - Sprint_Comma_List (List); - Write_Char (')'); - 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 -- - --------------------- - - procedure Write_Char_Sloc (C : Character) is - begin - if Debug_Generated_Code and then C /= ' ' then - Set_Debug_Sloc; - end if; - - Write_Char (C); - end Write_Char_Sloc; - - -------------------------------- - -- 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; - - begin - Specs := Discriminant_Specifications (N); - - if Present (Specs) then - Write_Str_With_Col_Check (" ("); - Spec := First (Specs); - - loop - Sprint_Node (Spec); - Next (Spec); - exit when Spec = Empty; - - -- Add semicolon, unless we are printing original tree and the - -- next specification is part of a list (but not the first - -- element of that list) - - if not Dump_Original_Only or else not Prev_Ids (Spec) then - Write_Str ("; "); - end if; - end loop; - - Write_Char (')'); - end if; - end Write_Discr_Specs; - - ----------------- - -- Write_Ekind -- - ----------------- - - procedure Write_Ekind (E : Entity_Id) is - S : constant String := Entity_Kind'Image (Ekind (E)); - - begin - Name_Len := S'Length; - Name_Buffer (1 .. Name_Len) := S; - Set_Casing (Mixed_Case); - Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); - end Write_Ekind; - - -------------- - -- Write_Id -- - -------------- - - procedure Write_Id (N : Node_Id) is - begin - -- Deal with outputting Itype - - -- Note: if we are printing the full tree with -gnatds, then we may - -- end up picking up the Associated_Node link from a generic template - -- here which overlaps the Entity field, but as documented, Write_Itype - -- is defended against junk calls. - - if Nkind (N) in N_Entity then - Write_Itype (N); - elsif Nkind (N) in N_Has_Entity then - Write_Itype (Entity (N)); - end if; - - -- Case of a defining identifier - - if Nkind (N) = N_Defining_Identifier then - - -- If defining identifier has an interface name (and no - -- address clause), then we output the interface name. - - if (Is_Imported (N) or else Is_Exported (N)) - and then Present (Interface_Name (N)) - and then No (Address_Clause (N)) - then - String_To_Name_Buffer (Strval (Interface_Name (N))); - Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); - - -- If no interface name (or inactive because there was - -- an address clause), then just output the Chars name. - - else - Write_Name_With_Col_Check (Chars (N)); - end if; - - -- Case of selector of an expanded name where the expanded name - -- has an associated entity, output this entity. - - elsif Nkind (Parent (N)) = N_Expanded_Name - and then Selector_Name (Parent (N)) = N - and then Present (Entity (Parent (N))) - then - Write_Id (Entity (Parent (N))); - - -- For any other node with an associated entity, output it - - elsif Nkind (N) in N_Has_Entity - and then Present (Entity_Or_Associated_Node (N)) - and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity - then - Write_Id (Entity (N)); - - -- All other cases, we just print the Chars field - - else - Write_Name_With_Col_Check (Chars (N)); - end if; - end Write_Id; - - ----------------------- - -- Write_Identifiers -- - ----------------------- - - function Write_Identifiers (Node : Node_Id) return Boolean is - begin - Sprint_Node (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 - - return - not Dump_Original_Only or else not More_Ids (Node); - - end Write_Identifiers; - - ------------------------ - -- Write_Implicit_Def -- - ------------------------ - - procedure Write_Implicit_Def (E : Entity_Id) is - Ind : Node_Id; - - begin - case Ekind (E) is - when E_Array_Subtype => - Write_Str_With_Col_Check ("subtype "); - Write_Id (E); - Write_Str_With_Col_Check (" is "); - Write_Id (Base_Type (E)); - Write_Str_With_Col_Check (" ("); - - Ind := First_Index (E); - while Present (Ind) loop - Sprint_Node (Ind); - Next_Index (Ind); - - if Present (Ind) then - Write_Str (", "); - end if; - end loop; - - Write_Str (");"); - - when E_Signed_Integer_Subtype | E_Enumeration_Subtype => - Write_Str_With_Col_Check ("subtype "); - Write_Id (E); - Write_Str (" is "); - Write_Id (Etype (E)); - Write_Str_With_Col_Check (" range "); - Sprint_Node (Scalar_Range (E)); - Write_Str (";"); - - when others => - Write_Str_With_Col_Check ("type "); - Write_Id (E); - Write_Str_With_Col_Check (" is <"); - Write_Ekind (E); - Write_Str (">;"); - end case; - - end Write_Implicit_Def; - - ------------------ - -- Write_Indent -- - ------------------ - - procedure Write_Indent is - begin - if Indent_Annull_Flag then - Indent_Annull_Flag := False; - else - Write_Eol; - - for J in 1 .. Indent loop - Write_Char (' '); - end loop; - end if; - end Write_Indent; - - ------------------------------ - -- Write_Indent_Identifiers -- - ------------------------------ - - function Write_Indent_Identifiers (Node : Node_Id) return Boolean is - begin - -- We need to start a new line for every node, except in the case - -- where we are printing the original tree and this is not the first - -- defining identifier in the list. - - if not Dump_Original_Only or else not Prev_Ids (Node) then - Write_Indent; - - -- If printing original tree and this is not the first defining - -- identifier in the list, then the previous call to this procedure - -- printed only the name, and we add a comma to separate the names. - - else - Write_Str (", "); - end if; - - Sprint_Node (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 - - return - not Dump_Original_Only or else not More_Ids (Node); - - end Write_Indent_Identifiers; - - ----------------------------------- - -- Write_Indent_Identifiers_Sloc -- - ----------------------------------- - - function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is - begin - -- We need to start a new line for every node, except in the case - -- where we are printing the original tree and this is not the first - -- defining identifier in the list. - - if not Dump_Original_Only or else not Prev_Ids (Node) then - Write_Indent; - - -- If printing original tree and this is not the first defining - -- identifier in the list, then the previous call to this procedure - -- printed only the name, and we add a comma to separate the names. - - else - Write_Str (", "); - end if; - - Set_Debug_Sloc; - Sprint_Node (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 - - return - not Dump_Original_Only or else not More_Ids (Node); - - end Write_Indent_Identifiers_Sloc; - - ---------------------- - -- Write_Indent_Str -- - ---------------------- - - procedure Write_Indent_Str (S : String) is - begin - Write_Indent; - Write_Str (S); - end Write_Indent_Str; - - --------------------------- - -- Write_Indent_Str_Sloc -- - --------------------------- - - procedure Write_Indent_Str_Sloc (S : String) is - begin - Write_Indent; - Write_Str_Sloc (S); - end Write_Indent_Str_Sloc; - - ----------------- - -- Write_Itype -- - ----------------- - - procedure Write_Itype (Typ : Entity_Id) is - - procedure Write_Header (T : Boolean := True); - -- Write type if T is True, subtype if T is false - - ------------------ - -- Write_Header -- - ------------------ - - procedure Write_Header (T : Boolean := True) is - begin - if T then - Write_Str ("[type "); - else - Write_Str ("[subtype "); - end if; - - Write_Name_With_Col_Check (Chars (Typ)); - Write_Str (" is "); - end Write_Header; - - -- Start of processing for Write_Itype - - begin - if Nkind (Typ) in N_Entity - and then Is_Itype (Typ) - and then not Itype_Printed (Typ) - then - -- Itype to be printed - - declare - B : constant Node_Id := Etype (Typ); - X : Node_Id; - P : constant Node_Id := Parent (Typ); - - S : constant Saved_Output_Buffer := Save_Output_Buffer; - -- Save current output buffer - - Old_Sloc : Source_Ptr; - -- Save sloc of related node, so it is not modified when - -- printing with -gnatD. - - begin - -- Write indentation at start of line - - for J in 1 .. Indent loop - Write_Char (' '); - end loop; - - -- If we have a constructed declaration, print it - - if Present (P) and then Nkind (P) in N_Declaration then - - -- We must set Itype_Printed true before the recursive call to - -- print the node, otherwise we get an infinite recursion! - - Set_Itype_Printed (Typ, True); - - -- Write the declaration enclosed in [], avoiding new line - -- at start of declaration, and semicolon at end. - - -- Note: The itype may be imported from another unit, in which - -- case we do not want to modify the Sloc of the declaration. - -- Otherwise the itype may appear to be in the current unit, - -- and the back-end will reject a reference out of scope. - - Write_Char ('['); - Indent_Annull_Flag := True; - Old_Sloc := Sloc (P); - Sprint_Node (P); - Set_Sloc (P, Old_Sloc); - Write_Erase_Char (';'); - - -- If no constructed declaration, then we have to concoct the - -- source corresponding to the type entity that we have at hand. - - else - case Ekind (Typ) is - - -- Access types and subtypes - - when Access_Kind => - Write_Header (Ekind (Typ) = E_Access_Type); - Write_Str ("access "); - - if Is_Access_Constant (Typ) then - Write_Str ("constant "); - elsif Can_Never_Be_Null (Typ) then - Write_Str ("not null "); - end if; - - Write_Id (Directly_Designated_Type (Typ)); - - -- Array types and string types - - when E_Array_Type | E_String_Type => - Write_Header; - Write_Str ("array ("); - - X := First_Index (Typ); - loop - Sprint_Node (X); - - if not Is_Constrained (Typ) then - Write_Str (" range <>"); - end if; - - Next_Index (X); - exit when No (X); - Write_Str (", "); - end loop; - - Write_Str (") of "); - Sprint_Node (Component_Type (Typ)); - - -- Array subtypes and string subtypes - - when E_Array_Subtype | E_String_Subtype => - Write_Header (False); - Write_Id (Etype (Typ)); - Write_Str (" ("); - - X := First_Index (Typ); - loop - Sprint_Node (X); - Next_Index (X); - exit when No (X); - Write_Str (", "); - end loop; - - Write_Char (')'); - - -- Signed integer types, and modular integer subtypes - - when E_Signed_Integer_Type | - E_Signed_Integer_Subtype | - E_Modular_Integer_Subtype => - - Write_Header (Ekind (Typ) = E_Signed_Integer_Type); - - if Ekind (Typ) = E_Signed_Integer_Type then - Write_Str ("new "); - end if; - - Write_Id (B); - - -- Print bounds if not different from base type - - declare - L : constant Node_Id := Type_Low_Bound (Typ); - H : constant Node_Id := Type_High_Bound (Typ); - LE : constant Node_Id := Type_Low_Bound (B); - HE : constant Node_Id := Type_High_Bound (B); - - begin - if Nkind (L) = N_Integer_Literal - and then Nkind (H) = N_Integer_Literal - and then Nkind (LE) = N_Integer_Literal - and then Nkind (HE) = N_Integer_Literal - and then UI_Eq (Intval (L), Intval (LE)) - and then UI_Eq (Intval (H), Intval (HE)) - then - null; - - else - Write_Str (" range "); - Sprint_Node (Type_Low_Bound (Typ)); - Write_Str (" .. "); - Sprint_Node (Type_High_Bound (Typ)); - end if; - end; - - -- Modular integer types - - when E_Modular_Integer_Type => - Write_Header; - Write_Str (" mod "); - Write_Uint_With_Col_Check (Modulus (Typ), Auto); - - -- Floating point types and subtypes - - when E_Floating_Point_Type | - E_Floating_Point_Subtype => - - Write_Header (Ekind (Typ) = E_Floating_Point_Type); - - if Ekind (Typ) = E_Floating_Point_Type then - Write_Str ("new "); - end if; - - Write_Id (Etype (Typ)); - - if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then - Write_Str (" digits "); - Write_Uint_With_Col_Check - (Digits_Value (Typ), Decimal); - end if; - - -- Print bounds if not different from base type - - declare - L : constant Node_Id := Type_Low_Bound (Typ); - H : constant Node_Id := Type_High_Bound (Typ); - LE : constant Node_Id := Type_Low_Bound (B); - HE : constant Node_Id := Type_High_Bound (B); - - begin - if Nkind (L) = N_Real_Literal - and then Nkind (H) = N_Real_Literal - and then Nkind (LE) = N_Real_Literal - and then Nkind (HE) = N_Real_Literal - and then UR_Eq (Realval (L), Realval (LE)) - and then UR_Eq (Realval (H), Realval (HE)) - then - null; - - else - Write_Str (" range "); - Sprint_Node (Type_Low_Bound (Typ)); - Write_Str (" .. "); - Sprint_Node (Type_High_Bound (Typ)); - end if; - end; - - -- Record subtypes - - when E_Record_Subtype => - Write_Header (False); - Write_Str ("record"); - Indent_Begin; - - declare - C : Entity_Id; - begin - C := First_Entity (Typ); - while Present (C) loop - Write_Indent; - Write_Id (C); - Write_Str (" : "); - Write_Id (Etype (C)); - Next_Entity (C); - end loop; - end; - - Indent_End; - Write_Indent_Str (" end record"); - - -- Class-Wide types - - when E_Class_Wide_Type => - Write_Header; - Write_Name_With_Col_Check (Chars (Etype (Typ))); - Write_Str ("'Class"); - - -- Subprogram types - - when E_Subprogram_Type => - Write_Header; - - if Etype (Typ) = Standard_Void_Type then - Write_Str ("procedure"); - else - Write_Str ("function"); - end if; - - if Present (First_Entity (Typ)) then - Write_Str (" ("); - - declare - Param : Entity_Id; - - begin - Param := First_Entity (Typ); - loop - Write_Id (Param); - Write_Str (" : "); - - if Ekind (Param) = E_In_Out_Parameter then - Write_Str ("in out "); - elsif Ekind (Param) = E_Out_Parameter then - Write_Str ("out "); - end if; - - Write_Id (Etype (Param)); - Next_Entity (Param); - exit when No (Param); - Write_Str (", "); - end loop; - - Write_Char (')'); - end; - end if; - - if Etype (Typ) /= Standard_Void_Type then - Write_Str (" return "); - Write_Id (Etype (Typ)); - end if; - - -- For all other Itypes, print ??? (fill in later) - - when others => - Write_Header (True); - Write_Str ("???"); - - end case; - end if; - - -- Add terminating bracket and restore output buffer - - Write_Char (']'); - Write_Eol; - Restore_Output_Buffer (S); - end; - - Set_Itype_Printed (Typ); - end if; - end Write_Itype; - - ------------------------------- - -- Write_Name_With_Col_Check -- - ------------------------------- - - procedure Write_Name_With_Col_Check (N : Name_Id) is - J : Natural; - - begin - Get_Name_String (N); - - -- Deal with -gnatI which replaces digits in an internal - -- name by three dots (e.g. R7b becomes R...b). - - if Debug_Flag_II and then Name_Buffer (1) in 'A' .. 'Z' then - J := 2; - while J < Name_Len loop - exit when Name_Buffer (J) not in 'A' .. 'Z'; - J := J + 1; - end loop; - - if Name_Buffer (J) in '0' .. '9' then - Write_Str_With_Col_Check (Name_Buffer (1 .. J - 1)); - Write_Str ("..."); - - while J <= Name_Len loop - if Name_Buffer (J) not in '0' .. '9' then - Write_Str (Name_Buffer (J .. Name_Len)); - exit; - - else - J := J + 1; - end if; - end loop; - - return; - end if; - end if; - - -- Fall through for normal case - - Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); - end Write_Name_With_Col_Check; - - ------------------------------------ - -- Write_Name_With_Col_Check_Sloc -- - ------------------------------------ - - procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is - begin - Get_Name_String (N); - Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len)); - end Write_Name_With_Col_Check_Sloc; - - -------------------- - -- Write_Operator -- - -------------------- - - procedure Write_Operator (N : Node_Id; S : String) is - F : Natural := S'First; - T : Natural := S'Last; - - begin - -- If no overflow check, just write string out, and we are done - - 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; - - Write_Char ('{'); - Write_Str_Sloc (S (F .. T)); - Write_Char ('}'); - - if S (S'Last) = ' ' then - Write_Char (' '); - end if; - end if; - end Write_Operator; - - ----------------------- - -- Write_Param_Specs -- - ----------------------- - - procedure Write_Param_Specs (N : Node_Id) is - Specs : List_Id; - Spec : Node_Id; - Formal : Node_Id; - - begin - Specs := Parameter_Specifications (N); - - if Is_Non_Empty_List (Specs) then - Write_Str_With_Col_Check (" ("); - Spec := First (Specs); - - loop - Sprint_Node (Spec); - Formal := Defining_Identifier (Spec); - Next (Spec); - exit when Spec = Empty; - - -- Add semicolon, unless we are printing original tree and the - -- next specification is part of a list (but not the first - -- element of that list) - - if not Dump_Original_Only or else not Prev_Ids (Spec) then - Write_Str ("; "); - end if; - end loop; - - -- Write out any extra formals - - while Present (Extra_Formal (Formal)) loop - Formal := Extra_Formal (Formal); - Write_Str ("; "); - Write_Name_With_Col_Check (Chars (Formal)); - Write_Str (" : "); - Write_Name_With_Col_Check (Chars (Etype (Formal))); - end loop; - - Write_Char (')'); - end if; - end Write_Param_Specs; - - -------------------------- - -- Write_Rewrite_Str -- - -------------------------- - - procedure Write_Rewrite_Str (S : String) is - begin - if not Dump_Generated_Only then - if S'Length = 3 and then S = ">>>" then - Write_Str (">>>"); - else - Write_Str_With_Col_Check (S); - end if; - end if; - end Write_Rewrite_Str; - - -------------------- - -- Write_Str_Sloc -- - -------------------- - - procedure Write_Str_Sloc (S : String) is - begin - for J in S'Range loop - Write_Char_Sloc (S (J)); - end loop; - end Write_Str_Sloc; - - ------------------------------ - -- Write_Str_With_Col_Check -- - ------------------------------ - - procedure Write_Str_With_Col_Check (S : String) is - begin - if Int (S'Last) + Column > Line_Limit then - Write_Indent_Str (" "); - - if S (1) = ' ' then - Write_Str (S (2 .. S'Length)); - else - Write_Str (S); - end if; - - else - Write_Str (S); - end if; - end Write_Str_With_Col_Check; - - ----------------------------------- - -- Write_Str_With_Col_Check_Sloc -- - ----------------------------------- - - procedure Write_Str_With_Col_Check_Sloc (S : String) is - begin - if Int (S'Last) + Column > Line_Limit then - Write_Indent_Str (" "); - - if S (1) = ' ' then - Write_Str_Sloc (S (2 .. S'Length)); - else - Write_Str_Sloc (S); - end if; - - else - Write_Str_Sloc (S); - end if; - end Write_Str_With_Col_Check_Sloc; - - ------------------------------- - -- Write_Uint_With_Col_Check -- - ------------------------------- - - procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is - begin - Col_Check (UI_Decimal_Digits_Hi (U)); - UI_Write (U, Format); - end Write_Uint_With_Col_Check; - - ------------------------------------ - -- Write_Uint_With_Col_Check_Sloc -- - ------------------------------------ - - procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is - begin - Col_Check (UI_Decimal_Digits_Hi (U)); - Set_Debug_Sloc; - UI_Write (U, Format); - end Write_Uint_With_Col_Check_Sloc; - - ------------------------------------- - -- Write_Ureal_With_Col_Check_Sloc -- - ------------------------------------- - - procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is - D : constant Uint := Denominator (U); - N : constant Uint := Numerator (U); - - begin - Col_Check - (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); - Set_Debug_Sloc; - UR_Write (U); - end Write_Ureal_With_Col_Check_Sloc; - -end Sprint; |