aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/sprint.adb
diff options
context:
space:
mode:
authorGeert Bosch <bosch@gcc.gnu.org>2002-03-08 21:11:04 +0100
committerGeert Bosch <bosch@gcc.gnu.org>2002-03-08 21:11:04 +0100
commit07fc65c47c45af6439208797e1ab26f7daedb666 (patch)
treeb584a79288c93215b05fb451943291ccd039388b /gcc/ada/sprint.adb
parent24965e7a8ac518b99a3bd7ef5b2d8d88f96bf514 (diff)
downloadgcc-07fc65c47c45af6439208797e1ab26f7daedb666.zip
gcc-07fc65c47c45af6439208797e1ab26f7daedb666.tar.gz
gcc-07fc65c47c45af6439208797e1ab26f7daedb666.tar.bz2
41intnam.ads, [...]: Merge in ACT changes.
* 41intnam.ads, 42intnam.ads, 4aintnam.ads, 4cintnam.ads, 4dintnam.ads, 4gintnam.ads, 4hintnam.ads, 4lintnam.ads, 4mintnam.ads, 4pintnam.ads, 4rintnam.ads, 4sintnam.ads, 4uintnam.ads, 4vcalend.adb, 4zintnam.ads, 52system.ads, 5amastop.adb, 5asystem.ads, 5ataprop.adb, 5atpopsp.adb, 5avxwork.ads, 5bosinte.adb, 5bsystem.ads, 5esystem.ads, 5fsystem.ads, 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, 5gsystem.ads, 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5hparame.ads, 5hsystem.ads, 5htaprop.adb, 5htraceb.adb, 5itaprop.adb, 5ksystem.ads, 5kvxwork.ads, 5lintman.adb, 5lsystem.ads, 5mvxwork.ads, 5ninmaop.adb, 5nosinte.ads, 5ntaprop.adb, 5ointerr.adb, 5omastop.adb, 5oosinte.adb, 5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5pvxwork.ads, 5qtaprop.adb, 5sintman.adb, 5ssystem.ads, 5staprop.adb, 5stpopse.adb, 5svxwork.ads, 5tosinte.ads, 5uintman.adb, 5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vmastop.adb, 5vparame.ads, 5vsystem.ads, 5vtaprop.adb, 5vtpopde.adb, 5wmemory.adb, 5wsystem.ads, 5wtaprop.adb, 5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb, 5zosinte.ads, 5zsystem.ads, 5ztaprop.adb, 6vcpp.adb, 6vcstrea.adb, 7sintman.adb, 7staprop.adb, 7stpopsp.adb, 9drpc.adb, Make-lang.in, Makefile.in, a-caldel.adb, a-comlin.ads, a-dynpri.adb, a-except.adb, a-except.ads, a-finali.adb, a-ncelfu.ads, a-reatim.adb, a-retide.adb, a-stream.ads, a-ststio.adb, a-ststio.ads, a-stwifi.adb, a-tags.adb, a-tasatt.adb, a-textio.adb, a-tideau.adb, a-tiflau.adb, a-tigeau.adb, a-tigeau.ads, a-tiinau.adb, a-timoau.adb, a-witeio.adb, a-wtdeau.adb, a-wtenau.adb, a-wtflau.adb, a-wtgeau.adb, a-wtgeau.ads, a-wtinau.adb, a-wtmoau.adb, ada-tree.def, ada-tree.h, adaint.c, adaint.h, ali-util.adb, ali.adb, ali.ads, atree.adb, atree.ads, atree.h, back_end.adb, bcheck.adb, bindgen.adb, bindusg.adb, checks.adb, comperr.adb, config-lang.in, csets.adb, csets.ads, cstand.adb, cstreams.c, debug.adb, debug.ads, decl.c, einfo.adb, einfo.ads, einfo.h, elists.h, errout.adb, errout.ads, eval_fat.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb, exp_ch12.adb, exp_ch13.adb, exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads, exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, exp_dbug.ads, exp_disp.ads, exp_dist.adb, exp_fixd.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb, exp_strm.adb, exp_util.adb, exp_util.ads, expander.adb, expect.c, fe.h, fmap.adb, fmap.ads, fname-uf.adb, freeze.adb, frontend.adb, g-awk.adb, g-cgideb.adb, g-comlin.adb, g-comlin.ads, g-debpoo.adb, g-dirope.adb, g-dirope.ads, g-dyntab.adb, g-expect.adb, g-expect.ads, g-io.ads, g-io_aux.adb, g-io_aux.ads, g-locfil.adb, g-locfil.ads, g-os_lib.adb, g-os_lib.ads, g-regexp.adb, g-regpat.adb, g-socket.adb, g-socket.ads, g-spipat.adb, g-table.adb, g-trasym.adb, g-trasym.ads, gigi.h, gmem.c, gnat1drv.adb, gnatbind.adb, gnatbl.c, gnatchop.adb, gnatcmd.adb, gnatdll.adb, gnatfind.adb, gnatlbr.adb, gnatlink.adb, gnatls.adb, gnatmem.adb, gnatprep.adb, gnatvsn.ads, gnatxref.adb, hlo.adb, hostparm.ads, i-cobol.adb, i-cpp.adb, i-cstrea.ads, i-cstrin.adb, i-pacdec.adb, i-vxwork.ads, impunit.adb, init.c, inline.adb, io-aux.c, layout.adb, lib-load.adb, lib-util.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads, lib.adb, lib.ads, make.adb, makeusg.adb, mdll.adb, memroot.adb, misc.c, mlib-tgt.adb, mlib-utl.adb, mlib-utl.ads, mlib.adb, namet.adb, namet.ads, namet.h, nlists.h, nmake.adb, nmake.ads, nmake.adt, opt.adb, opt.ads, osint.adb, osint.ads, output.adb, output.ads, par-ch2.adb, par-ch3.adb, par-ch5.adb, par-prag.adb, par-tchk.adb, par-util.adb, par.adb, prj-attr.adb, prj-dect.adb, prj-env.adb, prj-env.ads, prj-nmsc.adb, prj-part.adb, prj-proc.adb, prj-strt.adb, prj-tree.adb, prj-tree.ads, prj.adb, prj.ads, raise.c, raise.h, repinfo.adb, restrict.adb, restrict.ads, rident.ads, rtsfind.adb, rtsfind.ads, s-arit64.adb, s-asthan.adb, s-atacco.adb, s-atacco.ads, s-auxdec.adb, s-crc32.adb, s-crc32.ads, s-direio.adb, s-fatgen.adb, s-fileio.adb, s-finimp.adb, s-gloloc.adb, s-gloloc.ads, s-interr.adb, s-mastop.adb, s-mastop.ads, s-memory.adb, s-parame.ads, s-parint.adb, s-pooglo.adb, s-pooloc.adb, s-rpc.adb, s-secsta.adb, s-sequio.adb, s-shasto.adb, s-soflin.adb, s-soflin.ads, s-stache.adb, s-taasde.adb, s-taasde.ads, s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprop.ads, s-tarest.adb, s-tasdeb.adb, s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads, s-tassta.adb, s-tasuti.adb, s-tasuti.ads, s-tataat.adb, s-tataat.ads, s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads, s-unstyp.ads, s-widenu.adb, scn-nlit.adb, scn.adb, sem.adb, sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb, sem_ch10.adb, sem_ch11.adb, sem_ch11.ads, sem_ch12.adb, sem_ch13.adb, sem_ch13.ads, sem_ch2.adb, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch6.ads, sem_ch7.adb, sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, sem_disp.adb, sem_dist.adb, sem_elab.adb, sem_elim.adb, sem_elim.ads, sem_eval.adb, sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb, sem_util.ads, sem_vfpt.adb, sem_warn.adb, sinfo.adb, sinfo.ads, sinfo.h, sinput-l.adb, sinput-l.ads, sinput.adb, sinput.ads, snames.adb, snames.ads, snames.h, sprint.adb, sprint.ads, stringt.adb, stringt.ads, stringt.h, style.adb, switch.adb, switch.ads, sysdep.c, system.ads, table.adb, targparm.adb, targparm.ads, targtyps.c, tbuild.adb, tbuild.ads, tracebak.c, trans.c, tree_gen.adb, tree_io.adb, treepr.adb, treepr.ads, treeprs.ads, treeprs.adt, ttypes.ads, types.adb, types.ads, types.h, uintp.ads, urealp.ads, usage.adb, utils.c, utils2.c, validsw.adb, xnmake.adb, xr_tabls.adb, xr_tabls.ads, xref_lib.adb, xref_lib.ads : Merge in ACT changes. * 1ssecsta.adb, 1ssecsta.ads, a-chlat9.ads, a-cwila9.ads, g-enblsp.adb, g-md5.adb, g-md5.ads, gnatname.adb, gnatname.ads, mkdir.c, osint-b.adb, osint-b.ads, osint-c.adb, osint-c.ads, osint-l.adb, osint-l.ads, osint-m.adb, osint-m.ads : New files * 3lsoccon.ads, 5qparame.ads, 5qvxwork.ads, 5smastop.adb, 5zparame.ads, gnatmain.adb, gnatmain.ads, gnatpsys.adb : Removed * mdllfile.adb, mdllfile.ads, mdlltool.adb, mdlltool.ads : Renamed to mdll-fil.ad[bs] and mdll-util.ad[bs] * mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, mdll-utl.ads : Renamed from mdllfile.ad[bs] and mdlltool.ad[bs] From-SVN: r50451
Diffstat (limited to 'gcc/ada/sprint.adb')
-rw-r--r--gcc/ada/sprint.adb383
1 files changed, 258 insertions, 125 deletions
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index e7c1a6a..ab2b585 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -6,9 +6,9 @@
-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
+-- $Revision$
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, 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- --
@@ -28,6 +28,7 @@
with Atree; use Atree;
with Casing; use Casing;
+with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Lib; use Lib;
@@ -38,7 +39,7 @@ with Output; use Output;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
+with Sinput.D; use Sinput.D;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@@ -81,6 +82,55 @@ package body Sprint is
-- 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 : 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 --
-----------------------
@@ -102,8 +152,9 @@ package body Sprint is
procedure Indent_End;
-- Decrease indentation level
- procedure Print_Eol;
- -- Terminate current line in line buffer
+ procedure Print_Debug_Line (S : String);
+ -- Used to print output lines in Debug_Generated_Code mode (this is used
+ -- as the argument for a call to Set_Special_Output in package Output).
procedure Process_TFAI_RR_Flags (Nod : Node_Id);
-- Given a divide, multiplication or division node, check the flags
@@ -133,6 +184,9 @@ package body Sprint is
-- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is
-- called to ensure that the current node has a proper Sloc set.
+ procedure Write_Condition_And_Reason (Node : Node_Id);
+ -- Write Condition and Reason codes of Raise_xxx_Error node
+
procedure Write_Discr_Specs (N : Node_Id);
-- Output discriminant specification for node, which is any of the type
-- declarations that can have discriminants.
@@ -269,50 +323,37 @@ package body Sprint is
end Indent_End;
--------
- -- PG --
+ -- pg --
--------
- procedure PG (Node : Node_Id) is
+ procedure pg (Node : Node_Id) is
begin
Dump_Generated_Only := True;
Dump_Original_Only := False;
Sprint_Node (Node);
- Print_Eol;
- end PG;
+ Write_Eol;
+ end pg;
--------
- -- PO --
+ -- po --
--------
- procedure PO (Node : Node_Id) is
+ procedure po (Node : Node_Id) is
begin
Dump_Generated_Only := False;
Dump_Original_Only := True;
Sprint_Node (Node);
- Print_Eol;
- end PO;
+ Write_Eol;
+ end po;
- ---------------
- -- Print_Eol --
- ---------------
+ ----------------------
+ -- Print_Debug_Line --
+ ----------------------
- procedure Print_Eol is
+ procedure Print_Debug_Line (S : String) is
begin
- -- If we are writing a debug source file, then grab it from the
- -- Output buffer, and reset the column counter (the routines in
- -- Output never actually write any output for us in this mode,
- -- they just build line images in Buffer).
-
- if Debug_Generated_Code then
- Write_Debug_Line (Buffer (1 .. Natural (Column) - 1), Debug_Sloc);
- Column := 1;
-
- -- In normal mode, we call Write_Eol to write the line normally
-
- else
- Write_Eol;
- end if;
- end Print_Eol;
+ Write_Debug_Line (S, Debug_Sloc);
+ end Print_Debug_Line;
---------------------------
-- Process_TFAI_RR_Flags --
@@ -330,16 +371,16 @@ package body Sprint is
end Process_TFAI_RR_Flags;
--------
- -- PS --
+ -- ps --
--------
- procedure PS (Node : Node_Id) is
+ procedure ps (Node : Node_Id) is
begin
Dump_Generated_Only := False;
Dump_Original_Only := False;
Sprint_Node (Node);
- Print_Eol;
- end PS;
+ Write_Eol;
+ end ps;
--------------------
-- Set_Debug_Sloc --
@@ -366,13 +407,13 @@ package body Sprint is
Col : constant Int := Column;
begin
- Print_Eol;
+ Write_Eol;
while Col > Column loop
Write_Char ('-');
end loop;
- Print_Eol;
+ Write_Eol;
end Underline;
-- Start of processing for Tree_Dump.
@@ -391,13 +432,13 @@ package body Sprint is
if Debug_Flag_Z then
Debug_Flag_Z := False;
- Print_Eol;
- Print_Eol;
+ Write_Eol;
+ Write_Eol;
Write_Str ("Source recreated from tree of Standard (spec)");
Underline;
Sprint_Node (Standard_Package_Node);
- Print_Eol;
- Print_Eol;
+ Write_Eol;
+ Write_Eol;
end if;
if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then
@@ -418,10 +459,12 @@ package body Sprint is
-- If we are generating debug files, setup to write them
if Debug_Generated_Code then
+ Set_Special_Output (Print_Debug_Line'Access);
Create_Debug_Source (Source_Index (U), Debug_Sloc);
Sprint_Node (Cunit (U));
- Print_Eol;
+ Write_Eol;
Close_Debug_Source;
+ Set_Special_Output (null);
-- Normal output to standard output file
@@ -495,6 +538,26 @@ package body Sprint is
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 --
-----------------
@@ -722,9 +785,9 @@ package body Sprint is
end if;
when N_And_Then =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" and then ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_At_Clause =>
Write_Indent_Str_Sloc ("for ");
@@ -1466,9 +1529,9 @@ package body Sprint is
end if;
when N_In =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" in ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Incomplete_Type_Declaration =>
Write_Indent_Str_Sloc ("type ");
@@ -1565,9 +1628,9 @@ package body Sprint is
Sprint_Node (Expression (Node));
when N_Not_In =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" not in ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Null =>
Write_Str_With_Col_Check_Sloc ("null");
@@ -1648,108 +1711,108 @@ package body Sprint is
when N_Op_Abs =>
Write_Operator (Node, "abs ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Add =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " + ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_And =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " and ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Concat =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " & ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Divide =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Char (' ');
Process_TFAI_RR_Flags (Node);
Write_Operator (Node, "/ ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Eq =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " = ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Expon =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " ** ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Ge =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " >= ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Gt =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " > ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Le =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " <= ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Lt =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " < ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Minus =>
Write_Operator (Node, "-");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Mod =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
if Treat_Fixed_As_Integer (Node) then
Write_Str (" #");
end if;
Write_Operator (Node, " mod ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Multiply =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Char (' ');
Process_TFAI_RR_Flags (Node);
Write_Operator (Node, "* ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Ne =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " /= ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Not =>
Write_Operator (Node, "not ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Or =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " or ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Plus =>
Write_Operator (Node, "+");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Rem =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
if Treat_Fixed_As_Integer (Node) then
Write_Str (" #");
end if;
Write_Operator (Node, " rem ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Shift =>
Set_Debug_Sloc;
@@ -1762,14 +1825,14 @@ package body Sprint is
Write_Char (')');
when N_Op_Subtract =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " - ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Op_Xor =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Operator (Node, " xor ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Operator_Symbol =>
Write_Name_With_Col_Check_Sloc (Chars (Node));
@@ -1780,9 +1843,9 @@ package body Sprint is
Sprint_Opt_Node (Real_Range_Specification (Node));
when N_Or_Else =>
- Sprint_Node (Left_Opnd (Node));
+ Sprint_Left_Opnd (Node);
Write_Str_Sloc (" or else ");
- Sprint_Node (Right_Opnd (Node));
+ Sprint_Right_Opnd (Node);
when N_Others_Choice =>
if All_Others (Node) then
@@ -1991,7 +2054,20 @@ package body Sprint is
when N_Qualified_Expression =>
Sprint_Node (Subtype_Mark (Node));
Write_Char_Sloc (''');
- Sprint_Node (Expression (Node));
+
+ -- Print expression, make sure we have at least one level of
+ -- parentheses around the expression. For cases of qualified
+ -- expressions in the source, this is always the case, but
+ -- for generated qualifications, there may be no explicit
+ -- parentheses present.
+
+ if Paren_Count (Expression (Node)) /= 0 then
+ Sprint_Node (Expression (Node));
+ else
+ Write_Char ('(');
+ Sprint_Node (Expression (Node));
+ Write_Char (')');
+ end if;
when N_Raise_Constraint_Error =>
@@ -2006,35 +2082,37 @@ package body Sprint is
end if;
Write_Str_With_Col_Check_Sloc ("[constraint_error");
-
- if Present (Condition (Node)) then
- Write_Str_With_Col_Check (" when ");
- Sprint_Node (Condition (Node));
- end if;
-
- Write_Char (']');
+ Write_Condition_And_Reason (Node);
when N_Raise_Program_Error =>
- Write_Indent;
- Write_Str_With_Col_Check_Sloc ("[program_error");
- if Present (Condition (Node)) then
- Write_Str_With_Col_Check (" when ");
- Sprint_Node (Condition (Node));
+ -- This node can be used either as a subexpression or as a
+ -- statement form. The following test is a reasonably reliable
+ -- way to distinguish the two cases.
+
+ if Is_List_Member (Node)
+ and then Nkind (Parent (Node)) not in N_Subexpr
+ then
+ Write_Indent;
end if;
- Write_Char (']');
+ Write_Str_With_Col_Check_Sloc ("[program_error");
+ Write_Condition_And_Reason (Node);
when N_Raise_Storage_Error =>
- Write_Indent;
- Write_Str_With_Col_Check_Sloc ("[storage_error");
- if Present (Condition (Node)) then
- Write_Str_With_Col_Check (" when ");
- Sprint_Node (Condition (Node));
+ -- This node can be used either as a subexpression or as a
+ -- statement form. The following test is a reasonably reliable
+ -- way to distinguish the two cases.
+
+ if Is_List_Member (Node)
+ and then Nkind (Parent (Node)) not in N_Subexpr
+ then
+ Write_Indent;
end if;
- Write_Char (']');
+ Write_Str_With_Col_Check_Sloc ("[storage_error");
+ Write_Condition_And_Reason (Node);
when N_Raise_Statement =>
Write_Indent_Str_Sloc ("raise ");
@@ -2248,7 +2326,7 @@ package body Sprint is
Write_Indent_Str_Sloc ("separate (");
Sprint_Node (Name (Node));
Write_Char (')');
- Print_Eol;
+ Write_Eol;
Sprint_Node (Proper_Body (Node));
when N_Task_Body =>
@@ -2381,7 +2459,7 @@ package body Sprint is
when N_Unused_At_Start | N_Unused_At_End =>
Write_Indent_Str ("***** Error, unused node encountered *****");
- Print_Eol;
+ Write_Eol;
when N_Use_Package_Clause =>
Write_Indent_Str_Sloc ("use ");
@@ -2573,6 +2651,26 @@ package body Sprint is
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 --
---------------------
@@ -2586,6 +2684,34 @@ package body Sprint is
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 --
------------------------
@@ -2756,7 +2882,8 @@ package body Sprint is
if Indent_Annull_Flag then
Indent_Annull_Flag := False;
else
- Print_Eol;
+ Write_Eol;
+
for J in 1 .. Indent loop
Write_Char (' ');
end loop;
@@ -2909,25 +3036,31 @@ package body Sprint is
T : Natural := S'Last;
begin
- if S (F) = ' ' then
- Write_Char (' ');
- F := F + 1;
- end if;
+ -- If no overflow check, just write string out, and we are done
- if S (T) = ' ' then
- T := T - 1;
- end if;
+ if not Do_Overflow_Check (N) then
+ Write_Str_Sloc (S);
+
+ -- If overflow check, we want to surround the operator with curly
+ -- brackets, but not include spaces within the brackets.
+
+ else
+ if S (F) = ' ' then
+ Write_Char (' ');
+ F := F + 1;
+ end if;
+
+ if S (T) = ' ' then
+ T := T - 1;
+ end if;
- if Do_Overflow_Check (N) then
Write_Char ('{');
Write_Str_Sloc (S (F .. T));
Write_Char ('}');
- else
- Write_Str_Sloc (S);
- end if;
- if S (S'Last) = ' ' then
- Write_Char (' ');
+ if S (S'Last) = ' ' then
+ Write_Char (' ');
+ end if;
end if;
end Write_Operator;