1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S P R I N T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 2, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Casing; use Casing; 29with Csets; use Csets; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Lib; use Lib; 33with Namet; use Namet; 34with Nlists; use Nlists; 35with Opt; use Opt; 36with Output; use Output; 37with Rtsfind; use Rtsfind; 38with Sinfo; use Sinfo; 39with Sinput; use Sinput; 40with Sinput.D; use Sinput.D; 41with Snames; use Snames; 42with Stand; use Stand; 43with Stringt; use Stringt; 44with Uintp; use Uintp; 45with Uname; use Uname; 46with Urealp; use Urealp; 47 48package body Sprint is 49 50 Debug_Node : Node_Id := Empty; 51 -- If we are in Debug_Generated_Code mode, then this location is set 52 -- to the current node requiring Sloc fixup, until Set_Debug_Sloc is 53 -- called to set the proper value. The call clears it back to Empty. 54 55 Debug_Sloc : Source_Ptr; 56 -- Sloc of first byte of line currently being written if we are 57 -- generating a source debug file. 58 59 Dump_Original_Only : Boolean; 60 -- Set True if the -gnatdo (dump original tree) flag is set 61 62 Dump_Generated_Only : Boolean; 63 -- Set True if the -gnatG (dump generated tree) debug flag is set 64 -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD). 65 66 Dump_Freeze_Null : Boolean; 67 -- Set True if freeze nodes and non-source null statements output 68 69 Indent : Int := 0; 70 -- Number of columns for current line output indentation 71 72 Indent_Annull_Flag : Boolean := False; 73 -- Set True if subsequent Write_Indent call to be ignored, gets reset 74 -- by this call, so it is only active to suppress a single indent call. 75 76 Line_Limit : constant := 72; 77 -- Limit value for chopping long lines 78 79 Freeze_Indent : Int := 0; 80 -- Keep track of freeze indent level (controls blank lines before 81 -- procedures within expression freeze actions) 82 83 ------------------------------- 84 -- Operator Precedence Table -- 85 ------------------------------- 86 87 -- This table is used to decide whether a subexpression needs to be 88 -- parenthesized. The rule is that if an operand of an operator (which 89 -- for this purpose includes AND THEN and OR ELSE) is itself an operator 90 -- with a lower precedence than the operator (or equal precedence if 91 -- appearing as the right operand), then parentheses are required. 92 93 Op_Prec : constant array (N_Subexpr) of Short_Short_Integer := 94 (N_Op_And => 1, 95 N_Op_Or => 1, 96 N_Op_Xor => 1, 97 N_And_Then => 1, 98 N_Or_Else => 1, 99 100 N_In => 2, 101 N_Not_In => 2, 102 N_Op_Eq => 2, 103 N_Op_Ge => 2, 104 N_Op_Gt => 2, 105 N_Op_Le => 2, 106 N_Op_Lt => 2, 107 N_Op_Ne => 2, 108 109 N_Op_Add => 3, 110 N_Op_Concat => 3, 111 N_Op_Subtract => 3, 112 N_Op_Plus => 3, 113 N_Op_Minus => 3, 114 115 N_Op_Divide => 4, 116 N_Op_Mod => 4, 117 N_Op_Rem => 4, 118 N_Op_Multiply => 4, 119 120 N_Op_Expon => 5, 121 N_Op_Abs => 5, 122 N_Op_Not => 5, 123 124 others => 6); 125 126 procedure Sprint_Left_Opnd (N : Node_Id); 127 -- Print left operand of operator, parenthesizing if necessary 128 129 procedure Sprint_Right_Opnd (N : Node_Id); 130 -- Print right operand of operator, parenthesizing if necessary 131 132 ----------------------- 133 -- Local Subprograms -- 134 ----------------------- 135 136 procedure Col_Check (N : Nat); 137 -- Check that at least N characters remain on current line, and if not, 138 -- then start an extra line with two characters extra indentation for 139 -- continuing text on the next line. 140 141 procedure Indent_Annull; 142 -- Causes following call to Write_Indent to be ignored. This is used when 143 -- a higher level node wants to stop a lower level node from starting a 144 -- new line, when it would otherwise be inclined to do so (e.g. the case 145 -- of an accept statement called from an accept alternative with a guard) 146 147 procedure Indent_Begin; 148 -- Increase indentation level 149 150 procedure Indent_End; 151 -- Decrease indentation level 152 153 procedure Print_Debug_Line (S : String); 154 -- Used to print output lines in Debug_Generated_Code mode (this is used 155 -- as the argument for a call to Set_Special_Output in package Output). 156 157 procedure Process_TFAI_RR_Flags (Nod : Node_Id); 158 -- Given a divide, multiplication or division node, check the flags 159 -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the 160 -- appropriate special syntax characters (# and @). 161 162 procedure Set_Debug_Sloc; 163 -- If Debug_Node is non-empty, this routine sets the appropriate value 164 -- in its Sloc field, from the current location in the debug source file 165 -- that is currently being written. Note that Debug_Node is always empty 166 -- if a debug source file is not being written. 167 168 procedure Sprint_Bar_List (List : List_Id); 169 -- Print the given list with items separated by vertical bars 170 171 procedure Sprint_Node_Actual (Node : Node_Id); 172 -- This routine prints its node argument. It is a lower level routine than 173 -- Sprint_Node, in that it does not bother about rewritten trees. 174 175 procedure Sprint_Node_Sloc (Node : Node_Id); 176 -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode, 177 -- sets the Sloc of the current debug node to be a copy of the Sloc 178 -- of the sprinted node Node. Note that this is done after printing 179 -- Node, so that the Sloc is the proper updated value for the debug file. 180 181 procedure Write_Char_Sloc (C : Character); 182 -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is 183 -- called to ensure that the current node has a proper Sloc set. 184 185 procedure Write_Condition_And_Reason (Node : Node_Id); 186 -- Write Condition and Reason codes of Raise_xxx_Error node 187 188 procedure Write_Discr_Specs (N : Node_Id); 189 -- Ouput discriminant specification for node, which is any of the type 190 -- declarations that can have discriminants. 191 192 procedure Write_Ekind (E : Entity_Id); 193 -- Write the String corresponding to the Ekind without "E_". 194 195 procedure Write_Id (N : Node_Id); 196 -- N is a node with a Chars field. This procedure writes the name that 197 -- will be used in the generated code associated with the name. For a 198 -- node with no associated entity, this is simply the Chars field. For 199 -- the case where there is an entity associated with the node, we print 200 -- the name associated with the entity (since it may have been encoded). 201 -- One other special case is that an entity has an active external name 202 -- (i.e. an external name present with no address clause), then this 203 -- external name is output. 204 205 function Write_Identifiers (Node : Node_Id) return Boolean; 206 -- Handle node where the grammar has a list of defining identifiers, but 207 -- the tree has a separate declaration for each identifier. Handles the 208 -- printing of the defining identifier, and returns True if the type and 209 -- initialization information is to be printed, False if it is to be 210 -- skipped (the latter case happens when printing defining identifiers 211 -- other than the first in the original tree output case). 212 213 procedure Write_Implicit_Def (E : Entity_Id); 214 pragma Warnings (Off, Write_Implicit_Def); 215 -- Write the definition of the implicit type E according to its Ekind 216 -- For now a debugging procedure, but might be used in the future. 217 218 procedure Write_Indent; 219 -- Start a new line and write indentation spacing 220 221 function Write_Indent_Identifiers (Node : Node_Id) return Boolean; 222 -- Like Write_Identifiers except that each new printed declaration 223 -- is at the start of a new line. 224 225 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean; 226 -- Like Write_Indent_Identifiers except that in Debug_Generated_Code 227 -- mode, the Sloc of the current debug node is set to point ot the 228 -- first output identifier. 229 230 procedure Write_Indent_Str (S : String); 231 -- Start a new line and write indent spacing followed by given string 232 233 procedure Write_Indent_Str_Sloc (S : String); 234 -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode, 235 -- the Sloc of the current node is set to the first non-blank character 236 -- in the string S. 237 238 procedure Write_Name_With_Col_Check (N : Name_Id); 239 -- Write name (using Write_Name) with initial column check, and possible 240 -- initial Write_Indent (to get new line) if current line is too full. 241 242 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id); 243 -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code 244 -- mode, sets Sloc of current debug node to first character of name. 245 246 procedure Write_Operator (N : Node_Id; S : String); 247 -- Like Write_Str_Sloc, used for operators, encloses the string in 248 -- characters {} if the Do_Overflow flag is set on the node N. 249 250 procedure Write_Param_Specs (N : Node_Id); 251 -- Output parameter specifications for node (which is either a function 252 -- or procedure specification with a Parameter_Specifications field) 253 254 procedure Write_Rewrite_Str (S : String); 255 -- Writes out a string (typically containing <<< or >>>}) for a node 256 -- created by rewriting the tree. Suppressed if we are outputting the 257 -- generated code only, since in this case we don't specially mark nodes 258 -- created by rewriting). 259 260 procedure Write_Str_Sloc (S : String); 261 -- Like Write_Str, but sets debug Sloc of current debug node to first 262 -- non-blank character if a current debug node is active. 263 264 procedure Write_Str_With_Col_Check (S : String); 265 -- Write string (using Write_Str) with initial column check, and possible 266 -- initial Write_Indent (to get new line) if current line is too full. 267 268 procedure Write_Str_With_Col_Check_Sloc (S : String); 269 -- Like Write_Str_WIth_Col_Check, but sets debug Sloc of current debug 270 -- node to first non-blank character if a current debug node is active. 271 272 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format); 273 -- Write Uint (using UI_Write) with initial column check, and possible 274 -- initial Write_Indent (to get new line) if current line is too full. 275 -- The format parameter determines the output format (see UI_Write). 276 -- In addition, in Debug_Generated_Code mode, sets the current node 277 -- Sloc to the first character of the output value. 278 279 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal); 280 -- Write Ureal (using same output format as UR_Write) with column checks 281 -- and a possible initial Write_Indent (to get new line) if current line 282 -- is too full. In addition, in Debug_Generated_Code mode, sets the 283 -- current node Sloc to the first character of the output value. 284 285 --------------- 286 -- Col_Check -- 287 --------------- 288 289 procedure Col_Check (N : Nat) is 290 begin 291 if N + Column > Line_Limit then 292 Write_Indent_Str (" "); 293 end if; 294 end Col_Check; 295 296 ------------------- 297 -- Indent_Annull -- 298 ------------------- 299 300 procedure Indent_Annull is 301 begin 302 Indent_Annull_Flag := True; 303 end Indent_Annull; 304 305 ------------------ 306 -- Indent_Begin -- 307 ------------------ 308 309 procedure Indent_Begin is 310 begin 311 Indent := Indent + 3; 312 end Indent_Begin; 313 314 ---------------- 315 -- Indent_End -- 316 ---------------- 317 318 procedure Indent_End is 319 begin 320 Indent := Indent - 3; 321 end Indent_End; 322 323 -------- 324 -- pg -- 325 -------- 326 327 procedure pg (Node : Node_Id) is 328 begin 329 Dump_Generated_Only := True; 330 Dump_Original_Only := False; 331 Sprint_Node (Node); 332 Write_Eol; 333 end pg; 334 335 -------- 336 -- po -- 337 -------- 338 339 procedure po (Node : Node_Id) is 340 begin 341 Dump_Generated_Only := False; 342 Dump_Original_Only := True; 343 Sprint_Node (Node); 344 Write_Eol; 345 end po; 346 347 ---------------------- 348 -- Print_Debug_Line -- 349 ---------------------- 350 351 procedure Print_Debug_Line (S : String) is 352 begin 353 Write_Debug_Line (S, Debug_Sloc); 354 end Print_Debug_Line; 355 356 --------------------------- 357 -- Process_TFAI_RR_Flags -- 358 --------------------------- 359 360 procedure Process_TFAI_RR_Flags (Nod : Node_Id) is 361 begin 362 if Treat_Fixed_As_Integer (Nod) then 363 Write_Char ('#'); 364 end if; 365 366 if Rounded_Result (Nod) then 367 Write_Char ('@'); 368 end if; 369 end Process_TFAI_RR_Flags; 370 371 -------- 372 -- ps -- 373 -------- 374 375 procedure ps (Node : Node_Id) is 376 begin 377 Dump_Generated_Only := False; 378 Dump_Original_Only := False; 379 Sprint_Node (Node); 380 Write_Eol; 381 end ps; 382 383 -------------------- 384 -- Set_Debug_Sloc -- 385 -------------------- 386 387 procedure Set_Debug_Sloc is 388 begin 389 if Present (Debug_Node) then 390 Set_Sloc (Debug_Node, Debug_Sloc + Source_Ptr (Column - 1)); 391 Debug_Node := Empty; 392 end if; 393 end Set_Debug_Sloc; 394 395 ----------------- 396 -- Source_Dump -- 397 ----------------- 398 399 procedure Source_Dump is 400 401 procedure Underline; 402 -- Put underline under string we just printed 403 404 procedure Underline is 405 Col : constant Int := Column; 406 407 begin 408 Write_Eol; 409 410 while Col > Column loop 411 Write_Char ('-'); 412 end loop; 413 414 Write_Eol; 415 end Underline; 416 417 -- Start of processing for Tree_Dump. 418 419 begin 420 Dump_Generated_Only := Debug_Flag_G or 421 Print_Generated_Code or 422 Debug_Generated_Code; 423 Dump_Original_Only := Debug_Flag_O; 424 Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G; 425 426 -- Note that we turn off the tree dump flags immediately, before 427 -- starting the dump. This avoids generating two copies of the dump 428 -- if an abort occurs after printing the dump, and more importantly, 429 -- avoids an infinite loop if an abort occurs during the dump. 430 431 if Debug_Flag_Z then 432 Debug_Flag_Z := False; 433 Write_Eol; 434 Write_Eol; 435 Write_Str ("Source recreated from tree of Standard (spec)"); 436 Underline; 437 Sprint_Node (Standard_Package_Node); 438 Write_Eol; 439 Write_Eol; 440 end if; 441 442 if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then 443 Debug_Flag_G := False; 444 Debug_Flag_O := False; 445 Debug_Flag_S := False; 446 447 -- Dump requested units 448 449 for U in Main_Unit .. Last_Unit loop 450 451 -- Dump all units if -gnatdf set, otherwise we dump only 452 -- the source files that are in the extended main source. 453 454 if Debug_Flag_F 455 or else In_Extended_Main_Source_Unit (Cunit_Entity (U)) 456 then 457 -- If we are generating debug files, setup to write them 458 459 if Debug_Generated_Code then 460 Set_Special_Output (Print_Debug_Line'Access); 461 Create_Debug_Source (Source_Index (U), Debug_Sloc); 462 Sprint_Node (Cunit (U)); 463 Write_Eol; 464 Close_Debug_Source; 465 Set_Special_Output (null); 466 467 -- Normal output to standard output file 468 469 else 470 Write_Str ("Source recreated from tree for "); 471 Write_Unit_Name (Unit_Name (U)); 472 Underline; 473 Sprint_Node (Cunit (U)); 474 Write_Eol; 475 Write_Eol; 476 end if; 477 end if; 478 end loop; 479 end if; 480 end Source_Dump; 481 482 --------------------- 483 -- Sprint_Bar_List -- 484 --------------------- 485 486 procedure Sprint_Bar_List (List : List_Id) is 487 Node : Node_Id; 488 489 begin 490 if Is_Non_Empty_List (List) then 491 Node := First (List); 492 493 loop 494 Sprint_Node (Node); 495 Next (Node); 496 exit when Node = Empty; 497 Write_Str (" | "); 498 end loop; 499 end if; 500 end Sprint_Bar_List; 501 502 ----------------------- 503 -- Sprint_Comma_List -- 504 ----------------------- 505 506 procedure Sprint_Comma_List (List : List_Id) is 507 Node : Node_Id; 508 509 begin 510 if Is_Non_Empty_List (List) then 511 Node := First (List); 512 513 loop 514 Sprint_Node (Node); 515 Next (Node); 516 exit when Node = Empty; 517 518 if not Is_Rewrite_Insertion (Node) 519 or else not Dump_Original_Only 520 then 521 Write_Str (", "); 522 end if; 523 524 end loop; 525 end if; 526 end Sprint_Comma_List; 527 528 -------------------------- 529 -- Sprint_Indented_List -- 530 -------------------------- 531 532 procedure Sprint_Indented_List (List : List_Id) is 533 begin 534 Indent_Begin; 535 Sprint_Node_List (List); 536 Indent_End; 537 end Sprint_Indented_List; 538 539 --------------------- 540 -- Sprint_Left_Opnd -- 541 --------------------- 542 543 procedure Sprint_Left_Opnd (N : Node_Id) is 544 Opnd : constant Node_Id := Left_Opnd (N); 545 546 begin 547 if Paren_Count (Opnd) /= 0 548 or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N)) 549 then 550 Sprint_Node (Opnd); 551 552 else 553 Write_Char ('('); 554 Sprint_Node (Opnd); 555 Write_Char (')'); 556 end if; 557 end Sprint_Left_Opnd; 558 559 ----------------- 560 -- Sprint_Node -- 561 ----------------- 562 563 procedure Sprint_Node (Node : Node_Id) is 564 begin 565 if Is_Rewrite_Insertion (Node) then 566 if not Dump_Original_Only then 567 568 -- For special cases of nodes that always output <<< >>> 569 -- do not duplicate the output at this point. 570 571 if Nkind (Node) = N_Freeze_Entity 572 or else Nkind (Node) = N_Implicit_Label_Declaration 573 then 574 Sprint_Node_Actual (Node); 575 576 -- Normal case where <<< >>> may be required 577 578 else 579 Write_Rewrite_Str ("<<<"); 580 Sprint_Node_Actual (Node); 581 Write_Rewrite_Str (">>>"); 582 end if; 583 end if; 584 585 elsif Is_Rewrite_Substitution (Node) then 586 587 -- Case of dump generated only 588 589 if Dump_Generated_Only then 590 Sprint_Node_Actual (Node); 591 592 -- Case of dump original only 593 594 elsif Dump_Original_Only then 595 Sprint_Node_Actual (Original_Node (Node)); 596 597 -- Case of both being dumped 598 599 else 600 Sprint_Node_Actual (Original_Node (Node)); 601 Write_Rewrite_Str ("<<<"); 602 Sprint_Node_Actual (Node); 603 Write_Rewrite_Str (">>>"); 604 end if; 605 606 else 607 Sprint_Node_Actual (Node); 608 end if; 609 end Sprint_Node; 610 611 ------------------------ 612 -- Sprint_Node_Actual -- 613 ------------------------ 614 615 procedure Sprint_Node_Actual (Node : Node_Id) is 616 Save_Debug_Node : constant Node_Id := Debug_Node; 617 618 begin 619 if Node = Empty then 620 return; 621 end if; 622 623 for J in 1 .. Paren_Count (Node) loop 624 Write_Str_With_Col_Check ("("); 625 end loop; 626 627 -- Setup node for Sloc fixup if writing a debug source file. Note 628 -- that we take care of any previous node not yet properly set. 629 630 if Debug_Generated_Code then 631 Debug_Node := Node; 632 end if; 633 634 if Nkind (Node) in N_Subexpr 635 and then Do_Range_Check (Node) 636 then 637 Write_Str_With_Col_Check ("{"); 638 end if; 639 640 -- Select print circuit based on node kind 641 642 case Nkind (Node) is 643 644 when N_Abort_Statement => 645 Write_Indent_Str_Sloc ("abort "); 646 Sprint_Comma_List (Names (Node)); 647 Write_Char (';'); 648 649 when N_Abortable_Part => 650 Set_Debug_Sloc; 651 Write_Str_Sloc ("abort "); 652 Sprint_Indented_List (Statements (Node)); 653 654 when N_Abstract_Subprogram_Declaration => 655 Write_Indent; 656 Sprint_Node (Specification (Node)); 657 Write_Str_With_Col_Check (" is "); 658 Write_Str_Sloc ("abstract;"); 659 660 when N_Accept_Alternative => 661 Sprint_Node_List (Pragmas_Before (Node)); 662 663 if Present (Condition (Node)) then 664 Write_Indent_Str ("when "); 665 Sprint_Node (Condition (Node)); 666 Write_Str (" => "); 667 Indent_Annull; 668 end if; 669 670 Sprint_Node_Sloc (Accept_Statement (Node)); 671 Sprint_Node_List (Statements (Node)); 672 673 when N_Accept_Statement => 674 Write_Indent_Str_Sloc ("accept "); 675 Write_Id (Entry_Direct_Name (Node)); 676 677 if Present (Entry_Index (Node)) then 678 Write_Str_With_Col_Check (" ("); 679 Sprint_Node (Entry_Index (Node)); 680 Write_Char (')'); 681 end if; 682 683 Write_Param_Specs (Node); 684 685 if Present (Handled_Statement_Sequence (Node)) then 686 Write_Str_With_Col_Check (" do"); 687 Sprint_Node (Handled_Statement_Sequence (Node)); 688 Write_Indent_Str ("end "); 689 Write_Id (Entry_Direct_Name (Node)); 690 end if; 691 692 Write_Char (';'); 693 694 when N_Access_Definition => 695 Write_Str_With_Col_Check_Sloc ("access "); 696 Sprint_Node (Subtype_Mark (Node)); 697 698 when N_Access_Function_Definition => 699 Write_Str_With_Col_Check_Sloc ("access "); 700 701 if Protected_Present (Node) then 702 Write_Str_With_Col_Check ("protected "); 703 end if; 704 705 Write_Str_With_Col_Check ("function"); 706 Write_Param_Specs (Node); 707 Write_Str_With_Col_Check (" return "); 708 Sprint_Node (Subtype_Mark (Node)); 709 710 when N_Access_Procedure_Definition => 711 Write_Str_With_Col_Check_Sloc ("access "); 712 713 if Protected_Present (Node) then 714 Write_Str_With_Col_Check ("protected "); 715 end if; 716 717 Write_Str_With_Col_Check ("procedure"); 718 Write_Param_Specs (Node); 719 720 when N_Access_To_Object_Definition => 721 Write_Str_With_Col_Check_Sloc ("access "); 722 723 if All_Present (Node) then 724 Write_Str_With_Col_Check ("all "); 725 elsif Constant_Present (Node) then 726 Write_Str_With_Col_Check ("constant "); 727 end if; 728 729 Sprint_Node (Subtype_Indication (Node)); 730 731 when N_Aggregate => 732 if Null_Record_Present (Node) then 733 Write_Str_With_Col_Check_Sloc ("(null record)"); 734 735 else 736 Write_Str_With_Col_Check_Sloc ("("); 737 738 if Present (Expressions (Node)) then 739 Sprint_Comma_List (Expressions (Node)); 740 741 if Present (Component_Associations (Node)) then 742 Write_Str (", "); 743 end if; 744 end if; 745 746 if Present (Component_Associations (Node)) then 747 Indent_Begin; 748 749 declare 750 Nd : Node_Id; 751 752 begin 753 Nd := First (Component_Associations (Node)); 754 755 loop 756 Write_Indent; 757 Sprint_Node (Nd); 758 Next (Nd); 759 exit when No (Nd); 760 761 if not Is_Rewrite_Insertion (Nd) 762 or else not Dump_Original_Only 763 then 764 Write_Str (", "); 765 end if; 766 end loop; 767 end; 768 769 Indent_End; 770 end if; 771 772 Write_Char (')'); 773 end if; 774 775 when N_Allocator => 776 Write_Str_With_Col_Check_Sloc ("new "); 777 Sprint_Node (Expression (Node)); 778 779 if Present (Storage_Pool (Node)) then 780 Write_Str_With_Col_Check ("[storage_pool = "); 781 Sprint_Node (Storage_Pool (Node)); 782 Write_Char (']'); 783 end if; 784 785 when N_And_Then => 786 Sprint_Left_Opnd (Node); 787 Write_Str_Sloc (" and then "); 788 Sprint_Right_Opnd (Node); 789 790 when N_At_Clause => 791 Write_Indent_Str_Sloc ("for "); 792 Write_Id (Identifier (Node)); 793 Write_Str_With_Col_Check (" use at "); 794 Sprint_Node (Expression (Node)); 795 Write_Char (';'); 796 797 when N_Assignment_Statement => 798 Write_Indent; 799 Sprint_Node (Name (Node)); 800 Write_Str_Sloc (" := "); 801 Sprint_Node (Expression (Node)); 802 Write_Char (';'); 803 804 when N_Asynchronous_Select => 805 Write_Indent_Str_Sloc ("select"); 806 Indent_Begin; 807 Sprint_Node (Triggering_Alternative (Node)); 808 Indent_End; 809 810 -- Note: let the printing of Abortable_Part handle outputting 811 -- the ABORT keyword, so that the Slco can be set correctly. 812 813 Write_Indent_Str ("then "); 814 Sprint_Node (Abortable_Part (Node)); 815 Write_Indent_Str ("end select;"); 816 817 when N_Attribute_Definition_Clause => 818 Write_Indent_Str_Sloc ("for "); 819 Sprint_Node (Name (Node)); 820 Write_Char ('''); 821 Write_Name_With_Col_Check (Chars (Node)); 822 Write_Str_With_Col_Check (" use "); 823 Sprint_Node (Expression (Node)); 824 Write_Char (';'); 825 826 when N_Attribute_Reference => 827 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then 828 Write_Indent; 829 end if; 830 831 Sprint_Node (Prefix (Node)); 832 Write_Char_Sloc ('''); 833 Write_Name_With_Col_Check (Attribute_Name (Node)); 834 Sprint_Paren_Comma_List (Expressions (Node)); 835 836 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then 837 Write_Char (';'); 838 end if; 839 840 when N_Block_Statement => 841 Write_Indent; 842 843 if Present (Identifier (Node)) 844 and then (not Has_Created_Identifier (Node) 845 or else not Dump_Original_Only) 846 then 847 Write_Rewrite_Str ("<<<"); 848 Write_Id (Identifier (Node)); 849 Write_Str (" : "); 850 Write_Rewrite_Str (">>>"); 851 end if; 852 853 if Present (Declarations (Node)) then 854 Write_Str_With_Col_Check_Sloc ("declare"); 855 Sprint_Indented_List (Declarations (Node)); 856 Write_Indent; 857 end if; 858 859 Write_Str_With_Col_Check_Sloc ("begin"); 860 Sprint_Node (Handled_Statement_Sequence (Node)); 861 Write_Indent_Str ("end"); 862 863 if Present (Identifier (Node)) 864 and then (not Has_Created_Identifier (Node) 865 or else not Dump_Original_Only) 866 then 867 Write_Rewrite_Str ("<<<"); 868 Write_Char (' '); 869 Write_Id (Identifier (Node)); 870 Write_Rewrite_Str (">>>"); 871 end if; 872 873 Write_Char (';'); 874 875 when N_Case_Statement => 876 Write_Indent_Str_Sloc ("case "); 877 Sprint_Node (Expression (Node)); 878 Write_Str (" is"); 879 Sprint_Indented_List (Alternatives (Node)); 880 Write_Indent_Str ("end case;"); 881 882 when N_Case_Statement_Alternative => 883 Write_Indent_Str_Sloc ("when "); 884 Sprint_Bar_List (Discrete_Choices (Node)); 885 Write_Str (" => "); 886 Sprint_Indented_List (Statements (Node)); 887 888 when N_Character_Literal => 889 if Column > 70 then 890 Write_Indent_Str (" "); 891 end if; 892 893 Write_Char_Sloc ('''); 894 Write_Char_Code (Char_Literal_Value (Node)); 895 Write_Char ('''); 896 897 when N_Code_Statement => 898 Write_Indent; 899 Set_Debug_Sloc; 900 Sprint_Node (Expression (Node)); 901 Write_Char (';'); 902 903 when N_Compilation_Unit => 904 Sprint_Node_List (Context_Items (Node)); 905 Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node))); 906 907 if Private_Present (Node) then 908 Write_Indent_Str ("private "); 909 Indent_Annull; 910 end if; 911 912 Sprint_Node_Sloc (Unit (Node)); 913 914 if Present (Actions (Aux_Decls_Node (Node))) 915 or else 916 Present (Pragmas_After (Aux_Decls_Node (Node))) 917 then 918 Write_Indent; 919 end if; 920 921 Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node))); 922 Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node))); 923 924 when N_Compilation_Unit_Aux => 925 null; -- nothing to do, never used, see above 926 927 when N_Component_Association => 928 Set_Debug_Sloc; 929 Sprint_Bar_List (Choices (Node)); 930 Write_Str (" => "); 931 932 -- Ada0Y (AI-287): Print the mbox if present 933 934 if Box_Present (Node) then 935 Write_Str_With_Col_Check ("<>"); 936 else 937 Sprint_Node (Expression (Node)); 938 end if; 939 940 when N_Component_Clause => 941 Write_Indent; 942 Sprint_Node (Component_Name (Node)); 943 Write_Str_Sloc (" at "); 944 Sprint_Node (Position (Node)); 945 Write_Char (' '); 946 Write_Str_With_Col_Check ("range "); 947 Sprint_Node (First_Bit (Node)); 948 Write_Str (" .. "); 949 Sprint_Node (Last_Bit (Node)); 950 Write_Char (';'); 951 952 when N_Component_Definition => 953 Set_Debug_Sloc; 954 955 if Aliased_Present (Node) then 956 Write_Str_With_Col_Check ("aliased "); 957 end if; 958 959 Sprint_Node (Subtype_Indication (Node)); 960 961 when N_Component_Declaration => 962 if Write_Indent_Identifiers_Sloc (Node) then 963 Write_Str (" : "); 964 Sprint_Node (Component_Definition (Node)); 965 966 if Present (Expression (Node)) then 967 Write_Str (" := "); 968 Sprint_Node (Expression (Node)); 969 end if; 970 971 Write_Char (';'); 972 end if; 973 974 when N_Component_List => 975 if Null_Present (Node) then 976 Indent_Begin; 977 Write_Indent_Str_Sloc ("null"); 978 Write_Char (';'); 979 Indent_End; 980 981 else 982 Set_Debug_Sloc; 983 Sprint_Indented_List (Component_Items (Node)); 984 Sprint_Node (Variant_Part (Node)); 985 end if; 986 987 when N_Conditional_Entry_Call => 988 Write_Indent_Str_Sloc ("select"); 989 Indent_Begin; 990 Sprint_Node (Entry_Call_Alternative (Node)); 991 Indent_End; 992 Write_Indent_Str ("else"); 993 Sprint_Indented_List (Else_Statements (Node)); 994 Write_Indent_Str ("end select;"); 995 996 when N_Conditional_Expression => 997 declare 998 Condition : constant Node_Id := First (Expressions (Node)); 999 Then_Expr : constant Node_Id := Next (Condition); 1000 Else_Expr : constant Node_Id := Next (Then_Expr); 1001 1002 begin 1003 Write_Str_With_Col_Check_Sloc ("(if "); 1004 Sprint_Node (Condition); 1005 Write_Str_With_Col_Check (" then "); 1006 Sprint_Node (Then_Expr); 1007 Write_Str_With_Col_Check (" else "); 1008 Sprint_Node (Else_Expr); 1009 Write_Char (')'); 1010 end; 1011 1012 when N_Constrained_Array_Definition => 1013 Write_Str_With_Col_Check_Sloc ("array "); 1014 Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node)); 1015 Write_Str (" of "); 1016 1017 Sprint_Node (Component_Definition (Node)); 1018 1019 when N_Decimal_Fixed_Point_Definition => 1020 Write_Str_With_Col_Check_Sloc (" delta "); 1021 Sprint_Node (Delta_Expression (Node)); 1022 Write_Str_With_Col_Check ("digits "); 1023 Sprint_Node (Digits_Expression (Node)); 1024 Sprint_Opt_Node (Real_Range_Specification (Node)); 1025 1026 when N_Defining_Character_Literal => 1027 Write_Name_With_Col_Check_Sloc (Chars (Node)); 1028 1029 when N_Defining_Identifier => 1030 Set_Debug_Sloc; 1031 Write_Id (Node); 1032 1033 when N_Defining_Operator_Symbol => 1034 Write_Name_With_Col_Check_Sloc (Chars (Node)); 1035 1036 when N_Defining_Program_Unit_Name => 1037 Set_Debug_Sloc; 1038 Sprint_Node (Name (Node)); 1039 Write_Char ('.'); 1040 Write_Id (Defining_Identifier (Node)); 1041 1042 when N_Delay_Alternative => 1043 Sprint_Node_List (Pragmas_Before (Node)); 1044 1045 if Present (Condition (Node)) then 1046 Write_Indent; 1047 Write_Str_With_Col_Check ("when "); 1048 Sprint_Node (Condition (Node)); 1049 Write_Str (" => "); 1050 Indent_Annull; 1051 end if; 1052 1053 Sprint_Node_Sloc (Delay_Statement (Node)); 1054 Sprint_Node_List (Statements (Node)); 1055 1056 when N_Delay_Relative_Statement => 1057 Write_Indent_Str_Sloc ("delay "); 1058 Sprint_Node (Expression (Node)); 1059 Write_Char (';'); 1060 1061 when N_Delay_Until_Statement => 1062 Write_Indent_Str_Sloc ("delay until "); 1063 Sprint_Node (Expression (Node)); 1064 Write_Char (';'); 1065 1066 when N_Delta_Constraint => 1067 Write_Str_With_Col_Check_Sloc ("delta "); 1068 Sprint_Node (Delta_Expression (Node)); 1069 Sprint_Opt_Node (Range_Constraint (Node)); 1070 1071 when N_Derived_Type_Definition => 1072 if Abstract_Present (Node) then 1073 Write_Str_With_Col_Check ("abstract "); 1074 end if; 1075 1076 Write_Str_With_Col_Check_Sloc ("new "); 1077 Sprint_Node (Subtype_Indication (Node)); 1078 1079 if Present (Record_Extension_Part (Node)) then 1080 Write_Str_With_Col_Check (" with "); 1081 Sprint_Node (Record_Extension_Part (Node)); 1082 end if; 1083 1084 when N_Designator => 1085 Sprint_Node (Name (Node)); 1086 Write_Char_Sloc ('.'); 1087 Write_Id (Identifier (Node)); 1088 1089 when N_Digits_Constraint => 1090 Write_Str_With_Col_Check_Sloc ("digits "); 1091 Sprint_Node (Digits_Expression (Node)); 1092 Sprint_Opt_Node (Range_Constraint (Node)); 1093 1094 when N_Discriminant_Association => 1095 Set_Debug_Sloc; 1096 1097 if Present (Selector_Names (Node)) then 1098 Sprint_Bar_List (Selector_Names (Node)); 1099 Write_Str (" => "); 1100 end if; 1101 1102 Set_Debug_Sloc; 1103 Sprint_Node (Expression (Node)); 1104 1105 when N_Discriminant_Specification => 1106 Set_Debug_Sloc; 1107 1108 if Write_Identifiers (Node) then 1109 Write_Str (" : "); 1110 Sprint_Node (Discriminant_Type (Node)); 1111 1112 if Present (Expression (Node)) then 1113 Write_Str (" := "); 1114 Sprint_Node (Expression (Node)); 1115 end if; 1116 else 1117 Write_Str (", "); 1118 end if; 1119 1120 when N_Elsif_Part => 1121 Write_Indent_Str_Sloc ("elsif "); 1122 Sprint_Node (Condition (Node)); 1123 Write_Str_With_Col_Check (" then"); 1124 Sprint_Indented_List (Then_Statements (Node)); 1125 1126 when N_Empty => 1127 null; 1128 1129 when N_Entry_Body => 1130 Write_Indent_Str_Sloc ("entry "); 1131 Write_Id (Defining_Identifier (Node)); 1132 Sprint_Node (Entry_Body_Formal_Part (Node)); 1133 Write_Str_With_Col_Check (" is"); 1134 Sprint_Indented_List (Declarations (Node)); 1135 Write_Indent_Str ("begin"); 1136 Sprint_Node (Handled_Statement_Sequence (Node)); 1137 Write_Indent_Str ("end "); 1138 Write_Id (Defining_Identifier (Node)); 1139 Write_Char (';'); 1140 1141 when N_Entry_Body_Formal_Part => 1142 if Present (Entry_Index_Specification (Node)) then 1143 Write_Str_With_Col_Check_Sloc (" ("); 1144 Sprint_Node (Entry_Index_Specification (Node)); 1145 Write_Char (')'); 1146 end if; 1147 1148 Write_Param_Specs (Node); 1149 Write_Str_With_Col_Check_Sloc (" when "); 1150 Sprint_Node (Condition (Node)); 1151 1152 when N_Entry_Call_Alternative => 1153 Sprint_Node_List (Pragmas_Before (Node)); 1154 Sprint_Node_Sloc (Entry_Call_Statement (Node)); 1155 Sprint_Node_List (Statements (Node)); 1156 1157 when N_Entry_Call_Statement => 1158 Write_Indent; 1159 Sprint_Node_Sloc (Name (Node)); 1160 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); 1161 Write_Char (';'); 1162 1163 when N_Entry_Declaration => 1164 Write_Indent_Str_Sloc ("entry "); 1165 Write_Id (Defining_Identifier (Node)); 1166 1167 if Present (Discrete_Subtype_Definition (Node)) then 1168 Write_Str_With_Col_Check (" ("); 1169 Sprint_Node (Discrete_Subtype_Definition (Node)); 1170 Write_Char (')'); 1171 end if; 1172 1173 Write_Param_Specs (Node); 1174 Write_Char (';'); 1175 1176 when N_Entry_Index_Specification => 1177 Write_Str_With_Col_Check_Sloc ("for "); 1178 Write_Id (Defining_Identifier (Node)); 1179 Write_Str_With_Col_Check (" in "); 1180 Sprint_Node (Discrete_Subtype_Definition (Node)); 1181 1182 when N_Enumeration_Representation_Clause => 1183 Write_Indent_Str_Sloc ("for "); 1184 Write_Id (Identifier (Node)); 1185 Write_Str_With_Col_Check (" use "); 1186 Sprint_Node (Array_Aggregate (Node)); 1187 Write_Char (';'); 1188 1189 when N_Enumeration_Type_Definition => 1190 Set_Debug_Sloc; 1191 1192 -- Skip attempt to print Literals field if it's not there and 1193 -- we are in package Standard (case of Character, which is 1194 -- handled specially (without an explicit literals list). 1195 1196 if Sloc (Node) > Standard_Location 1197 or else Present (Literals (Node)) 1198 then 1199 Sprint_Paren_Comma_List (Literals (Node)); 1200 end if; 1201 1202 when N_Error => 1203 Write_Str_With_Col_Check_Sloc ("<error>"); 1204 1205 when N_Exception_Declaration => 1206 if Write_Indent_Identifiers (Node) then 1207 Write_Str_With_Col_Check (" : "); 1208 Write_Str_Sloc ("exception;"); 1209 end if; 1210 1211 when N_Exception_Handler => 1212 Write_Indent_Str_Sloc ("when "); 1213 1214 if Present (Choice_Parameter (Node)) then 1215 Sprint_Node (Choice_Parameter (Node)); 1216 Write_Str (" : "); 1217 end if; 1218 1219 Sprint_Bar_List (Exception_Choices (Node)); 1220 Write_Str (" => "); 1221 Sprint_Indented_List (Statements (Node)); 1222 1223 when N_Exception_Renaming_Declaration => 1224 Write_Indent; 1225 Set_Debug_Sloc; 1226 Sprint_Node (Defining_Identifier (Node)); 1227 Write_Str_With_Col_Check (" : exception renames "); 1228 Sprint_Node (Name (Node)); 1229 Write_Char (';'); 1230 1231 when N_Exit_Statement => 1232 Write_Indent_Str_Sloc ("exit"); 1233 Sprint_Opt_Node (Name (Node)); 1234 1235 if Present (Condition (Node)) then 1236 Write_Str_With_Col_Check (" when "); 1237 Sprint_Node (Condition (Node)); 1238 end if; 1239 1240 Write_Char (';'); 1241 1242 when N_Expanded_Name => 1243 Sprint_Node (Prefix (Node)); 1244 Write_Char_Sloc ('.'); 1245 Sprint_Node (Selector_Name (Node)); 1246 1247 when N_Explicit_Dereference => 1248 Sprint_Node (Prefix (Node)); 1249 Write_Char_Sloc ('.'); 1250 Write_Str_Sloc ("all"); 1251 1252 when N_Extension_Aggregate => 1253 Write_Str_With_Col_Check_Sloc ("("); 1254 Sprint_Node (Ancestor_Part (Node)); 1255 Write_Str_With_Col_Check (" with "); 1256 1257 if Null_Record_Present (Node) then 1258 Write_Str_With_Col_Check ("null record"); 1259 else 1260 if Present (Expressions (Node)) then 1261 Sprint_Comma_List (Expressions (Node)); 1262 1263 if Present (Component_Associations (Node)) then 1264 Write_Str (", "); 1265 end if; 1266 end if; 1267 1268 if Present (Component_Associations (Node)) then 1269 Sprint_Comma_List (Component_Associations (Node)); 1270 end if; 1271 end if; 1272 1273 Write_Char (')'); 1274 1275 when N_Floating_Point_Definition => 1276 Write_Str_With_Col_Check_Sloc ("digits "); 1277 Sprint_Node (Digits_Expression (Node)); 1278 Sprint_Opt_Node (Real_Range_Specification (Node)); 1279 1280 when N_Formal_Decimal_Fixed_Point_Definition => 1281 Write_Str_With_Col_Check_Sloc ("delta <> digits <>"); 1282 1283 when N_Formal_Derived_Type_Definition => 1284 Write_Str_With_Col_Check_Sloc ("new "); 1285 Sprint_Node (Subtype_Mark (Node)); 1286 1287 if Private_Present (Node) then 1288 Write_Str_With_Col_Check (" with private"); 1289 end if; 1290 1291 when N_Formal_Discrete_Type_Definition => 1292 Write_Str_With_Col_Check_Sloc ("<>"); 1293 1294 when N_Formal_Floating_Point_Definition => 1295 Write_Str_With_Col_Check_Sloc ("digits <>"); 1296 1297 when N_Formal_Modular_Type_Definition => 1298 Write_Str_With_Col_Check_Sloc ("mod <>"); 1299 1300 when N_Formal_Object_Declaration => 1301 Set_Debug_Sloc; 1302 1303 if Write_Indent_Identifiers (Node) then 1304 Write_Str (" : "); 1305 1306 if In_Present (Node) then 1307 Write_Str_With_Col_Check ("in "); 1308 end if; 1309 1310 if Out_Present (Node) then 1311 Write_Str_With_Col_Check ("out "); 1312 end if; 1313 1314 Sprint_Node (Subtype_Mark (Node)); 1315 1316 if Present (Expression (Node)) then 1317 Write_Str (" := "); 1318 Sprint_Node (Expression (Node)); 1319 end if; 1320 1321 Write_Char (';'); 1322 end if; 1323 1324 when N_Formal_Ordinary_Fixed_Point_Definition => 1325 Write_Str_With_Col_Check_Sloc ("delta <>"); 1326 1327 when N_Formal_Package_Declaration => 1328 Write_Indent_Str_Sloc ("with package "); 1329 Write_Id (Defining_Identifier (Node)); 1330 Write_Str_With_Col_Check (" is new "); 1331 Sprint_Node (Name (Node)); 1332 Write_Str_With_Col_Check (" (<>);"); 1333 1334 when N_Formal_Private_Type_Definition => 1335 if Abstract_Present (Node) then 1336 Write_Str_With_Col_Check ("abstract "); 1337 end if; 1338 1339 if Tagged_Present (Node) then 1340 Write_Str_With_Col_Check ("tagged "); 1341 end if; 1342 1343 if Limited_Present (Node) then 1344 Write_Str_With_Col_Check ("limited "); 1345 end if; 1346 1347 Write_Str_With_Col_Check_Sloc ("private"); 1348 1349 when N_Formal_Signed_Integer_Type_Definition => 1350 Write_Str_With_Col_Check_Sloc ("range <>"); 1351 1352 when N_Formal_Subprogram_Declaration => 1353 Write_Indent_Str_Sloc ("with "); 1354 Sprint_Node (Specification (Node)); 1355 1356 if Box_Present (Node) then 1357 Write_Str_With_Col_Check (" is <>"); 1358 elsif Present (Default_Name (Node)) then 1359 Write_Str_With_Col_Check (" is "); 1360 Sprint_Node (Default_Name (Node)); 1361 end if; 1362 1363 Write_Char (';'); 1364 1365 when N_Formal_Type_Declaration => 1366 Write_Indent_Str_Sloc ("type "); 1367 Write_Id (Defining_Identifier (Node)); 1368 1369 if Present (Discriminant_Specifications (Node)) then 1370 Write_Discr_Specs (Node); 1371 elsif Unknown_Discriminants_Present (Node) then 1372 Write_Str_With_Col_Check ("(<>)"); 1373 end if; 1374 1375 Write_Str_With_Col_Check (" is "); 1376 Sprint_Node (Formal_Type_Definition (Node)); 1377 Write_Char (';'); 1378 1379 when N_Free_Statement => 1380 Write_Indent_Str_Sloc ("free "); 1381 Sprint_Node (Expression (Node)); 1382 Write_Char (';'); 1383 1384 when N_Freeze_Entity => 1385 if Dump_Original_Only then 1386 null; 1387 1388 elsif Present (Actions (Node)) or else Dump_Freeze_Null then 1389 Write_Indent; 1390 Write_Rewrite_Str ("<<<"); 1391 Write_Str_With_Col_Check_Sloc ("freeze "); 1392 Write_Id (Entity (Node)); 1393 Write_Str (" ["); 1394 1395 if No (Actions (Node)) then 1396 Write_Char (']'); 1397 1398 else 1399 Freeze_Indent := Freeze_Indent + 1; 1400 Sprint_Indented_List (Actions (Node)); 1401 Freeze_Indent := Freeze_Indent - 1; 1402 Write_Indent_Str ("]"); 1403 end if; 1404 1405 Write_Rewrite_Str (">>>"); 1406 end if; 1407 1408 when N_Full_Type_Declaration => 1409 Write_Indent_Str_Sloc ("type "); 1410 Write_Id (Defining_Identifier (Node)); 1411 Write_Discr_Specs (Node); 1412 Write_Str_With_Col_Check (" is "); 1413 Sprint_Node (Type_Definition (Node)); 1414 Write_Char (';'); 1415 1416 when N_Function_Call => 1417 Set_Debug_Sloc; 1418 Sprint_Node (Name (Node)); 1419 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); 1420 1421 when N_Function_Instantiation => 1422 Write_Indent_Str_Sloc ("function "); 1423 Sprint_Node (Defining_Unit_Name (Node)); 1424 Write_Str_With_Col_Check (" is new "); 1425 Sprint_Node (Name (Node)); 1426 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); 1427 Write_Char (';'); 1428 1429 when N_Function_Specification => 1430 Write_Str_With_Col_Check_Sloc ("function "); 1431 Sprint_Node (Defining_Unit_Name (Node)); 1432 Write_Param_Specs (Node); 1433 Write_Str_With_Col_Check (" return "); 1434 Sprint_Node (Subtype_Mark (Node)); 1435 1436 when N_Generic_Association => 1437 Set_Debug_Sloc; 1438 1439 if Present (Selector_Name (Node)) then 1440 Sprint_Node (Selector_Name (Node)); 1441 Write_Str (" => "); 1442 end if; 1443 1444 Sprint_Node (Explicit_Generic_Actual_Parameter (Node)); 1445 1446 when N_Generic_Function_Renaming_Declaration => 1447 Write_Indent_Str_Sloc ("generic function "); 1448 Sprint_Node (Defining_Unit_Name (Node)); 1449 Write_Str_With_Col_Check (" renames "); 1450 Sprint_Node (Name (Node)); 1451 Write_Char (';'); 1452 1453 when N_Generic_Package_Declaration => 1454 Write_Indent; 1455 Write_Indent_Str_Sloc ("generic "); 1456 Sprint_Indented_List (Generic_Formal_Declarations (Node)); 1457 Write_Indent; 1458 Sprint_Node (Specification (Node)); 1459 Write_Char (';'); 1460 1461 when N_Generic_Package_Renaming_Declaration => 1462 Write_Indent_Str_Sloc ("generic package "); 1463 Sprint_Node (Defining_Unit_Name (Node)); 1464 Write_Str_With_Col_Check (" renames "); 1465 Sprint_Node (Name (Node)); 1466 Write_Char (';'); 1467 1468 when N_Generic_Procedure_Renaming_Declaration => 1469 Write_Indent_Str_Sloc ("generic procedure "); 1470 Sprint_Node (Defining_Unit_Name (Node)); 1471 Write_Str_With_Col_Check (" renames "); 1472 Sprint_Node (Name (Node)); 1473 Write_Char (';'); 1474 1475 when N_Generic_Subprogram_Declaration => 1476 Write_Indent; 1477 Write_Indent_Str_Sloc ("generic "); 1478 Sprint_Indented_List (Generic_Formal_Declarations (Node)); 1479 Write_Indent; 1480 Sprint_Node (Specification (Node)); 1481 Write_Char (';'); 1482 1483 when N_Goto_Statement => 1484 Write_Indent_Str_Sloc ("goto "); 1485 Sprint_Node (Name (Node)); 1486 Write_Char (';'); 1487 1488 if Nkind (Next (Node)) = N_Label then 1489 Write_Indent; 1490 end if; 1491 1492 when N_Handled_Sequence_Of_Statements => 1493 Set_Debug_Sloc; 1494 Sprint_Indented_List (Statements (Node)); 1495 1496 if Present (Exception_Handlers (Node)) then 1497 Write_Indent_Str ("exception"); 1498 Indent_Begin; 1499 Sprint_Node_List (Exception_Handlers (Node)); 1500 Indent_End; 1501 end if; 1502 1503 if Present (At_End_Proc (Node)) then 1504 Write_Indent_Str ("at end"); 1505 Indent_Begin; 1506 Write_Indent; 1507 Sprint_Node (At_End_Proc (Node)); 1508 Write_Char (';'); 1509 Indent_End; 1510 end if; 1511 1512 when N_Identifier => 1513 Set_Debug_Sloc; 1514 Write_Id (Node); 1515 1516 when N_If_Statement => 1517 Write_Indent_Str_Sloc ("if "); 1518 Sprint_Node (Condition (Node)); 1519 Write_Str_With_Col_Check (" then"); 1520 Sprint_Indented_List (Then_Statements (Node)); 1521 Sprint_Opt_Node_List (Elsif_Parts (Node)); 1522 1523 if Present (Else_Statements (Node)) then 1524 Write_Indent_Str ("else"); 1525 Sprint_Indented_List (Else_Statements (Node)); 1526 end if; 1527 1528 Write_Indent_Str ("end if;"); 1529 1530 when N_Implicit_Label_Declaration => 1531 if not Dump_Original_Only then 1532 Write_Indent; 1533 Write_Rewrite_Str ("<<<"); 1534 Set_Debug_Sloc; 1535 Write_Id (Defining_Identifier (Node)); 1536 Write_Str (" : "); 1537 Write_Str_With_Col_Check ("label"); 1538 Write_Rewrite_Str (">>>"); 1539 end if; 1540 1541 when N_In => 1542 Sprint_Left_Opnd (Node); 1543 Write_Str_Sloc (" in "); 1544 Sprint_Right_Opnd (Node); 1545 1546 when N_Incomplete_Type_Declaration => 1547 Write_Indent_Str_Sloc ("type "); 1548 Write_Id (Defining_Identifier (Node)); 1549 1550 if Present (Discriminant_Specifications (Node)) then 1551 Write_Discr_Specs (Node); 1552 elsif Unknown_Discriminants_Present (Node) then 1553 Write_Str_With_Col_Check ("(<>)"); 1554 end if; 1555 1556 Write_Char (';'); 1557 1558 when N_Index_Or_Discriminant_Constraint => 1559 Set_Debug_Sloc; 1560 Sprint_Paren_Comma_List (Constraints (Node)); 1561 1562 when N_Indexed_Component => 1563 Sprint_Node_Sloc (Prefix (Node)); 1564 Sprint_Opt_Paren_Comma_List (Expressions (Node)); 1565 1566 when N_Integer_Literal => 1567 if Print_In_Hex (Node) then 1568 Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex); 1569 else 1570 Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto); 1571 end if; 1572 1573 when N_Iteration_Scheme => 1574 if Present (Condition (Node)) then 1575 Write_Str_With_Col_Check_Sloc ("while "); 1576 Sprint_Node (Condition (Node)); 1577 else 1578 Write_Str_With_Col_Check_Sloc ("for "); 1579 Sprint_Node (Loop_Parameter_Specification (Node)); 1580 end if; 1581 1582 Write_Char (' '); 1583 1584 when N_Itype_Reference => 1585 Write_Indent_Str_Sloc ("reference "); 1586 Write_Id (Itype (Node)); 1587 1588 when N_Label => 1589 Write_Indent_Str_Sloc ("<<"); 1590 Write_Id (Identifier (Node)); 1591 Write_Str (">>"); 1592 1593 when N_Loop_Parameter_Specification => 1594 Set_Debug_Sloc; 1595 Write_Id (Defining_Identifier (Node)); 1596 Write_Str_With_Col_Check (" in "); 1597 1598 if Reverse_Present (Node) then 1599 Write_Str_With_Col_Check ("reverse "); 1600 end if; 1601 1602 Sprint_Node (Discrete_Subtype_Definition (Node)); 1603 1604 when N_Loop_Statement => 1605 Write_Indent; 1606 1607 if Present (Identifier (Node)) 1608 and then (not Has_Created_Identifier (Node) 1609 or else not Dump_Original_Only) 1610 then 1611 Write_Rewrite_Str ("<<<"); 1612 Write_Id (Identifier (Node)); 1613 Write_Str (" : "); 1614 Write_Rewrite_Str (">>>"); 1615 Sprint_Node (Iteration_Scheme (Node)); 1616 Write_Str_With_Col_Check_Sloc ("loop"); 1617 Sprint_Indented_List (Statements (Node)); 1618 Write_Indent_Str ("end loop "); 1619 Write_Rewrite_Str ("<<<"); 1620 Write_Id (Identifier (Node)); 1621 Write_Rewrite_Str (">>>"); 1622 Write_Char (';'); 1623 1624 else 1625 Sprint_Node (Iteration_Scheme (Node)); 1626 Write_Str_With_Col_Check_Sloc ("loop"); 1627 Sprint_Indented_List (Statements (Node)); 1628 Write_Indent_Str ("end loop;"); 1629 end if; 1630 1631 when N_Mod_Clause => 1632 Sprint_Node_List (Pragmas_Before (Node)); 1633 Write_Str_With_Col_Check_Sloc ("at mod "); 1634 Sprint_Node (Expression (Node)); 1635 1636 when N_Modular_Type_Definition => 1637 Write_Str_With_Col_Check_Sloc ("mod "); 1638 Sprint_Node (Expression (Node)); 1639 1640 when N_Not_In => 1641 Sprint_Left_Opnd (Node); 1642 Write_Str_Sloc (" not in "); 1643 Sprint_Right_Opnd (Node); 1644 1645 when N_Null => 1646 Write_Str_With_Col_Check_Sloc ("null"); 1647 1648 when N_Null_Statement => 1649 if Comes_From_Source (Node) 1650 or else Dump_Freeze_Null 1651 or else not Is_List_Member (Node) 1652 or else (No (Prev (Node)) and then No (Next (Node))) 1653 then 1654 Write_Indent_Str_Sloc ("null;"); 1655 end if; 1656 1657 when N_Number_Declaration => 1658 Set_Debug_Sloc; 1659 1660 if Write_Indent_Identifiers (Node) then 1661 Write_Str_With_Col_Check (" : constant "); 1662 Write_Str (" := "); 1663 Sprint_Node (Expression (Node)); 1664 Write_Char (';'); 1665 end if; 1666 1667 when N_Object_Declaration => 1668 Set_Debug_Sloc; 1669 1670 if Write_Indent_Identifiers (Node) then 1671 Write_Str (" : "); 1672 1673 if Aliased_Present (Node) then 1674 Write_Str_With_Col_Check ("aliased "); 1675 end if; 1676 1677 if Constant_Present (Node) then 1678 Write_Str_With_Col_Check ("constant "); 1679 end if; 1680 1681 Sprint_Node (Object_Definition (Node)); 1682 1683 if Present (Expression (Node)) then 1684 Write_Str (" := "); 1685 Sprint_Node (Expression (Node)); 1686 end if; 1687 1688 Write_Char (';'); 1689 end if; 1690 1691 when N_Object_Renaming_Declaration => 1692 Write_Indent; 1693 Set_Debug_Sloc; 1694 Sprint_Node (Defining_Identifier (Node)); 1695 Write_Str (" : "); 1696 Sprint_Node (Subtype_Mark (Node)); 1697 Write_Str_With_Col_Check (" renames "); 1698 Sprint_Node (Name (Node)); 1699 Write_Char (';'); 1700 1701 when N_Op_Abs => 1702 Write_Operator (Node, "abs "); 1703 Sprint_Right_Opnd (Node); 1704 1705 when N_Op_Add => 1706 Sprint_Left_Opnd (Node); 1707 Write_Operator (Node, " + "); 1708 Sprint_Right_Opnd (Node); 1709 1710 when N_Op_And => 1711 Sprint_Left_Opnd (Node); 1712 Write_Operator (Node, " and "); 1713 Sprint_Right_Opnd (Node); 1714 1715 when N_Op_Concat => 1716 Sprint_Left_Opnd (Node); 1717 Write_Operator (Node, " & "); 1718 Sprint_Right_Opnd (Node); 1719 1720 when N_Op_Divide => 1721 Sprint_Left_Opnd (Node); 1722 Write_Char (' '); 1723 Process_TFAI_RR_Flags (Node); 1724 Write_Operator (Node, "/ "); 1725 Sprint_Right_Opnd (Node); 1726 1727 when N_Op_Eq => 1728 Sprint_Left_Opnd (Node); 1729 Write_Operator (Node, " = "); 1730 Sprint_Right_Opnd (Node); 1731 1732 when N_Op_Expon => 1733 Sprint_Left_Opnd (Node); 1734 Write_Operator (Node, " ** "); 1735 Sprint_Right_Opnd (Node); 1736 1737 when N_Op_Ge => 1738 Sprint_Left_Opnd (Node); 1739 Write_Operator (Node, " >= "); 1740 Sprint_Right_Opnd (Node); 1741 1742 when N_Op_Gt => 1743 Sprint_Left_Opnd (Node); 1744 Write_Operator (Node, " > "); 1745 Sprint_Right_Opnd (Node); 1746 1747 when N_Op_Le => 1748 Sprint_Left_Opnd (Node); 1749 Write_Operator (Node, " <= "); 1750 Sprint_Right_Opnd (Node); 1751 1752 when N_Op_Lt => 1753 Sprint_Left_Opnd (Node); 1754 Write_Operator (Node, " < "); 1755 Sprint_Right_Opnd (Node); 1756 1757 when N_Op_Minus => 1758 Write_Operator (Node, "-"); 1759 Sprint_Right_Opnd (Node); 1760 1761 when N_Op_Mod => 1762 Sprint_Left_Opnd (Node); 1763 1764 if Treat_Fixed_As_Integer (Node) then 1765 Write_Str (" #"); 1766 end if; 1767 1768 Write_Operator (Node, " mod "); 1769 Sprint_Right_Opnd (Node); 1770 1771 when N_Op_Multiply => 1772 Sprint_Left_Opnd (Node); 1773 Write_Char (' '); 1774 Process_TFAI_RR_Flags (Node); 1775 Write_Operator (Node, "* "); 1776 Sprint_Right_Opnd (Node); 1777 1778 when N_Op_Ne => 1779 Sprint_Left_Opnd (Node); 1780 Write_Operator (Node, " /= "); 1781 Sprint_Right_Opnd (Node); 1782 1783 when N_Op_Not => 1784 Write_Operator (Node, "not "); 1785 Sprint_Right_Opnd (Node); 1786 1787 when N_Op_Or => 1788 Sprint_Left_Opnd (Node); 1789 Write_Operator (Node, " or "); 1790 Sprint_Right_Opnd (Node); 1791 1792 when N_Op_Plus => 1793 Write_Operator (Node, "+"); 1794 Sprint_Right_Opnd (Node); 1795 1796 when N_Op_Rem => 1797 Sprint_Left_Opnd (Node); 1798 1799 if Treat_Fixed_As_Integer (Node) then 1800 Write_Str (" #"); 1801 end if; 1802 1803 Write_Operator (Node, " rem "); 1804 Sprint_Right_Opnd (Node); 1805 1806 when N_Op_Shift => 1807 Set_Debug_Sloc; 1808 Write_Id (Node); 1809 Write_Char ('!'); 1810 Write_Str_With_Col_Check ("("); 1811 Sprint_Node (Left_Opnd (Node)); 1812 Write_Str (", "); 1813 Sprint_Node (Right_Opnd (Node)); 1814 Write_Char (')'); 1815 1816 when N_Op_Subtract => 1817 Sprint_Left_Opnd (Node); 1818 Write_Operator (Node, " - "); 1819 Sprint_Right_Opnd (Node); 1820 1821 when N_Op_Xor => 1822 Sprint_Left_Opnd (Node); 1823 Write_Operator (Node, " xor "); 1824 Sprint_Right_Opnd (Node); 1825 1826 when N_Operator_Symbol => 1827 Write_Name_With_Col_Check_Sloc (Chars (Node)); 1828 1829 when N_Ordinary_Fixed_Point_Definition => 1830 Write_Str_With_Col_Check_Sloc ("delta "); 1831 Sprint_Node (Delta_Expression (Node)); 1832 Sprint_Opt_Node (Real_Range_Specification (Node)); 1833 1834 when N_Or_Else => 1835 Sprint_Left_Opnd (Node); 1836 Write_Str_Sloc (" or else "); 1837 Sprint_Right_Opnd (Node); 1838 1839 when N_Others_Choice => 1840 if All_Others (Node) then 1841 Write_Str_With_Col_Check ("all "); 1842 end if; 1843 1844 Write_Str_With_Col_Check_Sloc ("others"); 1845 1846 when N_Package_Body => 1847 Write_Indent; 1848 Write_Indent_Str_Sloc ("package body "); 1849 Sprint_Node (Defining_Unit_Name (Node)); 1850 Write_Str (" is"); 1851 Sprint_Indented_List (Declarations (Node)); 1852 1853 if Present (Handled_Statement_Sequence (Node)) then 1854 Write_Indent_Str ("begin"); 1855 Sprint_Node (Handled_Statement_Sequence (Node)); 1856 end if; 1857 1858 Write_Indent_Str ("end "); 1859 Sprint_Node (Defining_Unit_Name (Node)); 1860 Write_Char (';'); 1861 1862 when N_Package_Body_Stub => 1863 Write_Indent_Str_Sloc ("package body "); 1864 Sprint_Node (Defining_Identifier (Node)); 1865 Write_Str_With_Col_Check (" is separate;"); 1866 1867 when N_Package_Declaration => 1868 Write_Indent; 1869 Write_Indent; 1870 Sprint_Node_Sloc (Specification (Node)); 1871 Write_Char (';'); 1872 1873 when N_Package_Instantiation => 1874 Write_Indent; 1875 Write_Indent_Str_Sloc ("package "); 1876 Sprint_Node (Defining_Unit_Name (Node)); 1877 Write_Str (" is new "); 1878 Sprint_Node (Name (Node)); 1879 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); 1880 Write_Char (';'); 1881 1882 when N_Package_Renaming_Declaration => 1883 Write_Indent_Str_Sloc ("package "); 1884 Sprint_Node (Defining_Unit_Name (Node)); 1885 Write_Str_With_Col_Check (" renames "); 1886 Sprint_Node (Name (Node)); 1887 Write_Char (';'); 1888 1889 when N_Package_Specification => 1890 Write_Str_With_Col_Check_Sloc ("package "); 1891 Sprint_Node (Defining_Unit_Name (Node)); 1892 Write_Str (" is"); 1893 Sprint_Indented_List (Visible_Declarations (Node)); 1894 1895 if Present (Private_Declarations (Node)) then 1896 Write_Indent_Str ("private"); 1897 Sprint_Indented_List (Private_Declarations (Node)); 1898 end if; 1899 1900 Write_Indent_Str ("end "); 1901 Sprint_Node (Defining_Unit_Name (Node)); 1902 1903 when N_Parameter_Association => 1904 Sprint_Node_Sloc (Selector_Name (Node)); 1905 Write_Str (" => "); 1906 Sprint_Node (Explicit_Actual_Parameter (Node)); 1907 1908 when N_Parameter_Specification => 1909 Set_Debug_Sloc; 1910 1911 if Write_Identifiers (Node) then 1912 Write_Str (" : "); 1913 1914 if In_Present (Node) then 1915 Write_Str_With_Col_Check ("in "); 1916 end if; 1917 1918 if Out_Present (Node) then 1919 Write_Str_With_Col_Check ("out "); 1920 end if; 1921 1922 Sprint_Node (Parameter_Type (Node)); 1923 1924 if Present (Expression (Node)) then 1925 Write_Str (" := "); 1926 Sprint_Node (Expression (Node)); 1927 end if; 1928 else 1929 Write_Str (", "); 1930 end if; 1931 1932 when N_Pragma => 1933 Write_Indent_Str_Sloc ("pragma "); 1934 Write_Name_With_Col_Check (Chars (Node)); 1935 1936 if Present (Pragma_Argument_Associations (Node)) then 1937 Sprint_Opt_Paren_Comma_List 1938 (Pragma_Argument_Associations (Node)); 1939 end if; 1940 1941 Write_Char (';'); 1942 1943 when N_Pragma_Argument_Association => 1944 Set_Debug_Sloc; 1945 1946 if Chars (Node) /= No_Name then 1947 Write_Name_With_Col_Check (Chars (Node)); 1948 Write_Str (" => "); 1949 end if; 1950 1951 Sprint_Node (Expression (Node)); 1952 1953 when N_Private_Type_Declaration => 1954 Write_Indent_Str_Sloc ("type "); 1955 Write_Id (Defining_Identifier (Node)); 1956 1957 if Present (Discriminant_Specifications (Node)) then 1958 Write_Discr_Specs (Node); 1959 elsif Unknown_Discriminants_Present (Node) then 1960 Write_Str_With_Col_Check ("(<>)"); 1961 end if; 1962 1963 Write_Str (" is "); 1964 1965 if Tagged_Present (Node) then 1966 Write_Str_With_Col_Check ("tagged "); 1967 end if; 1968 1969 if Limited_Present (Node) then 1970 Write_Str_With_Col_Check ("limited "); 1971 end if; 1972 1973 Write_Str_With_Col_Check ("private;"); 1974 1975 when N_Private_Extension_Declaration => 1976 Write_Indent_Str_Sloc ("type "); 1977 Write_Id (Defining_Identifier (Node)); 1978 1979 if Present (Discriminant_Specifications (Node)) then 1980 Write_Discr_Specs (Node); 1981 elsif Unknown_Discriminants_Present (Node) then 1982 Write_Str_With_Col_Check ("(<>)"); 1983 end if; 1984 1985 Write_Str_With_Col_Check (" is new "); 1986 Sprint_Node (Subtype_Indication (Node)); 1987 Write_Str_With_Col_Check (" with private;"); 1988 1989 when N_Procedure_Call_Statement => 1990 Write_Indent; 1991 Set_Debug_Sloc; 1992 Sprint_Node (Name (Node)); 1993 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); 1994 Write_Char (';'); 1995 1996 when N_Procedure_Instantiation => 1997 Write_Indent_Str_Sloc ("procedure "); 1998 Sprint_Node (Defining_Unit_Name (Node)); 1999 Write_Str_With_Col_Check (" is new "); 2000 Sprint_Node (Name (Node)); 2001 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); 2002 Write_Char (';'); 2003 2004 when N_Procedure_Specification => 2005 Write_Str_With_Col_Check_Sloc ("procedure "); 2006 Sprint_Node (Defining_Unit_Name (Node)); 2007 Write_Param_Specs (Node); 2008 2009 when N_Protected_Body => 2010 Write_Indent_Str_Sloc ("protected body "); 2011 Write_Id (Defining_Identifier (Node)); 2012 Write_Str (" is"); 2013 Sprint_Indented_List (Declarations (Node)); 2014 Write_Indent_Str ("end "); 2015 Write_Id (Defining_Identifier (Node)); 2016 Write_Char (';'); 2017 2018 when N_Protected_Body_Stub => 2019 Write_Indent_Str_Sloc ("protected body "); 2020 Write_Id (Defining_Identifier (Node)); 2021 Write_Str_With_Col_Check (" is separate;"); 2022 2023 when N_Protected_Definition => 2024 Set_Debug_Sloc; 2025 Sprint_Indented_List (Visible_Declarations (Node)); 2026 2027 if Present (Private_Declarations (Node)) then 2028 Write_Indent_Str ("private"); 2029 Sprint_Indented_List (Private_Declarations (Node)); 2030 end if; 2031 2032 Write_Indent_Str ("end "); 2033 2034 when N_Protected_Type_Declaration => 2035 Write_Indent_Str_Sloc ("protected type "); 2036 Write_Id (Defining_Identifier (Node)); 2037 Write_Discr_Specs (Node); 2038 Write_Str (" is"); 2039 Sprint_Node (Protected_Definition (Node)); 2040 Write_Id (Defining_Identifier (Node)); 2041 Write_Char (';'); 2042 2043 when N_Qualified_Expression => 2044 Sprint_Node (Subtype_Mark (Node)); 2045 Write_Char_Sloc ('''); 2046 2047 -- Print expression, make sure we have at least one level of 2048 -- parentheses around the expression. For cases of qualified 2049 -- expressions in the source, this is always the case, but 2050 -- for generated qualifications, there may be no explicit 2051 -- parentheses present. 2052 2053 if Paren_Count (Expression (Node)) /= 0 then 2054 Sprint_Node (Expression (Node)); 2055 else 2056 Write_Char ('('); 2057 Sprint_Node (Expression (Node)); 2058 Write_Char (')'); 2059 end if; 2060 2061 when N_Raise_Constraint_Error => 2062 2063 -- This node can be used either as a subexpression or as a 2064 -- statement form. The following test is a reasonably reliable 2065 -- way to distinguish the two cases. 2066 2067 if Is_List_Member (Node) 2068 and then Nkind (Parent (Node)) not in N_Subexpr 2069 then 2070 Write_Indent; 2071 end if; 2072 2073 Write_Str_With_Col_Check_Sloc ("[constraint_error"); 2074 Write_Condition_And_Reason (Node); 2075 2076 when N_Raise_Program_Error => 2077 2078 -- This node can be used either as a subexpression or as a 2079 -- statement form. The following test is a reasonably reliable 2080 -- way to distinguish the two cases. 2081 2082 if Is_List_Member (Node) 2083 and then Nkind (Parent (Node)) not in N_Subexpr 2084 then 2085 Write_Indent; 2086 end if; 2087 2088 Write_Str_With_Col_Check_Sloc ("[program_error"); 2089 Write_Condition_And_Reason (Node); 2090 2091 when N_Raise_Storage_Error => 2092 2093 -- This node can be used either as a subexpression or as a 2094 -- statement form. The following test is a reasonably reliable 2095 -- way to distinguish the two cases. 2096 2097 if Is_List_Member (Node) 2098 and then Nkind (Parent (Node)) not in N_Subexpr 2099 then 2100 Write_Indent; 2101 end if; 2102 2103 Write_Str_With_Col_Check_Sloc ("[storage_error"); 2104 Write_Condition_And_Reason (Node); 2105 2106 when N_Raise_Statement => 2107 Write_Indent_Str_Sloc ("raise "); 2108 Sprint_Node (Name (Node)); 2109 Write_Char (';'); 2110 2111 when N_Range => 2112 Sprint_Node (Low_Bound (Node)); 2113 Write_Str_Sloc (" .. "); 2114 Sprint_Node (High_Bound (Node)); 2115 2116 when N_Range_Constraint => 2117 Write_Str_With_Col_Check_Sloc ("range "); 2118 Sprint_Node (Range_Expression (Node)); 2119 2120 when N_Real_Literal => 2121 Write_Ureal_With_Col_Check_Sloc (Realval (Node)); 2122 2123 when N_Real_Range_Specification => 2124 Write_Str_With_Col_Check_Sloc ("range "); 2125 Sprint_Node (Low_Bound (Node)); 2126 Write_Str (" .. "); 2127 Sprint_Node (High_Bound (Node)); 2128 2129 when N_Record_Definition => 2130 if Abstract_Present (Node) then 2131 Write_Str_With_Col_Check ("abstract "); 2132 end if; 2133 2134 if Tagged_Present (Node) then 2135 Write_Str_With_Col_Check ("tagged "); 2136 end if; 2137 2138 if Limited_Present (Node) then 2139 Write_Str_With_Col_Check ("limited "); 2140 end if; 2141 2142 if Null_Present (Node) then 2143 Write_Str_With_Col_Check_Sloc ("null record"); 2144 2145 else 2146 Write_Str_With_Col_Check_Sloc ("record"); 2147 Sprint_Node (Component_List (Node)); 2148 Write_Indent_Str ("end record"); 2149 end if; 2150 2151 when N_Record_Representation_Clause => 2152 Write_Indent_Str_Sloc ("for "); 2153 Sprint_Node (Identifier (Node)); 2154 Write_Str_With_Col_Check (" use record "); 2155 2156 if Present (Mod_Clause (Node)) then 2157 Sprint_Node (Mod_Clause (Node)); 2158 end if; 2159 2160 Sprint_Indented_List (Component_Clauses (Node)); 2161 Write_Indent_Str ("end record;"); 2162 2163 when N_Reference => 2164 Sprint_Node (Prefix (Node)); 2165 Write_Str_With_Col_Check_Sloc ("'reference"); 2166 2167 when N_Requeue_Statement => 2168 Write_Indent_Str_Sloc ("requeue "); 2169 Sprint_Node (Name (Node)); 2170 2171 if Abort_Present (Node) then 2172 Write_Str_With_Col_Check (" with abort"); 2173 end if; 2174 2175 Write_Char (';'); 2176 2177 when N_Return_Statement => 2178 if Present (Expression (Node)) then 2179 Write_Indent_Str_Sloc ("return "); 2180 Sprint_Node (Expression (Node)); 2181 Write_Char (';'); 2182 else 2183 Write_Indent_Str_Sloc ("return;"); 2184 end if; 2185 2186 when N_Selective_Accept => 2187 Write_Indent_Str_Sloc ("select"); 2188 2189 declare 2190 Alt_Node : Node_Id; 2191 2192 begin 2193 Alt_Node := First (Select_Alternatives (Node)); 2194 loop 2195 Indent_Begin; 2196 Sprint_Node (Alt_Node); 2197 Indent_End; 2198 Next (Alt_Node); 2199 exit when No (Alt_Node); 2200 Write_Indent_Str ("or"); 2201 end loop; 2202 end; 2203 2204 if Present (Else_Statements (Node)) then 2205 Write_Indent_Str ("else"); 2206 Sprint_Indented_List (Else_Statements (Node)); 2207 end if; 2208 2209 Write_Indent_Str ("end select;"); 2210 2211 when N_Signed_Integer_Type_Definition => 2212 Write_Str_With_Col_Check_Sloc ("range "); 2213 Sprint_Node (Low_Bound (Node)); 2214 Write_Str (" .. "); 2215 Sprint_Node (High_Bound (Node)); 2216 2217 when N_Single_Protected_Declaration => 2218 Write_Indent_Str_Sloc ("protected "); 2219 Write_Id (Defining_Identifier (Node)); 2220 Write_Str (" is"); 2221 Sprint_Node (Protected_Definition (Node)); 2222 Write_Id (Defining_Identifier (Node)); 2223 Write_Char (';'); 2224 2225 when N_Single_Task_Declaration => 2226 Write_Indent_Str_Sloc ("task "); 2227 Write_Id (Defining_Identifier (Node)); 2228 2229 if Present (Task_Definition (Node)) then 2230 Write_Str (" is"); 2231 Sprint_Node (Task_Definition (Node)); 2232 Write_Id (Defining_Identifier (Node)); 2233 end if; 2234 2235 Write_Char (';'); 2236 2237 when N_Selected_Component => 2238 Sprint_Node (Prefix (Node)); 2239 Write_Char_Sloc ('.'); 2240 Sprint_Node (Selector_Name (Node)); 2241 2242 when N_Slice => 2243 Set_Debug_Sloc; 2244 Sprint_Node (Prefix (Node)); 2245 Write_Str_With_Col_Check (" ("); 2246 Sprint_Node (Discrete_Range (Node)); 2247 Write_Char (')'); 2248 2249 when N_String_Literal => 2250 if String_Length (Strval (Node)) + Column > 75 then 2251 Write_Indent_Str (" "); 2252 end if; 2253 2254 Set_Debug_Sloc; 2255 Write_String_Table_Entry (Strval (Node)); 2256 2257 when N_Subprogram_Body => 2258 if Freeze_Indent = 0 then 2259 Write_Indent; 2260 end if; 2261 2262 Write_Indent; 2263 Sprint_Node_Sloc (Specification (Node)); 2264 Write_Str (" is"); 2265 2266 Sprint_Indented_List (Declarations (Node)); 2267 Write_Indent_Str ("begin"); 2268 Sprint_Node (Handled_Statement_Sequence (Node)); 2269 2270 Write_Indent_Str ("end "); 2271 Sprint_Node (Defining_Unit_Name (Specification (Node))); 2272 Write_Char (';'); 2273 2274 if Is_List_Member (Node) 2275 and then Present (Next (Node)) 2276 and then Nkind (Next (Node)) /= N_Subprogram_Body 2277 then 2278 Write_Indent; 2279 end if; 2280 2281 when N_Subprogram_Body_Stub => 2282 Write_Indent; 2283 Sprint_Node_Sloc (Specification (Node)); 2284 Write_Str_With_Col_Check (" is separate;"); 2285 2286 when N_Subprogram_Declaration => 2287 Write_Indent; 2288 Sprint_Node_Sloc (Specification (Node)); 2289 Write_Char (';'); 2290 2291 when N_Subprogram_Info => 2292 Sprint_Node (Identifier (Node)); 2293 Write_Str_With_Col_Check_Sloc ("'subprogram_info"); 2294 2295 when N_Subprogram_Renaming_Declaration => 2296 Write_Indent; 2297 Sprint_Node (Specification (Node)); 2298 Write_Str_With_Col_Check_Sloc (" renames "); 2299 Sprint_Node (Name (Node)); 2300 Write_Char (';'); 2301 2302 when N_Subtype_Declaration => 2303 Write_Indent_Str_Sloc ("subtype "); 2304 Write_Id (Defining_Identifier (Node)); 2305 Write_Str (" is "); 2306 Sprint_Node (Subtype_Indication (Node)); 2307 Write_Char (';'); 2308 2309 when N_Subtype_Indication => 2310 Sprint_Node_Sloc (Subtype_Mark (Node)); 2311 Write_Char (' '); 2312 Sprint_Node (Constraint (Node)); 2313 2314 when N_Subunit => 2315 Write_Indent_Str_Sloc ("separate ("); 2316 Sprint_Node (Name (Node)); 2317 Write_Char (')'); 2318 Write_Eol; 2319 Sprint_Node (Proper_Body (Node)); 2320 2321 when N_Task_Body => 2322 Write_Indent_Str_Sloc ("task body "); 2323 Write_Id (Defining_Identifier (Node)); 2324 Write_Str (" is"); 2325 Sprint_Indented_List (Declarations (Node)); 2326 Write_Indent_Str ("begin"); 2327 Sprint_Node (Handled_Statement_Sequence (Node)); 2328 Write_Indent_Str ("end "); 2329 Write_Id (Defining_Identifier (Node)); 2330 Write_Char (';'); 2331 2332 when N_Task_Body_Stub => 2333 Write_Indent_Str_Sloc ("task body "); 2334 Write_Id (Defining_Identifier (Node)); 2335 Write_Str_With_Col_Check (" is separate;"); 2336 2337 when N_Task_Definition => 2338 Set_Debug_Sloc; 2339 Sprint_Indented_List (Visible_Declarations (Node)); 2340 2341 if Present (Private_Declarations (Node)) then 2342 Write_Indent_Str ("private"); 2343 Sprint_Indented_List (Private_Declarations (Node)); 2344 end if; 2345 2346 Write_Indent_Str ("end "); 2347 2348 when N_Task_Type_Declaration => 2349 Write_Indent_Str_Sloc ("task type "); 2350 Write_Id (Defining_Identifier (Node)); 2351 Write_Discr_Specs (Node); 2352 if Present (Task_Definition (Node)) then 2353 Write_Str (" is"); 2354 Sprint_Node (Task_Definition (Node)); 2355 Write_Id (Defining_Identifier (Node)); 2356 end if; 2357 2358 Write_Char (';'); 2359 2360 when N_Terminate_Alternative => 2361 Sprint_Node_List (Pragmas_Before (Node)); 2362 2363 Write_Indent; 2364 2365 if Present (Condition (Node)) then 2366 Write_Str_With_Col_Check ("when "); 2367 Sprint_Node (Condition (Node)); 2368 Write_Str (" => "); 2369 end if; 2370 2371 Write_Str_With_Col_Check_Sloc ("terminate;"); 2372 Sprint_Node_List (Pragmas_After (Node)); 2373 2374 when N_Timed_Entry_Call => 2375 Write_Indent_Str_Sloc ("select"); 2376 Indent_Begin; 2377 Sprint_Node (Entry_Call_Alternative (Node)); 2378 Indent_End; 2379 Write_Indent_Str ("or"); 2380 Indent_Begin; 2381 Sprint_Node (Delay_Alternative (Node)); 2382 Indent_End; 2383 Write_Indent_Str ("end select;"); 2384 2385 when N_Triggering_Alternative => 2386 Sprint_Node_List (Pragmas_Before (Node)); 2387 Sprint_Node_Sloc (Triggering_Statement (Node)); 2388 Sprint_Node_List (Statements (Node)); 2389 2390 when N_Type_Conversion => 2391 Set_Debug_Sloc; 2392 Sprint_Node (Subtype_Mark (Node)); 2393 Col_Check (4); 2394 2395 if Conversion_OK (Node) then 2396 Write_Char ('?'); 2397 end if; 2398 2399 if Float_Truncate (Node) then 2400 Write_Char ('^'); 2401 end if; 2402 2403 if Rounded_Result (Node) then 2404 Write_Char ('@'); 2405 end if; 2406 2407 Write_Char ('('); 2408 Sprint_Node (Expression (Node)); 2409 Write_Char (')'); 2410 2411 when N_Unchecked_Expression => 2412 Col_Check (10); 2413 Write_Str ("`("); 2414 Sprint_Node_Sloc (Expression (Node)); 2415 Write_Char (')'); 2416 2417 when N_Unchecked_Type_Conversion => 2418 Sprint_Node (Subtype_Mark (Node)); 2419 Write_Char ('!'); 2420 Write_Str_With_Col_Check ("("); 2421 Sprint_Node_Sloc (Expression (Node)); 2422 Write_Char (')'); 2423 2424 when N_Unconstrained_Array_Definition => 2425 Write_Str_With_Col_Check_Sloc ("array ("); 2426 2427 declare 2428 Node1 : Node_Id; 2429 2430 begin 2431 Node1 := First (Subtype_Marks (Node)); 2432 loop 2433 Sprint_Node (Node1); 2434 Write_Str_With_Col_Check (" range <>"); 2435 Next (Node1); 2436 exit when Node1 = Empty; 2437 Write_Str (", "); 2438 end loop; 2439 end; 2440 2441 Write_Str (") of "); 2442 Sprint_Node (Component_Definition (Node)); 2443 2444 when N_Unused_At_Start | N_Unused_At_End => 2445 Write_Indent_Str ("***** Error, unused node encountered *****"); 2446 Write_Eol; 2447 2448 when N_Use_Package_Clause => 2449 Write_Indent_Str_Sloc ("use "); 2450 Sprint_Comma_List (Names (Node)); 2451 Write_Char (';'); 2452 2453 when N_Use_Type_Clause => 2454 Write_Indent_Str_Sloc ("use type "); 2455 Sprint_Comma_List (Subtype_Marks (Node)); 2456 Write_Char (';'); 2457 2458 when N_Validate_Unchecked_Conversion => 2459 Write_Indent_Str_Sloc ("validate unchecked_conversion ("); 2460 Sprint_Node (Source_Type (Node)); 2461 Write_Str (", "); 2462 Sprint_Node (Target_Type (Node)); 2463 Write_Str (");"); 2464 2465 when N_Variant => 2466 Write_Indent_Str_Sloc ("when "); 2467 Sprint_Bar_List (Discrete_Choices (Node)); 2468 Write_Str (" => "); 2469 Sprint_Node (Component_List (Node)); 2470 2471 when N_Variant_Part => 2472 Indent_Begin; 2473 Write_Indent_Str_Sloc ("case "); 2474 Sprint_Node (Name (Node)); 2475 Write_Str (" is "); 2476 Sprint_Indented_List (Variants (Node)); 2477 Write_Indent_Str ("end case"); 2478 Indent_End; 2479 2480 when N_With_Clause => 2481 2482 -- Special test, if we are dumping the original tree only, 2483 -- then we want to eliminate the bogus with clauses that 2484 -- correspond to the non-existent children of Text_IO. 2485 2486 if Dump_Original_Only 2487 and then Is_Text_IO_Kludge_Unit (Name (Node)) 2488 then 2489 null; 2490 2491 -- Normal case, output the with clause 2492 2493 else 2494 if First_Name (Node) or else not Dump_Original_Only then 2495 2496 -- Ada0Y (AI-50217): Print limited with_clauses 2497 2498 if Limited_Present (Node) then 2499 Write_Indent_Str ("limited with "); 2500 else 2501 Write_Indent_Str ("with "); 2502 end if; 2503 2504 else 2505 Write_Str (", "); 2506 end if; 2507 2508 Sprint_Node_Sloc (Name (Node)); 2509 2510 if Last_Name (Node) or else not Dump_Original_Only then 2511 Write_Char (';'); 2512 end if; 2513 end if; 2514 2515 when N_With_Type_Clause => 2516 Write_Indent_Str ("with type "); 2517 Sprint_Node_Sloc (Name (Node)); 2518 2519 if Tagged_Present (Node) then 2520 Write_Str (" is tagged;"); 2521 else 2522 Write_Str (" is access;"); 2523 end if; 2524 2525 end case; 2526 2527 if Nkind (Node) in N_Subexpr 2528 and then Do_Range_Check (Node) 2529 then 2530 Write_Str ("}"); 2531 end if; 2532 2533 for J in 1 .. Paren_Count (Node) loop 2534 Write_Char (')'); 2535 end loop; 2536 2537 pragma Assert (No (Debug_Node)); 2538 Debug_Node := Save_Debug_Node; 2539 end Sprint_Node_Actual; 2540 2541 ---------------------- 2542 -- Sprint_Node_List -- 2543 ---------------------- 2544 2545 procedure Sprint_Node_List (List : List_Id) is 2546 Node : Node_Id; 2547 2548 begin 2549 if Is_Non_Empty_List (List) then 2550 Node := First (List); 2551 2552 loop 2553 Sprint_Node (Node); 2554 Next (Node); 2555 exit when Node = Empty; 2556 end loop; 2557 end if; 2558 end Sprint_Node_List; 2559 2560 ---------------------- 2561 -- Sprint_Node_Sloc -- 2562 ---------------------- 2563 2564 procedure Sprint_Node_Sloc (Node : Node_Id) is 2565 begin 2566 Sprint_Node (Node); 2567 2568 if Present (Debug_Node) then 2569 Set_Sloc (Debug_Node, Sloc (Node)); 2570 Debug_Node := Empty; 2571 end if; 2572 end Sprint_Node_Sloc; 2573 2574 --------------------- 2575 -- Sprint_Opt_Node -- 2576 --------------------- 2577 2578 procedure Sprint_Opt_Node (Node : Node_Id) is 2579 begin 2580 if Present (Node) then 2581 Write_Char (' '); 2582 Sprint_Node (Node); 2583 end if; 2584 end Sprint_Opt_Node; 2585 2586 -------------------------- 2587 -- Sprint_Opt_Node_List -- 2588 -------------------------- 2589 2590 procedure Sprint_Opt_Node_List (List : List_Id) is 2591 begin 2592 if Present (List) then 2593 Sprint_Node_List (List); 2594 end if; 2595 end Sprint_Opt_Node_List; 2596 2597 --------------------------------- 2598 -- Sprint_Opt_Paren_Comma_List -- 2599 --------------------------------- 2600 2601 procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is 2602 begin 2603 if Is_Non_Empty_List (List) then 2604 Write_Char (' '); 2605 Sprint_Paren_Comma_List (List); 2606 end if; 2607 end Sprint_Opt_Paren_Comma_List; 2608 2609 ----------------------------- 2610 -- Sprint_Paren_Comma_List -- 2611 ----------------------------- 2612 2613 procedure Sprint_Paren_Comma_List (List : List_Id) is 2614 N : Node_Id; 2615 Node_Exists : Boolean := False; 2616 2617 begin 2618 2619 if Is_Non_Empty_List (List) then 2620 2621 if Dump_Original_Only then 2622 N := First (List); 2623 2624 while Present (N) loop 2625 2626 if not Is_Rewrite_Insertion (N) then 2627 Node_Exists := True; 2628 exit; 2629 end if; 2630 2631 Next (N); 2632 end loop; 2633 2634 if not Node_Exists then 2635 return; 2636 end if; 2637 end if; 2638 2639 Write_Str_With_Col_Check ("("); 2640 Sprint_Comma_List (List); 2641 Write_Char (')'); 2642 end if; 2643 end Sprint_Paren_Comma_List; 2644 2645 ---------------------- 2646 -- Sprint_Right_Opnd -- 2647 ---------------------- 2648 2649 procedure Sprint_Right_Opnd (N : Node_Id) is 2650 Opnd : constant Node_Id := Right_Opnd (N); 2651 2652 begin 2653 if Paren_Count (Opnd) /= 0 2654 or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N)) 2655 then 2656 Sprint_Node (Opnd); 2657 2658 else 2659 Write_Char ('('); 2660 Sprint_Node (Opnd); 2661 Write_Char (')'); 2662 end if; 2663 end Sprint_Right_Opnd; 2664 2665 --------------------- 2666 -- Write_Char_Sloc -- 2667 --------------------- 2668 2669 procedure Write_Char_Sloc (C : Character) is 2670 begin 2671 if Debug_Generated_Code and then C /= ' ' then 2672 Set_Debug_Sloc; 2673 end if; 2674 2675 Write_Char (C); 2676 end Write_Char_Sloc; 2677 2678 -------------------------------- 2679 -- Write_Condition_And_Reason -- 2680 -------------------------------- 2681 2682 procedure Write_Condition_And_Reason (Node : Node_Id) is 2683 Image : constant String := RT_Exception_Code'Image 2684 (RT_Exception_Code'Val 2685 (UI_To_Int (Reason (Node)))); 2686 2687 begin 2688 if Present (Condition (Node)) then 2689 Write_Str_With_Col_Check (" when "); 2690 Sprint_Node (Condition (Node)); 2691 end if; 2692 2693 Write_Str (" """); 2694 2695 for J in 4 .. Image'Last loop 2696 if Image (J) = '_' then 2697 Write_Char (' '); 2698 else 2699 Write_Char (Fold_Lower (Image (J))); 2700 end if; 2701 end loop; 2702 2703 Write_Str ("""]"); 2704 end Write_Condition_And_Reason; 2705 2706 ------------------------ 2707 -- Write_Discr_Specs -- 2708 ------------------------ 2709 2710 procedure Write_Discr_Specs (N : Node_Id) is 2711 Specs : List_Id; 2712 Spec : Node_Id; 2713 2714 begin 2715 Specs := Discriminant_Specifications (N); 2716 2717 if Present (Specs) then 2718 Write_Str_With_Col_Check (" ("); 2719 Spec := First (Specs); 2720 2721 loop 2722 Sprint_Node (Spec); 2723 Next (Spec); 2724 exit when Spec = Empty; 2725 2726 -- Add semicolon, unless we are printing original tree and the 2727 -- next specification is part of a list (but not the first 2728 -- element of that list) 2729 2730 if not Dump_Original_Only or else not Prev_Ids (Spec) then 2731 Write_Str ("; "); 2732 end if; 2733 end loop; 2734 2735 Write_Char (')'); 2736 end if; 2737 end Write_Discr_Specs; 2738 2739 ----------------- 2740 -- Write_Ekind -- 2741 ----------------- 2742 2743 procedure Write_Ekind (E : Entity_Id) is 2744 S : constant String := Entity_Kind'Image (Ekind (E)); 2745 2746 begin 2747 Name_Len := S'Length; 2748 Name_Buffer (1 .. Name_Len) := S; 2749 Set_Casing (Mixed_Case); 2750 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 2751 end Write_Ekind; 2752 2753 -------------- 2754 -- Write_Id -- 2755 -------------- 2756 2757 procedure Write_Id (N : Node_Id) is 2758 begin 2759 -- Case of a defining identifier 2760 2761 if Nkind (N) = N_Defining_Identifier then 2762 2763 -- If defining identifier has an interface name (and no 2764 -- address clause), then we output the interface name. 2765 2766 if (Is_Imported (N) or else Is_Exported (N)) 2767 and then Present (Interface_Name (N)) 2768 and then No (Address_Clause (N)) 2769 then 2770 String_To_Name_Buffer (Strval (Interface_Name (N))); 2771 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 2772 2773 -- If no interface name (or inactive because there was 2774 -- an address clause), then just output the Chars name. 2775 2776 else 2777 Write_Name_With_Col_Check (Chars (N)); 2778 end if; 2779 2780 -- Case of selector of an expanded name where the expanded name 2781 -- has an associated entity, output this entity. 2782 2783 elsif Nkind (Parent (N)) = N_Expanded_Name 2784 and then Selector_Name (Parent (N)) = N 2785 and then Present (Entity (Parent (N))) 2786 then 2787 Write_Id (Entity (Parent (N))); 2788 2789 -- For any other node with an associated entity, output it 2790 2791 elsif Nkind (N) in N_Has_Entity 2792 and then Present (Entity_Or_Associated_Node (N)) 2793 and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity 2794 then 2795 Write_Id (Entity (N)); 2796 2797 -- All other cases, we just print the Chars field 2798 2799 else 2800 Write_Name_With_Col_Check (Chars (N)); 2801 end if; 2802 end Write_Id; 2803 2804 ----------------------- 2805 -- Write_Identifiers -- 2806 ----------------------- 2807 2808 function Write_Identifiers (Node : Node_Id) return Boolean is 2809 begin 2810 Sprint_Node (Defining_Identifier (Node)); 2811 2812 -- The remainder of the declaration must be printed unless we are 2813 -- printing the original tree and this is not the last identifier 2814 2815 return 2816 not Dump_Original_Only or else not More_Ids (Node); 2817 2818 end Write_Identifiers; 2819 2820 ------------------------ 2821 -- Write_Implicit_Def -- 2822 ------------------------ 2823 2824 procedure Write_Implicit_Def (E : Entity_Id) is 2825 Ind : Node_Id; 2826 2827 begin 2828 case Ekind (E) is 2829 when E_Array_Subtype => 2830 Write_Str_With_Col_Check ("subtype "); 2831 Write_Id (E); 2832 Write_Str_With_Col_Check (" is "); 2833 Write_Id (Base_Type (E)); 2834 Write_Str_With_Col_Check (" ("); 2835 2836 Ind := First_Index (E); 2837 2838 while Present (Ind) loop 2839 Sprint_Node (Ind); 2840 Next_Index (Ind); 2841 2842 if Present (Ind) then 2843 Write_Str (", "); 2844 end if; 2845 end loop; 2846 2847 Write_Str (");"); 2848 2849 when E_Signed_Integer_Subtype | E_Enumeration_Subtype => 2850 Write_Str_With_Col_Check ("subtype "); 2851 Write_Id (E); 2852 Write_Str (" is "); 2853 Write_Id (Etype (E)); 2854 Write_Str_With_Col_Check (" range "); 2855 Sprint_Node (Scalar_Range (E)); 2856 Write_Str (";"); 2857 2858 when others => 2859 Write_Str_With_Col_Check ("type "); 2860 Write_Id (E); 2861 Write_Str_With_Col_Check (" is <"); 2862 Write_Ekind (E); 2863 Write_Str (">;"); 2864 end case; 2865 2866 end Write_Implicit_Def; 2867 2868 ------------------ 2869 -- Write_Indent -- 2870 ------------------ 2871 2872 procedure Write_Indent is 2873 begin 2874 if Indent_Annull_Flag then 2875 Indent_Annull_Flag := False; 2876 else 2877 Write_Eol; 2878 2879 for J in 1 .. Indent loop 2880 Write_Char (' '); 2881 end loop; 2882 end if; 2883 end Write_Indent; 2884 2885 ------------------------------ 2886 -- Write_Indent_Identifiers -- 2887 ------------------------------ 2888 2889 function Write_Indent_Identifiers (Node : Node_Id) return Boolean is 2890 begin 2891 -- We need to start a new line for every node, except in the case 2892 -- where we are printing the original tree and this is not the first 2893 -- defining identifier in the list. 2894 2895 if not Dump_Original_Only or else not Prev_Ids (Node) then 2896 Write_Indent; 2897 2898 -- If printing original tree and this is not the first defining 2899 -- identifier in the list, then the previous call to this procedure 2900 -- printed only the name, and we add a comma to separate the names. 2901 2902 else 2903 Write_Str (", "); 2904 end if; 2905 2906 Sprint_Node (Defining_Identifier (Node)); 2907 2908 -- The remainder of the declaration must be printed unless we are 2909 -- printing the original tree and this is not the last identifier 2910 2911 return 2912 not Dump_Original_Only or else not More_Ids (Node); 2913 2914 end Write_Indent_Identifiers; 2915 2916 ----------------------------------- 2917 -- Write_Indent_Identifiers_Sloc -- 2918 ----------------------------------- 2919 2920 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is 2921 begin 2922 -- We need to start a new line for every node, except in the case 2923 -- where we are printing the original tree and this is not the first 2924 -- defining identifier in the list. 2925 2926 if not Dump_Original_Only or else not Prev_Ids (Node) then 2927 Write_Indent; 2928 2929 -- If printing original tree and this is not the first defining 2930 -- identifier in the list, then the previous call to this procedure 2931 -- printed only the name, and we add a comma to separate the names. 2932 2933 else 2934 Write_Str (", "); 2935 end if; 2936 2937 Set_Debug_Sloc; 2938 Sprint_Node (Defining_Identifier (Node)); 2939 2940 -- The remainder of the declaration must be printed unless we are 2941 -- printing the original tree and this is not the last identifier 2942 2943 return 2944 not Dump_Original_Only or else not More_Ids (Node); 2945 2946 end Write_Indent_Identifiers_Sloc; 2947 2948 ---------------------- 2949 -- Write_Indent_Str -- 2950 ---------------------- 2951 2952 procedure Write_Indent_Str (S : String) is 2953 begin 2954 Write_Indent; 2955 Write_Str (S); 2956 end Write_Indent_Str; 2957 2958 --------------------------- 2959 -- Write_Indent_Str_Sloc -- 2960 --------------------------- 2961 2962 procedure Write_Indent_Str_Sloc (S : String) is 2963 begin 2964 Write_Indent; 2965 Write_Str_Sloc (S); 2966 end Write_Indent_Str_Sloc; 2967 2968 ------------------------------- 2969 -- Write_Name_With_Col_Check -- 2970 ------------------------------- 2971 2972 procedure Write_Name_With_Col_Check (N : Name_Id) is 2973 J : Natural; 2974 2975 begin 2976 Get_Name_String (N); 2977 2978 -- Deal with -gnatI which replaces digits in an internal 2979 -- name by three dots (e.g. R7b becomes R...b). 2980 2981 if Debug_Flag_II and then Name_Buffer (1) in 'A' .. 'Z' then 2982 2983 J := 2; 2984 while J < Name_Len loop 2985 exit when Name_Buffer (J) not in 'A' .. 'Z'; 2986 J := J + 1; 2987 end loop; 2988 2989 if Name_Buffer (J) in '0' .. '9' then 2990 Write_Str_With_Col_Check (Name_Buffer (1 .. J - 1)); 2991 Write_Str ("..."); 2992 2993 while J <= Name_Len loop 2994 if Name_Buffer (J) not in '0' .. '9' then 2995 Write_Str (Name_Buffer (J .. Name_Len)); 2996 exit; 2997 2998 else 2999 J := J + 1; 3000 end if; 3001 end loop; 3002 3003 return; 3004 end if; 3005 end if; 3006 3007 -- Fall through for normal case 3008 3009 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 3010 end Write_Name_With_Col_Check; 3011 3012 ------------------------------------ 3013 -- Write_Name_With_Col_Check_Sloc -- 3014 ------------------------------------ 3015 3016 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is 3017 begin 3018 Get_Name_String (N); 3019 Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len)); 3020 end Write_Name_With_Col_Check_Sloc; 3021 3022 -------------------- 3023 -- Write_Operator -- 3024 -------------------- 3025 3026 procedure Write_Operator (N : Node_Id; S : String) is 3027 F : Natural := S'First; 3028 T : Natural := S'Last; 3029 3030 begin 3031 -- If no overflow check, just write string out, and we are done 3032 3033 if not Do_Overflow_Check (N) then 3034 Write_Str_Sloc (S); 3035 3036 -- If overflow check, we want to surround the operator with curly 3037 -- brackets, but not include spaces within the brackets. 3038 3039 else 3040 if S (F) = ' ' then 3041 Write_Char (' '); 3042 F := F + 1; 3043 end if; 3044 3045 if S (T) = ' ' then 3046 T := T - 1; 3047 end if; 3048 3049 Write_Char ('{'); 3050 Write_Str_Sloc (S (F .. T)); 3051 Write_Char ('}'); 3052 3053 if S (S'Last) = ' ' then 3054 Write_Char (' '); 3055 end if; 3056 end if; 3057 end Write_Operator; 3058 3059 ----------------------- 3060 -- Write_Param_Specs -- 3061 ----------------------- 3062 3063 procedure Write_Param_Specs (N : Node_Id) is 3064 Specs : List_Id; 3065 Spec : Node_Id; 3066 Formal : Node_Id; 3067 3068 begin 3069 Specs := Parameter_Specifications (N); 3070 3071 if Is_Non_Empty_List (Specs) then 3072 Write_Str_With_Col_Check (" ("); 3073 Spec := First (Specs); 3074 3075 loop 3076 Sprint_Node (Spec); 3077 Formal := Defining_Identifier (Spec); 3078 Next (Spec); 3079 exit when Spec = Empty; 3080 3081 -- Add semicolon, unless we are printing original tree and the 3082 -- next specification is part of a list (but not the first 3083 -- element of that list) 3084 3085 if not Dump_Original_Only or else not Prev_Ids (Spec) then 3086 Write_Str ("; "); 3087 end if; 3088 end loop; 3089 3090 -- Write out any extra formals 3091 3092 while Present (Extra_Formal (Formal)) loop 3093 Formal := Extra_Formal (Formal); 3094 Write_Str ("; "); 3095 Write_Name_With_Col_Check (Chars (Formal)); 3096 Write_Str (" : "); 3097 Write_Name_With_Col_Check (Chars (Etype (Formal))); 3098 end loop; 3099 3100 Write_Char (')'); 3101 end if; 3102 end Write_Param_Specs; 3103 3104 -------------------------- 3105 -- Write_Rewrite_Str -- 3106 -------------------------- 3107 3108 procedure Write_Rewrite_Str (S : String) is 3109 begin 3110 if not Dump_Generated_Only then 3111 if S'Length = 3 and then S = ">>>" then 3112 Write_Str (">>>"); 3113 else 3114 Write_Str_With_Col_Check (S); 3115 end if; 3116 end if; 3117 end Write_Rewrite_Str; 3118 3119 -------------------- 3120 -- Write_Str_Sloc -- 3121 -------------------- 3122 3123 procedure Write_Str_Sloc (S : String) is 3124 begin 3125 for J in S'Range loop 3126 Write_Char_Sloc (S (J)); 3127 end loop; 3128 end Write_Str_Sloc; 3129 3130 ------------------------------ 3131 -- Write_Str_With_Col_Check -- 3132 ------------------------------ 3133 3134 procedure Write_Str_With_Col_Check (S : String) is 3135 begin 3136 if Int (S'Last) + Column > Line_Limit then 3137 Write_Indent_Str (" "); 3138 3139 if S (1) = ' ' then 3140 Write_Str (S (2 .. S'Length)); 3141 else 3142 Write_Str (S); 3143 end if; 3144 3145 else 3146 Write_Str (S); 3147 end if; 3148 end Write_Str_With_Col_Check; 3149 3150 ----------------------------------- 3151 -- Write_Str_With_Col_Check_Sloc -- 3152 ----------------------------------- 3153 3154 procedure Write_Str_With_Col_Check_Sloc (S : String) is 3155 begin 3156 if Int (S'Last) + Column > Line_Limit then 3157 Write_Indent_Str (" "); 3158 3159 if S (1) = ' ' then 3160 Write_Str_Sloc (S (2 .. S'Length)); 3161 else 3162 Write_Str_Sloc (S); 3163 end if; 3164 3165 else 3166 Write_Str_Sloc (S); 3167 end if; 3168 end Write_Str_With_Col_Check_Sloc; 3169 3170 ------------------------------------ 3171 -- Write_Uint_With_Col_Check_Sloc -- 3172 ------------------------------------ 3173 3174 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is 3175 begin 3176 Col_Check (UI_Decimal_Digits_Hi (U)); 3177 Set_Debug_Sloc; 3178 UI_Write (U, Format); 3179 end Write_Uint_With_Col_Check_Sloc; 3180 3181 ------------------------------------- 3182 -- Write_Ureal_With_Col_Check_Sloc -- 3183 ------------------------------------- 3184 3185 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is 3186 D : constant Uint := Denominator (U); 3187 N : constant Uint := Numerator (U); 3188 3189 begin 3190 Col_Check 3191 (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); 3192 Set_Debug_Sloc; 3193 UR_Write (U); 3194 end Write_Ureal_With_Col_Check_Sloc; 3195 3196end Sprint; 3197