6e937c1c5c
2004-02-02 Vincent Celier <celier@gnat.com> * gprcmd.adb (Check_Args): If condition is false, print the invoked comment before the usage. Gprcmd: Fail when command is not recognized. (Usage): Document command "prefix" * g-md5.adb (Digest): Process last block. (Update): Do not process last block. Store remaining characters and length in Context. * g-md5.ads (Update): Document that several call to update are equivalent to one call with the concatenated string. (Context): Add fields to allow new Update behaviour. * fname-uf.ads/adb (Get_File_Name): New Boolean parameter May_Fail, defaulted to False. When May_Fail is True and no existing file can be found, return No_File. * 6vcstrea.adb: Inlined functions are now wrappers to implementation functions. * lib-writ.adb (Write_With_Lines): When body file does not exist, use spec file name instead on the W line. 2004-02-02 Robert Dewar <dewar@gnat.com> * ali.adb: Read and acquire info from new format restrictions lines * bcheck.adb: Add circuits for checking restrictions with parameters * bindgen.adb: Output dummy restrictions data To be changed later * ali.ads, checks.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb, exp_ch3.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_util.adb, freeze.adb, gnat1drv.adb, sem_attr.adb, sem_ch10.adb, sem_ch11.adb, sem_ch12.adb, targparm.adb, targparm.ads, tbuild.adb, sem_ch2.adb, sem_elab.adb, sem_res.adb: Minor changes for new restrictions handling. * exp_ch9.adb (Build_Master_Entity): Cleanup the code (also suppresses the warning message on access to possibly uninitialized variable S) Minor changes for new restrictions handling. * gnatbind.adb: Minor reformatting Minor changes for new restrictions handling Move circuit for -r processing here from bcheck (cleaner) * gnatcmd.adb, gnatlink.adb: Minor reformatting * lib-writ.adb: Output new format restrictions lines * lib-writ.ads: Document new R format lines for new restrictions handling. * s-restri.ads/adb: New files * Makefile.rtl: Add entry for s-restri.ads/adb * par-ch3.adb: Fix bad error messages starting with upper case letter Minor reformatting * restrict.adb: Major rewrite throughout for new restrictions handling Major point is to handle restrictions with parameters * restrict.ads: Major changes in interface to handle restrictions with parameters. Also generally simplifies setting of restrictions. * snames.ads/adb: New entry for proper handling of No_Requeue * sem_ch3.adb (Count_Tasks): New circuitry for implementing Max_Tasks restriction counting. Other minor changes for new restrictions handling * sem_prag.adb: No_Requeue is a synonym for No_Requeue_Statements. Restriction_Warnings now allows full parameter notation Major rewrite of Restrictions for new restrictions handling 2004-02-02 Javier Miranda <miranda@gnat.com> * par-ch3.adb (P_Identifier_Declarations): Give support to the Ada 0Y syntax rule for object renaming declarations. (P_Array_Type_Definition): Give support for the Ada 0Y syntax rule for component definitions. * sem_ch3.adb (Analyze_Component_Declaration): Give support to access components. (Array_Type_Declaration): Give support to access components. In addition it was also modified to reflect the name of the object in anonymous array types. The old code did not take into account that it is possible to have an unconstrained anonymous array with an initial value. (Check_Or_Process_Discriminants): Allow access discriminant in non-limited types. (Process_Discriminants): Allow access discriminant in non-limited types Initialize the new Access_Definition field in N_Object_Renaming_Decl node. Change Ada0Y to Ada 0Y in comments * sem_ch4.adb (Find_Equality_Types): Allow anonymous access types in equality operators. Change Ada0Y to Ada 0Y in comments * sem_ch8.adb (Analyze_Object_Renaming): Give support to access renamings Change Ada0Y to Ada 0Y in comments * sem_type.adb (Find_Unique_Type): Give support to the equality operators for universal access types Change Ada0Y to Ada 0Y in comments * sinfo.adb (Access_Definition, Set_Access_Definition): New subprograms * sinfo.ads (N_Component_Definition): Addition of Access_Definition field. (N_Object_Renaming_Declaration): Addition of Access_Definition field Change Ada0Y to Ada 0Y in comments * sprint.adb (Sprint_Node_Actual): Give support to the new syntax for component definition and object renaming nodes Change Ada0Y to Ada 0Y in comments 2004-02-02 Jose Ruiz <ruiz@act-europe.fr> * restrict.adb: Use the new restriction identifier No_Requeue_Statements instead of the old No_Requeue for defining the restricted profile. * sem_ch9.adb (Analyze_Requeue): Check the new restriction No_Requeue_Statements. * s-rident.ads: Adding restriction No_Requeue_Statements (AI-00249) that supersedes the GNAT specific restriction No_Requeue. The later is kept for backward compatibility. 2004-02-02 Ed Schonberg <schonberg@gnat.com> * lib.ads, i-cobol.ads, * s-stoele.ads, s-thread.ads, style.ads, 5staprop.adb, atree.adb, atree.ads, g-crc32.ads: Remove redundant pragma and fix incorrect ones. * sem_prag.adb For pragma Inline and pragma Pure_Function, emit a warning if the pragma is redundant. 2004-02-02 Thomas Quinot <quinot@act-europe.fr> * 5staprop.adb: Add missing 'constant' keywords. * Makefile.in: use consistent value for SYMLIB on platforms where libaddr2line is supported. 2004-02-02 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> * utils.c (end_subprog_body): Do not call rest_of_compilation if just annotating types. 2004-02-02 Olivier Hainque <hainque@act-europe.fr> * init.c (__gnat_install_handler): Setup an alternate stack for signal handlers in the environment thread. This allows proper propagation of an exception on stack overflows in this thread even when the builtin ABI stack-checking scheme is used without support for a stack reserve region. * utils.c (create_field_decl): Augment the head comment about bitfield creation, and don't account for DECL_BIT_FIELD in DECL_NONADDRESSABLE_P here, because the former is not accurate enough at this point. Let finish_record_type decide instead. Don't make a bitfield if the field is to be addressable. Always set a size for the field if the record is packed, to ensure the checks for bitfield creation are triggered. (finish_record_type): During last pass over the fields, clear DECL_BIT_FIELD when possible in the !STRICT_ALIGNMENT case, as this is not covered by the calls to layout_decl. Adjust DECL_NONADDRESSABLE_P from DECL_BIT_FIELD. From-SVN: r77110
3221 lines
100 KiB
Ada
3221 lines
100 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S P R I N T --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2004, 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, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, 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 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 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_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.
|
|
|
|
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_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_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;
|
|
|
|
--------
|
|
-- 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_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 =>
|
|
Write_Str_With_Col_Check_Sloc ("access ");
|
|
Sprint_Node (Subtype_Mark (Node));
|
|
|
|
when N_Access_Function_Definition =>
|
|
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 (Subtype_Mark (Node));
|
|
|
|
when N_Access_Procedure_Definition =>
|
|
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;
|
|
|
|
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 ");
|
|
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 (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 0Y (AI-287): Print the mbox if present
|
|
|
|
if Box_Present (Node) then
|
|
Write_Str_With_Col_Check ("<>");
|
|
else
|
|
Sprint_Node (Expression (Node));
|
|
end if;
|
|
|
|
when N_Component_Clause =>
|
|
Write_Indent;
|
|
Sprint_Node (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 0Y (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;
|
|
|
|
Sprint_Node (Subtype_Indication (Node));
|
|
else
|
|
pragma Assert (False);
|
|
null;
|
|
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 ");
|
|
Sprint_Node (Subtype_Indication (Node));
|
|
|
|
if Present (Record_Extension_Part (Node)) then
|
|
Write_Str_With_Col_Check (" with ");
|
|
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 (" : ");
|
|
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_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_Subprogram_Declaration =>
|
|
Write_Indent_Str_Sloc ("with ");
|
|
Sprint_Node (Specification (Node));
|
|
|
|
if Box_Present (Node) then
|
|
Write_Str_With_Col_Check (" is <>");
|
|
elsif Present (Default_Name (Node)) then
|
|
Write_Str_With_Col_Check (" is ");
|
|
Sprint_Node (Default_Name (Node));
|
|
end if;
|
|
|
|
Write_Char (';');
|
|
|
|
when N_Formal_Type_Declaration =>
|
|
Write_Indent_Str_Sloc ("type ");
|
|
Write_Id (Defining_Identifier (Node));
|
|
|
|
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;
|
|
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 ");
|
|
Sprint_Node (Subtype_Mark (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;
|
|
|
|
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 0Y (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
|
|
pragma Assert (False);
|
|
null;
|
|
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;
|
|
|
|
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;
|
|
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);
|
|
Write_Str (" is");
|
|
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));
|
|
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 ");
|
|
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 (Task_Definition (Node)) then
|
|
Write_Str (" is");
|
|
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 0Y (AI-50217): Print limited with_clauses
|
|
|
|
if 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
|
|
-- 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_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_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;
|