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-2013, 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 3, 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 COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Casing; use Casing; 29with Csets; use Csets; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Fname; use Fname; 33with Lib; use Lib; 34with Namet; use Namet; 35with Nlists; use Nlists; 36with Opt; use Opt; 37with Output; use Output; 38with Rtsfind; use Rtsfind; 39with Sem_Eval; use Sem_Eval; 40with Sem_Util; use Sem_Util; 41with Sinfo; use Sinfo; 42with Sinput; use Sinput; 43with Sinput.D; use Sinput.D; 44with Snames; use Snames; 45with Stand; use Stand; 46with Stringt; use Stringt; 47with Uintp; use Uintp; 48with Uname; use Uname; 49with Urealp; use Urealp; 50 51package body Sprint is 52 Current_Source_File : Source_File_Index; 53 -- Index of source file whose generated code is being dumped 54 55 Dump_Node : Node_Id := Empty; 56 -- This is set to the current node, used for printing line numbers. In 57 -- Debug_Generated_Code mode, Dump_Node is set to the current node 58 -- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper 59 -- value. The call clears it back to Empty. 60 61 Debug_Sloc : Source_Ptr; 62 -- Sloc of first byte of line currently being written if we are 63 -- generating a source debug file. 64 65 Dump_Original_Only : Boolean; 66 -- Set True if the -gnatdo (dump original tree) flag is set 67 68 Dump_Generated_Only : Boolean; 69 -- Set True if the -gnatdG (dump generated tree) debug flag is set 70 -- or for Print_Generated_Code (-gnatG) or Dump_Generated_Code (-gnatD). 71 72 Dump_Freeze_Null : Boolean; 73 -- Set True if empty freeze nodes and non-source null statements output. 74 -- Note that freeze nodes containing freeze actions are always output, 75 -- as are freeze nodes for itypes, which in general have the effect of 76 -- causing elaboration of the itype. 77 78 Freeze_Indent : Int := 0; 79 -- Keep track of freeze indent level (controls output of blank lines before 80 -- procedures within expression freeze actions). Relevant only if we are 81 -- not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't 82 -- output these blank lines in any case. 83 84 Indent : Int := 0; 85 -- Number of columns for current line output indentation 86 87 Indent_Annull_Flag : Boolean := False; 88 -- Set True if subsequent Write_Indent call to be ignored, gets reset 89 -- by this call, so it is only active to suppress a single indent call. 90 91 Last_Line_Printed : Physical_Line_Number; 92 -- This keeps track of the physical line number of the last source line 93 -- that has been output. The value is only valid in Dump_Source_Text mode. 94 95 ------------------------------- 96 -- Operator Precedence Table -- 97 ------------------------------- 98 99 -- This table is used to decide whether a subexpression needs to be 100 -- parenthesized. The rule is that if an operand of an operator (which 101 -- for this purpose includes AND THEN and OR ELSE) is itself an operator 102 -- with a lower precedence than the operator (or equal precedence if 103 -- appearing as the right operand), then parentheses are required. 104 105 Op_Prec : constant array (N_Subexpr) of Short_Short_Integer := 106 (N_Op_And => 1, 107 N_Op_Or => 1, 108 N_Op_Xor => 1, 109 N_And_Then => 1, 110 N_Or_Else => 1, 111 112 N_In => 2, 113 N_Not_In => 2, 114 N_Op_Eq => 2, 115 N_Op_Ge => 2, 116 N_Op_Gt => 2, 117 N_Op_Le => 2, 118 N_Op_Lt => 2, 119 N_Op_Ne => 2, 120 121 N_Op_Add => 3, 122 N_Op_Concat => 3, 123 N_Op_Subtract => 3, 124 N_Op_Plus => 3, 125 N_Op_Minus => 3, 126 127 N_Op_Divide => 4, 128 N_Op_Mod => 4, 129 N_Op_Rem => 4, 130 N_Op_Multiply => 4, 131 132 N_Op_Expon => 5, 133 N_Op_Abs => 5, 134 N_Op_Not => 5, 135 136 others => 6); 137 138 procedure Sprint_Left_Opnd (N : Node_Id); 139 -- Print left operand of operator, parenthesizing if necessary 140 141 procedure Sprint_Right_Opnd (N : Node_Id); 142 -- Print right operand of operator, parenthesizing if necessary 143 144 ----------------------- 145 -- Local Subprograms -- 146 ----------------------- 147 148 procedure Col_Check (N : Nat); 149 -- Check that at least N characters remain on current line, and if not, 150 -- then start an extra line with two characters extra indentation for 151 -- continuing text on the next line. 152 153 procedure Extra_Blank_Line; 154 -- In some situations we write extra blank lines to separate the generated 155 -- code to make it more readable. However, these extra blank lines are not 156 -- generated in Dump_Source_Text mode, since there the source text lines 157 -- output with preceding blank lines are quite sufficient as separators. 158 -- This procedure writes a blank line if Dump_Source_Text is False. 159 160 procedure Indent_Annull; 161 -- Causes following call to Write_Indent to be ignored. This is used when 162 -- a higher level node wants to stop a lower level node from starting a 163 -- new line, when it would otherwise be inclined to do so (e.g. the case 164 -- of an accept statement called from an accept alternative with a guard) 165 166 procedure Indent_Begin; 167 -- Increase indentation level 168 169 procedure Indent_End; 170 -- Decrease indentation level 171 172 procedure Print_Debug_Line (S : String); 173 -- Used to print output lines in Debug_Generated_Code mode (this is used 174 -- as the argument for a call to Set_Special_Output in package Output). 175 176 procedure Process_TFAI_RR_Flags (Nod : Node_Id); 177 -- Given a divide, multiplication or division node, check the flags 178 -- Treat_Fixed_As_Integer and Rounded_Flags, and if set, output the 179 -- appropriate special syntax characters (# and @). 180 181 procedure Set_Debug_Sloc; 182 -- If Dump_Node is non-empty, this routine sets the appropriate value 183 -- in its Sloc field, from the current location in the debug source file 184 -- that is currently being written. 185 186 procedure Sprint_And_List (List : List_Id); 187 -- Print the given list with items separated by vertical "and" 188 189 procedure Sprint_Aspect_Specifications 190 (Node : Node_Id; 191 Semicolon : Boolean); 192 -- Node is a declaration node that has aspect specifications (Has_Aspects 193 -- flag set True). It outputs the aspect specifications. For the case 194 -- of Semicolon = True, it is called after outputting the terminating 195 -- semicolon for the related node. The effect is to remove the semicolon 196 -- and print the aspect specifications followed by a terminating semicolon. 197 -- For the case of Semicolon False, no semicolon is removed or output, and 198 -- all the aspects are printed on a single line. 199 200 procedure Sprint_Bar_List (List : List_Id); 201 -- Print the given list with items separated by vertical bars 202 203 procedure Sprint_End_Label 204 (Node : Node_Id; 205 Default : Node_Id); 206 -- Print the end label for a Handled_Sequence_Of_Statements in a body. 207 -- If there is no end label, use the defining identifier of the enclosing 208 -- construct. If the end label is present, treat it as a reference to the 209 -- defining entity of the construct: this guarantees that it carries the 210 -- proper sloc information for debugging purposes. 211 212 procedure Sprint_Node_Actual (Node : Node_Id); 213 -- This routine prints its node argument. It is a lower level routine than 214 -- Sprint_Node, in that it does not bother about rewritten trees. 215 216 procedure Sprint_Node_Sloc (Node : Node_Id); 217 -- Like Sprint_Node, but in addition, in Debug_Generated_Code mode, 218 -- sets the Sloc of the current debug node to be a copy of the Sloc 219 -- of the sprinted node Node. Note that this is done after printing 220 -- Node, so that the Sloc is the proper updated value for the debug file. 221 222 procedure Update_Itype (Node : Node_Id); 223 -- Update the Sloc of an itype that is not attached to the tree, when 224 -- debugging expanded code. This routine is called from nodes whose 225 -- type can be an Itype, such as defining_identifiers that may be of 226 -- an anonymous access type, or ranges in slices. 227 228 procedure Write_Char_Sloc (C : Character); 229 -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is 230 -- called to ensure that the current node has a proper Sloc set. 231 232 procedure Write_Condition_And_Reason (Node : Node_Id); 233 -- Write Condition and Reason codes of Raise_xxx_Error node 234 235 procedure Write_Corresponding_Source (S : String); 236 -- If S is a string with a single keyword (possibly followed by a space), 237 -- and if the next non-comment non-blank source line matches this keyword, 238 -- then output all source lines up to this matching line. 239 240 procedure Write_Discr_Specs (N : Node_Id); 241 -- Output discriminant specification for node, which is any of the type 242 -- declarations that can have discriminants. 243 244 procedure Write_Ekind (E : Entity_Id); 245 -- Write the String corresponding to the Ekind without "E_" 246 247 procedure Write_Id (N : Node_Id); 248 -- N is a node with a Chars field. This procedure writes the name that 249 -- will be used in the generated code associated with the name. For a 250 -- node with no associated entity, this is simply the Chars field. For 251 -- the case where there is an entity associated with the node, we print 252 -- the name associated with the entity (since it may have been encoded). 253 -- One other special case is that an entity has an active external name 254 -- (i.e. an external name present with no address clause), then this 255 -- external name is output. This procedure also deals with outputting 256 -- declarations of referenced itypes, if not output earlier. 257 258 function Write_Identifiers (Node : Node_Id) return Boolean; 259 -- Handle node where the grammar has a list of defining identifiers, but 260 -- the tree has a separate declaration for each identifier. Handles the 261 -- printing of the defining identifier, and returns True if the type and 262 -- initialization information is to be printed, False if it is to be 263 -- skipped (the latter case happens when printing defining identifiers 264 -- other than the first in the original tree output case). 265 266 procedure Write_Implicit_Def (E : Entity_Id); 267 pragma Warnings (Off, Write_Implicit_Def); 268 -- Write the definition of the implicit type E according to its Ekind 269 -- For now a debugging procedure, but might be used in the future. 270 271 procedure Write_Indent; 272 -- Start a new line and write indentation spacing 273 274 function Write_Indent_Identifiers (Node : Node_Id) return Boolean; 275 -- Like Write_Identifiers except that each new printed declaration 276 -- is at the start of a new line. 277 278 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean; 279 -- Like Write_Indent_Identifiers except that in Debug_Generated_Code 280 -- mode, the Sloc of the current debug node is set to point to the 281 -- first output identifier. 282 283 procedure Write_Indent_Str (S : String); 284 -- Start a new line and write indent spacing followed by given string 285 286 procedure Write_Indent_Str_Sloc (S : String); 287 -- Like Write_Indent_Str, but in addition, in Debug_Generated_Code mode, 288 -- the Sloc of the current node is set to the first non-blank character 289 -- in the string S. 290 291 procedure Write_Itype (Typ : Entity_Id); 292 -- If Typ is an Itype that has not been written yet, write it. If Typ is 293 -- any other kind of entity or tree node, the call is ignored. 294 295 procedure Write_Name_With_Col_Check (N : Name_Id); 296 -- Write name (using Write_Name) with initial column check, and possible 297 -- initial Write_Indent (to get new line) if current line is too full. 298 299 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id); 300 -- Like Write_Name_With_Col_Check but in addition, in Debug_Generated_Code 301 -- mode, sets Sloc of current debug node to first character of name. 302 303 procedure Write_Operator (N : Node_Id; S : String); 304 -- Like Write_Str_Sloc, used for operators, encloses the string in 305 -- characters {} if the Do_Overflow flag is set on the node N. 306 307 procedure Write_Param_Specs (N : Node_Id); 308 -- Output parameter specifications for node (which is either a function 309 -- or procedure specification with a Parameter_Specifications field) 310 311 procedure Write_Rewrite_Str (S : String); 312 -- Writes out a string (typically containing <<< or >>>}) for a node 313 -- created by rewriting the tree. Suppressed if we are outputting the 314 -- generated code only, since in this case we don't specially mark nodes 315 -- created by rewriting). 316 317 procedure Write_Source_Line (L : Physical_Line_Number); 318 -- If writing of interspersed source lines is enabled, then write the given 319 -- line from the source file, preceded by Eol, then an extra blank line if 320 -- the line has at least one blank, is not a comment and is not line one, 321 -- then "--" and the line number followed by period followed by text of the 322 -- source line (without terminating Eol). If interspersed source line 323 -- output not enabled, then the call has no effect. 324 325 procedure Write_Source_Lines (L : Physical_Line_Number); 326 -- If writing of interspersed source lines is enabled, then writes source 327 -- lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If 328 -- interspersed source line output not enabled, then call has no effect. 329 330 procedure Write_Str_Sloc (S : String); 331 -- Like Write_Str, but sets debug Sloc of current debug node to first 332 -- non-blank character if a current debug node is active. 333 334 procedure Write_Str_With_Col_Check (S : String); 335 -- Write string (using Write_Str) with initial column check, and possible 336 -- initial Write_Indent (to get new line) if current line is too full. 337 338 procedure Write_Str_With_Col_Check_Sloc (S : String); 339 -- Like Write_Str_With_Col_Check, but sets debug Sloc of current debug 340 -- node to first non-blank character if a current debug node is active. 341 342 procedure Write_Subprogram_Name (N : Node_Id); 343 -- N is the Name field of a function call or procedure statement call. 344 -- The effect of the call is to output the name, preceded by a $ if the 345 -- call is identified as an implicit call to a run time routine. 346 347 procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format); 348 -- Write Uint (using UI_Write) with initial column check, and possible 349 -- initial Write_Indent (to get new line) if current line is too full. 350 -- The format parameter determines the output format (see UI_Write). 351 352 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format); 353 -- Write Uint (using UI_Write) with initial column check, and possible 354 -- initial Write_Indent (to get new line) if current line is too full. 355 -- The format parameter determines the output format (see UI_Write). 356 -- In addition, in Debug_Generated_Code mode, sets the current node 357 -- Sloc to the first character of the output value. 358 359 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal); 360 -- Write Ureal (using same output format as UR_Write) with column checks 361 -- and a possible initial Write_Indent (to get new line) if current line 362 -- is too full. In addition, in Debug_Generated_Code mode, sets the 363 -- current node Sloc to the first character of the output value. 364 365 --------------- 366 -- Col_Check -- 367 --------------- 368 369 procedure Col_Check (N : Nat) is 370 begin 371 if N + Column > Sprint_Line_Limit then 372 Write_Indent_Str (" "); 373 end if; 374 end Col_Check; 375 376 ---------------------- 377 -- Extra_Blank_Line -- 378 ---------------------- 379 380 procedure Extra_Blank_Line is 381 begin 382 if not Dump_Source_Text then 383 Write_Indent; 384 end if; 385 end Extra_Blank_Line; 386 387 ------------------- 388 -- Indent_Annull -- 389 ------------------- 390 391 procedure Indent_Annull is 392 begin 393 Indent_Annull_Flag := True; 394 end Indent_Annull; 395 396 ------------------ 397 -- Indent_Begin -- 398 ------------------ 399 400 procedure Indent_Begin is 401 begin 402 Indent := Indent + 3; 403 end Indent_Begin; 404 405 ---------------- 406 -- Indent_End -- 407 ---------------- 408 409 procedure Indent_End is 410 begin 411 Indent := Indent - 3; 412 end Indent_End; 413 414 -------- 415 -- pg -- 416 -------- 417 418 procedure pg (Arg : Union_Id) is 419 begin 420 Dump_Generated_Only := True; 421 Dump_Original_Only := False; 422 Dump_Freeze_Null := True; 423 Current_Source_File := No_Source_File; 424 425 if Arg in List_Range then 426 Sprint_Node_List (List_Id (Arg), New_Lines => True); 427 428 elsif Arg in Node_Range then 429 Sprint_Node (Node_Id (Arg)); 430 431 else 432 null; 433 end if; 434 435 Write_Eol; 436 end pg; 437 438 -------- 439 -- po -- 440 -------- 441 442 procedure po (Arg : Union_Id) is 443 begin 444 Dump_Generated_Only := False; 445 Dump_Original_Only := True; 446 Current_Source_File := No_Source_File; 447 448 if Arg in List_Range then 449 Sprint_Node_List (List_Id (Arg), New_Lines => True); 450 451 elsif Arg in Node_Range then 452 Sprint_Node (Node_Id (Arg)); 453 454 else 455 null; 456 end if; 457 458 Write_Eol; 459 end po; 460 461 ---------------------- 462 -- Print_Debug_Line -- 463 ---------------------- 464 465 procedure Print_Debug_Line (S : String) is 466 begin 467 Write_Debug_Line (S, Debug_Sloc); 468 end Print_Debug_Line; 469 470 --------------------------- 471 -- Process_TFAI_RR_Flags -- 472 --------------------------- 473 474 procedure Process_TFAI_RR_Flags (Nod : Node_Id) is 475 begin 476 if Treat_Fixed_As_Integer (Nod) then 477 Write_Char ('#'); 478 end if; 479 480 if Rounded_Result (Nod) then 481 Write_Char ('@'); 482 end if; 483 end Process_TFAI_RR_Flags; 484 485 -------- 486 -- ps -- 487 -------- 488 489 procedure ps (Arg : Union_Id) is 490 begin 491 Dump_Generated_Only := False; 492 Dump_Original_Only := False; 493 Current_Source_File := No_Source_File; 494 495 if Arg in List_Range then 496 Sprint_Node_List (List_Id (Arg), New_Lines => True); 497 498 elsif Arg in Node_Range then 499 Sprint_Node (Node_Id (Arg)); 500 501 else 502 null; 503 end if; 504 505 Write_Eol; 506 end ps; 507 508 -------------------- 509 -- Set_Debug_Sloc -- 510 -------------------- 511 512 procedure Set_Debug_Sloc is 513 begin 514 if Debug_Generated_Code and then Present (Dump_Node) then 515 Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); 516 Dump_Node := Empty; 517 end if; 518 end Set_Debug_Sloc; 519 520 ----------------- 521 -- Source_Dump -- 522 ----------------- 523 524 procedure Source_Dump is 525 526 procedure Underline; 527 -- Put underline under string we just printed 528 529 --------------- 530 -- Underline -- 531 --------------- 532 533 procedure Underline is 534 Col : constant Int := Column; 535 536 begin 537 Write_Eol; 538 539 while Col > Column loop 540 Write_Char ('-'); 541 end loop; 542 543 Write_Eol; 544 end Underline; 545 546 -- Start of processing for Source_Dump 547 548 begin 549 Dump_Generated_Only := Debug_Flag_G or 550 Print_Generated_Code or 551 Debug_Generated_Code; 552 Dump_Original_Only := Debug_Flag_O; 553 Dump_Freeze_Null := Debug_Flag_S or Debug_Flag_G; 554 555 -- Note that we turn off the tree dump flags immediately, before 556 -- starting the dump. This avoids generating two copies of the dump 557 -- if an abort occurs after printing the dump, and more importantly, 558 -- avoids an infinite loop if an abort occurs during the dump. 559 560 if Debug_Flag_Z then 561 Current_Source_File := No_Source_File; 562 Debug_Flag_Z := False; 563 Write_Eol; 564 Write_Eol; 565 Write_Str ("Source recreated from tree of Standard (spec)"); 566 Underline; 567 Sprint_Node (Standard_Package_Node); 568 Write_Eol; 569 Write_Eol; 570 end if; 571 572 if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then 573 Debug_Flag_G := False; 574 Debug_Flag_O := False; 575 Debug_Flag_S := False; 576 577 -- Dump requested units 578 579 for U in Main_Unit .. Last_Unit loop 580 Current_Source_File := Source_Index (U); 581 582 -- Dump all units if -gnatdf set, otherwise we dump only 583 -- the source files that are in the extended main source. 584 585 if Debug_Flag_F 586 or else In_Extended_Main_Source_Unit (Cunit_Entity (U)) 587 then 588 -- If we are generating debug files, setup to write them 589 590 if Debug_Generated_Code then 591 Set_Special_Output (Print_Debug_Line'Access); 592 Create_Debug_Source (Source_Index (U), Debug_Sloc); 593 Write_Source_Line (1); 594 Last_Line_Printed := 1; 595 Sprint_Node (Cunit (U)); 596 Write_Source_Lines (Last_Source_Line (Current_Source_File)); 597 Write_Eol; 598 Close_Debug_Source; 599 Set_Special_Output (null); 600 601 -- Normal output to standard output file 602 603 else 604 Write_Str ("Source recreated from tree for "); 605 Write_Unit_Name (Unit_Name (U)); 606 Underline; 607 Write_Source_Line (1); 608 Last_Line_Printed := 1; 609 Sprint_Node (Cunit (U)); 610 Write_Source_Lines (Last_Source_Line (Current_Source_File)); 611 Write_Eol; 612 Write_Eol; 613 end if; 614 end if; 615 end loop; 616 end if; 617 end Source_Dump; 618 619 --------------------- 620 -- Sprint_And_List -- 621 --------------------- 622 623 procedure Sprint_And_List (List : List_Id) is 624 Node : Node_Id; 625 begin 626 if Is_Non_Empty_List (List) then 627 Node := First (List); 628 loop 629 Sprint_Node (Node); 630 Next (Node); 631 exit when Node = Empty; 632 Write_Str (" and "); 633 end loop; 634 end if; 635 end Sprint_And_List; 636 637 ---------------------------------- 638 -- Sprint_Aspect_Specifications -- 639 ---------------------------------- 640 641 procedure Sprint_Aspect_Specifications 642 (Node : Node_Id; 643 Semicolon : Boolean) 644 is 645 AS : constant List_Id := Aspect_Specifications (Node); 646 A : Node_Id; 647 648 begin 649 if Semicolon then 650 Write_Erase_Char (';'); 651 Indent := Indent + 2; 652 Write_Indent; 653 Write_Str ("with "); 654 Indent := Indent + 5; 655 656 else 657 Write_Str (" with "); 658 end if; 659 660 A := First (AS); 661 loop 662 Sprint_Node (Identifier (A)); 663 664 if Class_Present (A) then 665 Write_Str ("'Class"); 666 end if; 667 668 if Present (Expression (A)) then 669 Write_Str (" => "); 670 Sprint_Node (Expression (A)); 671 end if; 672 673 Next (A); 674 675 exit when No (A); 676 Write_Char (','); 677 678 if Semicolon then 679 Write_Indent; 680 end if; 681 end loop; 682 683 if Semicolon then 684 Indent := Indent - 7; 685 Write_Char (';'); 686 end if; 687 end Sprint_Aspect_Specifications; 688 689 --------------------- 690 -- Sprint_Bar_List -- 691 --------------------- 692 693 procedure Sprint_Bar_List (List : List_Id) is 694 Node : Node_Id; 695 begin 696 if Is_Non_Empty_List (List) then 697 Node := First (List); 698 loop 699 Sprint_Node (Node); 700 Next (Node); 701 exit when Node = Empty; 702 Write_Str (" | "); 703 end loop; 704 end if; 705 end Sprint_Bar_List; 706 707 ---------------------- 708 -- Sprint_End_Label -- 709 ---------------------- 710 711 procedure Sprint_End_Label 712 (Node : Node_Id; 713 Default : Node_Id) 714 is 715 begin 716 if Present (Node) 717 and then Present (End_Label (Node)) 718 and then Is_Entity_Name (End_Label (Node)) 719 then 720 Set_Entity (End_Label (Node), Default); 721 722 -- For a function whose name is an operator, use the qualified name 723 -- created for the defining entity. 724 725 if Nkind (End_Label (Node)) = N_Operator_Symbol then 726 Set_Chars (End_Label (Node), Chars (Default)); 727 end if; 728 729 Sprint_Node (End_Label (Node)); 730 else 731 Sprint_Node (Default); 732 end if; 733 end Sprint_End_Label; 734 735 ----------------------- 736 -- Sprint_Comma_List -- 737 ----------------------- 738 739 procedure Sprint_Comma_List (List : List_Id) is 740 Node : Node_Id; 741 742 begin 743 if Is_Non_Empty_List (List) then 744 Node := First (List); 745 loop 746 Sprint_Node (Node); 747 Next (Node); 748 exit when Node = Empty; 749 750 if not Is_Rewrite_Insertion (Node) 751 or else not Dump_Original_Only 752 then 753 Write_Str (", "); 754 end if; 755 end loop; 756 end if; 757 end Sprint_Comma_List; 758 759 -------------------------- 760 -- Sprint_Indented_List -- 761 -------------------------- 762 763 procedure Sprint_Indented_List (List : List_Id) is 764 begin 765 Indent_Begin; 766 Sprint_Node_List (List); 767 Indent_End; 768 end Sprint_Indented_List; 769 770 --------------------- 771 -- Sprint_Left_Opnd -- 772 --------------------- 773 774 procedure Sprint_Left_Opnd (N : Node_Id) is 775 Opnd : constant Node_Id := Left_Opnd (N); 776 777 begin 778 if Paren_Count (Opnd) /= 0 779 or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N)) 780 then 781 Sprint_Node (Opnd); 782 783 else 784 Write_Char ('('); 785 Sprint_Node (Opnd); 786 Write_Char (')'); 787 end if; 788 end Sprint_Left_Opnd; 789 790 ----------------- 791 -- Sprint_Node -- 792 ----------------- 793 794 procedure Sprint_Node (Node : Node_Id) is 795 begin 796 if Is_Rewrite_Insertion (Node) then 797 if not Dump_Original_Only then 798 799 -- For special cases of nodes that always output <<< >>> 800 -- do not duplicate the output at this point. 801 802 if Nkind (Node) = N_Freeze_Entity 803 or else Nkind (Node) = N_Freeze_Generic_Entity 804 or else Nkind (Node) = N_Implicit_Label_Declaration 805 then 806 Sprint_Node_Actual (Node); 807 808 -- Normal case where <<< >>> may be required 809 810 else 811 Write_Rewrite_Str ("<<<"); 812 Sprint_Node_Actual (Node); 813 Write_Rewrite_Str (">>>"); 814 end if; 815 end if; 816 817 elsif Is_Rewrite_Substitution (Node) then 818 819 -- Case of dump generated only 820 821 if Dump_Generated_Only then 822 Sprint_Node_Actual (Node); 823 824 -- Case of dump original only 825 826 elsif Dump_Original_Only then 827 Sprint_Node_Actual (Original_Node (Node)); 828 829 -- Case of both being dumped 830 831 else 832 Sprint_Node_Actual (Original_Node (Node)); 833 Write_Rewrite_Str ("<<<"); 834 Sprint_Node_Actual (Node); 835 Write_Rewrite_Str (">>>"); 836 end if; 837 838 else 839 Sprint_Node_Actual (Node); 840 end if; 841 end Sprint_Node; 842 843 ------------------------ 844 -- Sprint_Node_Actual -- 845 ------------------------ 846 847 procedure Sprint_Node_Actual (Node : Node_Id) is 848 Save_Dump_Node : constant Node_Id := Dump_Node; 849 850 begin 851 if Node = Empty then 852 return; 853 end if; 854 855 for J in 1 .. Paren_Count (Node) loop 856 Write_Str_With_Col_Check ("("); 857 end loop; 858 859 -- Setup current dump node 860 861 Dump_Node := Node; 862 863 if Nkind (Node) in N_Subexpr 864 and then Do_Range_Check (Node) 865 then 866 Write_Str_With_Col_Check ("{"); 867 end if; 868 869 -- Select print circuit based on node kind 870 871 case Nkind (Node) is 872 when N_Abort_Statement => 873 Write_Indent_Str_Sloc ("abort "); 874 Sprint_Comma_List (Names (Node)); 875 Write_Char (';'); 876 877 when N_Abortable_Part => 878 Set_Debug_Sloc; 879 Write_Str_Sloc ("abort "); 880 Sprint_Indented_List (Statements (Node)); 881 882 when N_Abstract_Subprogram_Declaration => 883 Write_Indent; 884 Sprint_Node (Specification (Node)); 885 Write_Str_With_Col_Check (" is "); 886 Write_Str_Sloc ("abstract;"); 887 888 when N_Accept_Alternative => 889 Sprint_Node_List (Pragmas_Before (Node)); 890 891 if Present (Condition (Node)) then 892 Write_Indent_Str ("when "); 893 Sprint_Node (Condition (Node)); 894 Write_Str (" => "); 895 Indent_Annull; 896 end if; 897 898 Sprint_Node_Sloc (Accept_Statement (Node)); 899 Sprint_Node_List (Statements (Node)); 900 901 when N_Accept_Statement => 902 Write_Indent_Str_Sloc ("accept "); 903 Write_Id (Entry_Direct_Name (Node)); 904 905 if Present (Entry_Index (Node)) then 906 Write_Str_With_Col_Check (" ("); 907 Sprint_Node (Entry_Index (Node)); 908 Write_Char (')'); 909 end if; 910 911 Write_Param_Specs (Node); 912 913 if Present (Handled_Statement_Sequence (Node)) then 914 Write_Str_With_Col_Check (" do"); 915 Sprint_Node (Handled_Statement_Sequence (Node)); 916 Write_Indent_Str ("end "); 917 Write_Id (Entry_Direct_Name (Node)); 918 end if; 919 920 Write_Char (';'); 921 922 when N_Access_Definition => 923 924 -- Ada 2005 (AI-254) 925 926 if Present (Access_To_Subprogram_Definition (Node)) then 927 Sprint_Node (Access_To_Subprogram_Definition (Node)); 928 else 929 -- Ada 2005 (AI-231) 930 931 if Null_Exclusion_Present (Node) then 932 Write_Str ("not null "); 933 end if; 934 935 Write_Str_With_Col_Check_Sloc ("access "); 936 937 if All_Present (Node) then 938 Write_Str ("all "); 939 elsif Constant_Present (Node) then 940 Write_Str ("constant "); 941 end if; 942 943 Sprint_Node (Subtype_Mark (Node)); 944 end if; 945 946 when N_Access_Function_Definition => 947 948 -- Ada 2005 (AI-231) 949 950 if Null_Exclusion_Present (Node) then 951 Write_Str ("not null "); 952 end if; 953 954 Write_Str_With_Col_Check_Sloc ("access "); 955 956 if Protected_Present (Node) then 957 Write_Str_With_Col_Check ("protected "); 958 end if; 959 960 Write_Str_With_Col_Check ("function"); 961 Write_Param_Specs (Node); 962 Write_Str_With_Col_Check (" return "); 963 Sprint_Node (Result_Definition (Node)); 964 965 when N_Access_Procedure_Definition => 966 967 -- Ada 2005 (AI-231) 968 969 if Null_Exclusion_Present (Node) then 970 Write_Str ("not null "); 971 end if; 972 973 Write_Str_With_Col_Check_Sloc ("access "); 974 975 if Protected_Present (Node) then 976 Write_Str_With_Col_Check ("protected "); 977 end if; 978 979 Write_Str_With_Col_Check ("procedure"); 980 Write_Param_Specs (Node); 981 982 when N_Access_To_Object_Definition => 983 Write_Str_With_Col_Check_Sloc ("access "); 984 985 if All_Present (Node) then 986 Write_Str_With_Col_Check ("all "); 987 elsif Constant_Present (Node) then 988 Write_Str_With_Col_Check ("constant "); 989 end if; 990 991 -- Ada 2005 (AI-231) 992 993 if Null_Exclusion_Present (Node) then 994 Write_Str ("not null "); 995 end if; 996 997 Sprint_Node (Subtype_Indication (Node)); 998 999 when N_Aggregate => 1000 if Null_Record_Present (Node) then 1001 Write_Str_With_Col_Check_Sloc ("(null record)"); 1002 1003 else 1004 Write_Str_With_Col_Check_Sloc ("("); 1005 1006 if Present (Expressions (Node)) then 1007 Sprint_Comma_List (Expressions (Node)); 1008 1009 if Present (Component_Associations (Node)) 1010 and then not Is_Empty_List (Component_Associations (Node)) 1011 then 1012 Write_Str (", "); 1013 end if; 1014 end if; 1015 1016 if Present (Component_Associations (Node)) 1017 and then not Is_Empty_List (Component_Associations (Node)) 1018 then 1019 Indent_Begin; 1020 1021 declare 1022 Nd : Node_Id; 1023 1024 begin 1025 Nd := First (Component_Associations (Node)); 1026 1027 loop 1028 Write_Indent; 1029 Sprint_Node (Nd); 1030 Next (Nd); 1031 exit when No (Nd); 1032 1033 if not Is_Rewrite_Insertion (Nd) 1034 or else not Dump_Original_Only 1035 then 1036 Write_Str (", "); 1037 end if; 1038 end loop; 1039 end; 1040 1041 Indent_End; 1042 end if; 1043 1044 Write_Char (')'); 1045 end if; 1046 1047 when N_Allocator => 1048 Write_Str_With_Col_Check_Sloc ("new "); 1049 1050 -- Ada 2005 (AI-231) 1051 1052 if Null_Exclusion_Present (Node) then 1053 Write_Str ("not null "); 1054 end if; 1055 1056 Sprint_Node (Expression (Node)); 1057 1058 if Present (Storage_Pool (Node)) then 1059 Write_Str_With_Col_Check ("[storage_pool = "); 1060 Sprint_Node (Storage_Pool (Node)); 1061 Write_Char (']'); 1062 end if; 1063 1064 when N_And_Then => 1065 Sprint_Left_Opnd (Node); 1066 Write_Str_Sloc (" and then "); 1067 Sprint_Right_Opnd (Node); 1068 1069 -- Note: the following code for N_Aspect_Specification is not 1070 -- normally used, since we deal with aspects as part of a 1071 -- declaration, but it is here in case we deliberately try 1072 -- to print an N_Aspect_Speficiation node (e.g. from GDB). 1073 1074 when N_Aspect_Specification => 1075 Sprint_Node (Identifier (Node)); 1076 Write_Str (" => "); 1077 Sprint_Node (Expression (Node)); 1078 1079 when N_Assignment_Statement => 1080 Write_Indent; 1081 Sprint_Node (Name (Node)); 1082 Write_Str_Sloc (" := "); 1083 Sprint_Node (Expression (Node)); 1084 Write_Char (';'); 1085 1086 when N_Asynchronous_Select => 1087 Write_Indent_Str_Sloc ("select"); 1088 Indent_Begin; 1089 Sprint_Node (Triggering_Alternative (Node)); 1090 Indent_End; 1091 1092 -- Note: let the printing of Abortable_Part handle outputting 1093 -- the ABORT keyword, so that the Sloc can be set correctly. 1094 1095 Write_Indent_Str ("then "); 1096 Sprint_Node (Abortable_Part (Node)); 1097 Write_Indent_Str ("end select;"); 1098 1099 when N_At_Clause => 1100 Write_Indent_Str_Sloc ("for "); 1101 Write_Id (Identifier (Node)); 1102 Write_Str_With_Col_Check (" use at "); 1103 Sprint_Node (Expression (Node)); 1104 Write_Char (';'); 1105 1106 when N_Attribute_Definition_Clause => 1107 Write_Indent_Str_Sloc ("for "); 1108 Sprint_Node (Name (Node)); 1109 Write_Char ('''); 1110 Write_Name_With_Col_Check (Chars (Node)); 1111 Write_Str_With_Col_Check (" use "); 1112 Sprint_Node (Expression (Node)); 1113 Write_Char (';'); 1114 1115 when N_Attribute_Reference => 1116 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then 1117 Write_Indent; 1118 end if; 1119 1120 Sprint_Node (Prefix (Node)); 1121 Write_Char_Sloc ('''); 1122 Write_Name_With_Col_Check (Attribute_Name (Node)); 1123 Sprint_Paren_Comma_List (Expressions (Node)); 1124 1125 if Is_Procedure_Attribute_Name (Attribute_Name (Node)) then 1126 Write_Char (';'); 1127 end if; 1128 1129 when N_Block_Statement => 1130 Write_Indent; 1131 1132 if Present (Identifier (Node)) 1133 and then (not Has_Created_Identifier (Node) 1134 or else not Dump_Original_Only) 1135 then 1136 Write_Rewrite_Str ("<<<"); 1137 Write_Id (Identifier (Node)); 1138 Write_Str (" : "); 1139 Write_Rewrite_Str (">>>"); 1140 end if; 1141 1142 if Present (Declarations (Node)) then 1143 Write_Str_With_Col_Check_Sloc ("declare"); 1144 Sprint_Indented_List (Declarations (Node)); 1145 Write_Indent; 1146 end if; 1147 1148 Write_Str_With_Col_Check_Sloc ("begin"); 1149 Sprint_Node (Handled_Statement_Sequence (Node)); 1150 Write_Indent_Str ("end"); 1151 1152 if Present (Identifier (Node)) 1153 and then (not Has_Created_Identifier (Node) 1154 or else not Dump_Original_Only) 1155 then 1156 Write_Rewrite_Str ("<<<"); 1157 Write_Char (' '); 1158 Write_Id (Identifier (Node)); 1159 Write_Rewrite_Str (">>>"); 1160 end if; 1161 1162 Write_Char (';'); 1163 1164 when N_Case_Expression => 1165 declare 1166 Has_Parens : constant Boolean := Paren_Count (Node) > 0; 1167 Alt : Node_Id; 1168 1169 begin 1170 -- The syntax for case_expression does not include parentheses, 1171 -- but sometimes parentheses are required, so unconditionally 1172 -- generate them here unless already present. 1173 1174 if not Has_Parens then 1175 Write_Char ('('); 1176 end if; 1177 1178 Write_Str_With_Col_Check_Sloc ("case "); 1179 Sprint_Node (Expression (Node)); 1180 Write_Str_With_Col_Check (" is"); 1181 1182 Alt := First (Alternatives (Node)); 1183 loop 1184 Sprint_Node (Alt); 1185 Next (Alt); 1186 exit when No (Alt); 1187 Write_Char (','); 1188 end loop; 1189 1190 if not Has_Parens then 1191 Write_Char (')'); 1192 end if; 1193 end; 1194 1195 when N_Case_Expression_Alternative => 1196 Write_Str_With_Col_Check (" when "); 1197 Sprint_Bar_List (Discrete_Choices (Node)); 1198 Write_Str (" => "); 1199 Sprint_Node (Expression (Node)); 1200 1201 when N_Case_Statement => 1202 Write_Indent_Str_Sloc ("case "); 1203 Sprint_Node (Expression (Node)); 1204 Write_Str (" is"); 1205 Sprint_Indented_List (Alternatives (Node)); 1206 Write_Indent_Str ("end case;"); 1207 1208 when N_Case_Statement_Alternative => 1209 Write_Indent_Str_Sloc ("when "); 1210 Sprint_Bar_List (Discrete_Choices (Node)); 1211 Write_Str (" => "); 1212 Sprint_Indented_List (Statements (Node)); 1213 1214 when N_Character_Literal => 1215 if Column > Sprint_Line_Limit - 2 then 1216 Write_Indent_Str (" "); 1217 end if; 1218 1219 Write_Char_Sloc ('''); 1220 Write_Char_Code (UI_To_CC (Char_Literal_Value (Node))); 1221 Write_Char ('''); 1222 1223 when N_Code_Statement => 1224 Write_Indent; 1225 Set_Debug_Sloc; 1226 Sprint_Node (Expression (Node)); 1227 Write_Char (';'); 1228 1229 when N_Compilation_Unit => 1230 Sprint_Node_List (Context_Items (Node)); 1231 Sprint_Opt_Node_List (Declarations (Aux_Decls_Node (Node))); 1232 1233 if Private_Present (Node) then 1234 Write_Indent_Str ("private "); 1235 Indent_Annull; 1236 end if; 1237 1238 Sprint_Node_Sloc (Unit (Node)); 1239 1240 if Present (Actions (Aux_Decls_Node (Node))) 1241 or else 1242 Present (Pragmas_After (Aux_Decls_Node (Node))) 1243 then 1244 Write_Indent; 1245 end if; 1246 1247 Sprint_Opt_Node_List (Actions (Aux_Decls_Node (Node))); 1248 Sprint_Opt_Node_List (Pragmas_After (Aux_Decls_Node (Node))); 1249 1250 when N_Compilation_Unit_Aux => 1251 null; -- nothing to do, never used, see above 1252 1253 when N_Component_Association => 1254 Set_Debug_Sloc; 1255 Sprint_Bar_List (Choices (Node)); 1256 Write_Str (" => "); 1257 1258 -- Ada 2005 (AI-287): Print the box if present 1259 1260 if Box_Present (Node) then 1261 Write_Str_With_Col_Check ("<>"); 1262 else 1263 Sprint_Node (Expression (Node)); 1264 end if; 1265 1266 when N_Component_Clause => 1267 Write_Indent; 1268 Sprint_Node (Component_Name (Node)); 1269 Write_Str_Sloc (" at "); 1270 Sprint_Node (Position (Node)); 1271 Write_Char (' '); 1272 Write_Str_With_Col_Check ("range "); 1273 Sprint_Node (First_Bit (Node)); 1274 Write_Str (" .. "); 1275 Sprint_Node (Last_Bit (Node)); 1276 Write_Char (';'); 1277 1278 when N_Component_Definition => 1279 Set_Debug_Sloc; 1280 1281 -- Ada 2005 (AI-230): Access definition components 1282 1283 if Present (Access_Definition (Node)) then 1284 Sprint_Node (Access_Definition (Node)); 1285 1286 elsif Present (Subtype_Indication (Node)) then 1287 if Aliased_Present (Node) then 1288 Write_Str_With_Col_Check ("aliased "); 1289 end if; 1290 1291 -- Ada 2005 (AI-231) 1292 1293 if Null_Exclusion_Present (Node) then 1294 Write_Str (" not null "); 1295 end if; 1296 1297 Sprint_Node (Subtype_Indication (Node)); 1298 1299 else 1300 Write_Str (" ??? "); 1301 end if; 1302 1303 when N_Component_Declaration => 1304 if Write_Indent_Identifiers_Sloc (Node) then 1305 Write_Str (" : "); 1306 Sprint_Node (Component_Definition (Node)); 1307 1308 if Present (Expression (Node)) then 1309 Write_Str (" := "); 1310 Sprint_Node (Expression (Node)); 1311 end if; 1312 1313 Write_Char (';'); 1314 end if; 1315 1316 when N_Component_List => 1317 if Null_Present (Node) then 1318 Indent_Begin; 1319 Write_Indent_Str_Sloc ("null"); 1320 Write_Char (';'); 1321 Indent_End; 1322 1323 else 1324 Set_Debug_Sloc; 1325 Sprint_Indented_List (Component_Items (Node)); 1326 Sprint_Node (Variant_Part (Node)); 1327 end if; 1328 1329 when N_Conditional_Entry_Call => 1330 Write_Indent_Str_Sloc ("select"); 1331 Indent_Begin; 1332 Sprint_Node (Entry_Call_Alternative (Node)); 1333 Indent_End; 1334 Write_Indent_Str ("else"); 1335 Sprint_Indented_List (Else_Statements (Node)); 1336 Write_Indent_Str ("end select;"); 1337 1338 when N_Constrained_Array_Definition => 1339 Write_Str_With_Col_Check_Sloc ("array "); 1340 Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node)); 1341 Write_Str (" of "); 1342 1343 Sprint_Node (Component_Definition (Node)); 1344 1345 -- A contract node should not appear in the tree. It is a semantic 1346 -- node attached to entry and [generic] subprogram entities. 1347 1348 when N_Contract => 1349 raise Program_Error; 1350 1351 when N_Decimal_Fixed_Point_Definition => 1352 Write_Str_With_Col_Check_Sloc (" delta "); 1353 Sprint_Node (Delta_Expression (Node)); 1354 Write_Str_With_Col_Check ("digits "); 1355 Sprint_Node (Digits_Expression (Node)); 1356 Sprint_Opt_Node (Real_Range_Specification (Node)); 1357 1358 when N_Defining_Character_Literal => 1359 Write_Name_With_Col_Check_Sloc (Chars (Node)); 1360 1361 when N_Defining_Identifier => 1362 Set_Debug_Sloc; 1363 Write_Id (Node); 1364 1365 when N_Defining_Operator_Symbol => 1366 Write_Name_With_Col_Check_Sloc (Chars (Node)); 1367 1368 when N_Defining_Program_Unit_Name => 1369 Set_Debug_Sloc; 1370 Sprint_Node (Name (Node)); 1371 Write_Char ('.'); 1372 Write_Id (Defining_Identifier (Node)); 1373 1374 when N_Delay_Alternative => 1375 Sprint_Node_List (Pragmas_Before (Node)); 1376 1377 if Present (Condition (Node)) then 1378 Write_Indent; 1379 Write_Str_With_Col_Check ("when "); 1380 Sprint_Node (Condition (Node)); 1381 Write_Str (" => "); 1382 Indent_Annull; 1383 end if; 1384 1385 Sprint_Node_Sloc (Delay_Statement (Node)); 1386 Sprint_Node_List (Statements (Node)); 1387 1388 when N_Delay_Relative_Statement => 1389 Write_Indent_Str_Sloc ("delay "); 1390 Sprint_Node (Expression (Node)); 1391 Write_Char (';'); 1392 1393 when N_Delay_Until_Statement => 1394 Write_Indent_Str_Sloc ("delay until "); 1395 Sprint_Node (Expression (Node)); 1396 Write_Char (';'); 1397 1398 when N_Delta_Constraint => 1399 Write_Str_With_Col_Check_Sloc ("delta "); 1400 Sprint_Node (Delta_Expression (Node)); 1401 Sprint_Opt_Node (Range_Constraint (Node)); 1402 1403 when N_Derived_Type_Definition => 1404 if Abstract_Present (Node) then 1405 Write_Str_With_Col_Check ("abstract "); 1406 end if; 1407 1408 Write_Str_With_Col_Check ("new "); 1409 1410 -- Ada 2005 (AI-231) 1411 1412 if Null_Exclusion_Present (Node) then 1413 Write_Str_With_Col_Check ("not null "); 1414 end if; 1415 1416 Sprint_Node (Subtype_Indication (Node)); 1417 1418 if Present (Interface_List (Node)) then 1419 Write_Str_With_Col_Check (" and "); 1420 Sprint_And_List (Interface_List (Node)); 1421 Write_Str_With_Col_Check (" with "); 1422 end if; 1423 1424 if Present (Record_Extension_Part (Node)) then 1425 if No (Interface_List (Node)) then 1426 Write_Str_With_Col_Check (" with "); 1427 end if; 1428 1429 Sprint_Node (Record_Extension_Part (Node)); 1430 end if; 1431 1432 when N_Designator => 1433 Sprint_Node (Name (Node)); 1434 Write_Char_Sloc ('.'); 1435 Write_Id (Identifier (Node)); 1436 1437 when N_Digits_Constraint => 1438 Write_Str_With_Col_Check_Sloc ("digits "); 1439 Sprint_Node (Digits_Expression (Node)); 1440 Sprint_Opt_Node (Range_Constraint (Node)); 1441 1442 when N_Discriminant_Association => 1443 Set_Debug_Sloc; 1444 1445 if Present (Selector_Names (Node)) then 1446 Sprint_Bar_List (Selector_Names (Node)); 1447 Write_Str (" => "); 1448 end if; 1449 1450 Set_Debug_Sloc; 1451 Sprint_Node (Expression (Node)); 1452 1453 when N_Discriminant_Specification => 1454 Set_Debug_Sloc; 1455 1456 if Write_Identifiers (Node) then 1457 Write_Str (" : "); 1458 1459 if Null_Exclusion_Present (Node) then 1460 Write_Str ("not null "); 1461 end if; 1462 1463 Sprint_Node (Discriminant_Type (Node)); 1464 1465 if Present (Expression (Node)) then 1466 Write_Str (" := "); 1467 Sprint_Node (Expression (Node)); 1468 end if; 1469 else 1470 Write_Str (", "); 1471 end if; 1472 1473 when N_Elsif_Part => 1474 Write_Indent_Str_Sloc ("elsif "); 1475 Sprint_Node (Condition (Node)); 1476 Write_Str_With_Col_Check (" then"); 1477 Sprint_Indented_List (Then_Statements (Node)); 1478 1479 when N_Empty => 1480 null; 1481 1482 when N_Entry_Body => 1483 Write_Indent_Str_Sloc ("entry "); 1484 Write_Id (Defining_Identifier (Node)); 1485 Sprint_Node (Entry_Body_Formal_Part (Node)); 1486 Write_Str_With_Col_Check (" is"); 1487 Sprint_Indented_List (Declarations (Node)); 1488 Write_Indent_Str ("begin"); 1489 Sprint_Node (Handled_Statement_Sequence (Node)); 1490 Write_Indent_Str ("end "); 1491 Write_Id (Defining_Identifier (Node)); 1492 Write_Char (';'); 1493 1494 when N_Entry_Body_Formal_Part => 1495 if Present (Entry_Index_Specification (Node)) then 1496 Write_Str_With_Col_Check_Sloc (" ("); 1497 Sprint_Node (Entry_Index_Specification (Node)); 1498 Write_Char (')'); 1499 end if; 1500 1501 Write_Param_Specs (Node); 1502 Write_Str_With_Col_Check_Sloc (" when "); 1503 Sprint_Node (Condition (Node)); 1504 1505 when N_Entry_Call_Alternative => 1506 Sprint_Node_List (Pragmas_Before (Node)); 1507 Sprint_Node_Sloc (Entry_Call_Statement (Node)); 1508 Sprint_Node_List (Statements (Node)); 1509 1510 when N_Entry_Call_Statement => 1511 Write_Indent; 1512 Sprint_Node_Sloc (Name (Node)); 1513 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); 1514 Write_Char (';'); 1515 1516 when N_Entry_Declaration => 1517 Write_Indent_Str_Sloc ("entry "); 1518 Write_Id (Defining_Identifier (Node)); 1519 1520 if Present (Discrete_Subtype_Definition (Node)) then 1521 Write_Str_With_Col_Check (" ("); 1522 Sprint_Node (Discrete_Subtype_Definition (Node)); 1523 Write_Char (')'); 1524 end if; 1525 1526 Write_Param_Specs (Node); 1527 Write_Char (';'); 1528 1529 when N_Entry_Index_Specification => 1530 Write_Str_With_Col_Check_Sloc ("for "); 1531 Write_Id (Defining_Identifier (Node)); 1532 Write_Str_With_Col_Check (" in "); 1533 Sprint_Node (Discrete_Subtype_Definition (Node)); 1534 1535 when N_Enumeration_Representation_Clause => 1536 Write_Indent_Str_Sloc ("for "); 1537 Write_Id (Identifier (Node)); 1538 Write_Str_With_Col_Check (" use "); 1539 Sprint_Node (Array_Aggregate (Node)); 1540 Write_Char (';'); 1541 1542 when N_Enumeration_Type_Definition => 1543 Set_Debug_Sloc; 1544 1545 -- Skip attempt to print Literals field if it's not there and 1546 -- we are in package Standard (case of Character, which is 1547 -- handled specially (without an explicit literals list). 1548 1549 if Sloc (Node) > Standard_Location 1550 or else Present (Literals (Node)) 1551 then 1552 Sprint_Paren_Comma_List (Literals (Node)); 1553 end if; 1554 1555 when N_Error => 1556 Write_Str_With_Col_Check_Sloc ("<error>"); 1557 1558 when N_Exception_Declaration => 1559 if Write_Indent_Identifiers (Node) then 1560 Write_Str_With_Col_Check (" : "); 1561 1562 if Is_Statically_Allocated (Defining_Identifier (Node)) then 1563 Write_Str_With_Col_Check ("static "); 1564 end if; 1565 1566 Write_Str_Sloc ("exception"); 1567 1568 if Present (Expression (Node)) then 1569 Write_Str (" := "); 1570 Sprint_Node (Expression (Node)); 1571 end if; 1572 1573 Write_Char (';'); 1574 end if; 1575 1576 when N_Exception_Handler => 1577 Write_Indent_Str_Sloc ("when "); 1578 1579 if Present (Choice_Parameter (Node)) then 1580 Sprint_Node (Choice_Parameter (Node)); 1581 Write_Str (" : "); 1582 end if; 1583 1584 Sprint_Bar_List (Exception_Choices (Node)); 1585 Write_Str (" => "); 1586 Sprint_Indented_List (Statements (Node)); 1587 1588 when N_Exception_Renaming_Declaration => 1589 Write_Indent; 1590 Set_Debug_Sloc; 1591 Sprint_Node (Defining_Identifier (Node)); 1592 Write_Str_With_Col_Check (" : exception renames "); 1593 Sprint_Node (Name (Node)); 1594 Write_Char (';'); 1595 1596 when N_Exit_Statement => 1597 Write_Indent_Str_Sloc ("exit"); 1598 Sprint_Opt_Node (Name (Node)); 1599 1600 if Present (Condition (Node)) then 1601 Write_Str_With_Col_Check (" when "); 1602 Sprint_Node (Condition (Node)); 1603 end if; 1604 1605 Write_Char (';'); 1606 1607 when N_Expanded_Name => 1608 Sprint_Node (Prefix (Node)); 1609 Write_Char_Sloc ('.'); 1610 Sprint_Node (Selector_Name (Node)); 1611 1612 when N_Explicit_Dereference => 1613 Sprint_Node (Prefix (Node)); 1614 Write_Char_Sloc ('.'); 1615 Write_Str_Sloc ("all"); 1616 1617 when N_Expression_With_Actions => 1618 Indent_Begin; 1619 Write_Indent_Str_Sloc ("do "); 1620 Indent_Begin; 1621 Sprint_Node_List (Actions (Node)); 1622 Indent_End; 1623 Write_Indent; 1624 Write_Str_With_Col_Check_Sloc ("in "); 1625 Sprint_Node (Expression (Node)); 1626 Write_Str_With_Col_Check (" end"); 1627 Indent_End; 1628 Write_Indent; 1629 1630 when N_Expression_Function => 1631 Write_Indent; 1632 Sprint_Node_Sloc (Specification (Node)); 1633 Write_Str (" is"); 1634 Indent_Begin; 1635 Write_Indent; 1636 Sprint_Node (Expression (Node)); 1637 Write_Char (';'); 1638 Indent_End; 1639 1640 when N_Extended_Return_Statement => 1641 Write_Indent_Str_Sloc ("return "); 1642 Sprint_Node_List (Return_Object_Declarations (Node)); 1643 1644 if Present (Handled_Statement_Sequence (Node)) then 1645 Write_Str_With_Col_Check (" do"); 1646 Sprint_Node (Handled_Statement_Sequence (Node)); 1647 Write_Indent_Str ("end return;"); 1648 else 1649 Write_Indent_Str (";"); 1650 end if; 1651 1652 when N_Extension_Aggregate => 1653 Write_Str_With_Col_Check_Sloc ("("); 1654 Sprint_Node (Ancestor_Part (Node)); 1655 Write_Str_With_Col_Check (" with "); 1656 1657 if Null_Record_Present (Node) then 1658 Write_Str_With_Col_Check ("null record"); 1659 else 1660 if Present (Expressions (Node)) then 1661 Sprint_Comma_List (Expressions (Node)); 1662 1663 if Present (Component_Associations (Node)) then 1664 Write_Str (", "); 1665 end if; 1666 end if; 1667 1668 if Present (Component_Associations (Node)) then 1669 Sprint_Comma_List (Component_Associations (Node)); 1670 end if; 1671 end if; 1672 1673 Write_Char (')'); 1674 1675 when N_Floating_Point_Definition => 1676 Write_Str_With_Col_Check_Sloc ("digits "); 1677 Sprint_Node (Digits_Expression (Node)); 1678 Sprint_Opt_Node (Real_Range_Specification (Node)); 1679 1680 when N_Formal_Decimal_Fixed_Point_Definition => 1681 Write_Str_With_Col_Check_Sloc ("delta <> digits <>"); 1682 1683 when N_Formal_Derived_Type_Definition => 1684 Write_Str_With_Col_Check_Sloc ("new "); 1685 Sprint_Node (Subtype_Mark (Node)); 1686 1687 if Present (Interface_List (Node)) then 1688 Write_Str_With_Col_Check (" and "); 1689 Sprint_And_List (Interface_List (Node)); 1690 end if; 1691 1692 if Private_Present (Node) then 1693 Write_Str_With_Col_Check (" with private"); 1694 end if; 1695 1696 when N_Formal_Abstract_Subprogram_Declaration => 1697 Write_Indent_Str_Sloc ("with "); 1698 Sprint_Node (Specification (Node)); 1699 1700 Write_Str_With_Col_Check (" is abstract"); 1701 1702 if Box_Present (Node) then 1703 Write_Str_With_Col_Check (" <>"); 1704 elsif Present (Default_Name (Node)) then 1705 Write_Str_With_Col_Check (" "); 1706 Sprint_Node (Default_Name (Node)); 1707 end if; 1708 1709 Write_Char (';'); 1710 1711 when N_Formal_Concrete_Subprogram_Declaration => 1712 Write_Indent_Str_Sloc ("with "); 1713 Sprint_Node (Specification (Node)); 1714 1715 if Box_Present (Node) then 1716 Write_Str_With_Col_Check (" is <>"); 1717 elsif Present (Default_Name (Node)) then 1718 Write_Str_With_Col_Check (" is "); 1719 Sprint_Node (Default_Name (Node)); 1720 end if; 1721 1722 Write_Char (';'); 1723 1724 when N_Formal_Discrete_Type_Definition => 1725 Write_Str_With_Col_Check_Sloc ("<>"); 1726 1727 when N_Formal_Floating_Point_Definition => 1728 Write_Str_With_Col_Check_Sloc ("digits <>"); 1729 1730 when N_Formal_Modular_Type_Definition => 1731 Write_Str_With_Col_Check_Sloc ("mod <>"); 1732 1733 when N_Formal_Object_Declaration => 1734 Set_Debug_Sloc; 1735 1736 if Write_Indent_Identifiers (Node) then 1737 Write_Str (" : "); 1738 1739 if In_Present (Node) then 1740 Write_Str_With_Col_Check ("in "); 1741 end if; 1742 1743 if Out_Present (Node) then 1744 Write_Str_With_Col_Check ("out "); 1745 end if; 1746 1747 if Present (Subtype_Mark (Node)) then 1748 1749 -- Ada 2005 (AI-423): Formal object with null exclusion 1750 1751 if Null_Exclusion_Present (Node) then 1752 Write_Str ("not null "); 1753 end if; 1754 1755 Sprint_Node (Subtype_Mark (Node)); 1756 1757 -- Ada 2005 (AI-423): Formal object with access definition 1758 1759 else 1760 pragma Assert (Present (Access_Definition (Node))); 1761 1762 Sprint_Node (Access_Definition (Node)); 1763 end if; 1764 1765 if Present (Default_Expression (Node)) then 1766 Write_Str (" := "); 1767 Sprint_Node (Default_Expression (Node)); 1768 end if; 1769 1770 Write_Char (';'); 1771 end if; 1772 1773 when N_Formal_Ordinary_Fixed_Point_Definition => 1774 Write_Str_With_Col_Check_Sloc ("delta <>"); 1775 1776 when N_Formal_Package_Declaration => 1777 Write_Indent_Str_Sloc ("with package "); 1778 Write_Id (Defining_Identifier (Node)); 1779 Write_Str_With_Col_Check (" is new "); 1780 Sprint_Node (Name (Node)); 1781 Write_Str_With_Col_Check (" (<>);"); 1782 1783 when N_Formal_Private_Type_Definition => 1784 if Abstract_Present (Node) then 1785 Write_Str_With_Col_Check ("abstract "); 1786 end if; 1787 1788 if Tagged_Present (Node) then 1789 Write_Str_With_Col_Check ("tagged "); 1790 end if; 1791 1792 if Limited_Present (Node) then 1793 Write_Str_With_Col_Check ("limited "); 1794 end if; 1795 1796 Write_Str_With_Col_Check_Sloc ("private"); 1797 1798 when N_Formal_Incomplete_Type_Definition => 1799 if Tagged_Present (Node) then 1800 Write_Str_With_Col_Check ("is tagged "); 1801 end if; 1802 1803 when N_Formal_Signed_Integer_Type_Definition => 1804 Write_Str_With_Col_Check_Sloc ("range <>"); 1805 1806 when N_Formal_Type_Declaration => 1807 Write_Indent_Str_Sloc ("type "); 1808 Write_Id (Defining_Identifier (Node)); 1809 1810 if Present (Discriminant_Specifications (Node)) then 1811 Write_Discr_Specs (Node); 1812 elsif Unknown_Discriminants_Present (Node) then 1813 Write_Str_With_Col_Check ("(<>)"); 1814 end if; 1815 1816 if Nkind (Formal_Type_Definition (Node)) /= 1817 N_Formal_Incomplete_Type_Definition 1818 then 1819 Write_Str_With_Col_Check (" is "); 1820 end if; 1821 1822 Sprint_Node (Formal_Type_Definition (Node)); 1823 Write_Char (';'); 1824 1825 when N_Free_Statement => 1826 Write_Indent_Str_Sloc ("free "); 1827 Sprint_Node (Expression (Node)); 1828 Write_Char (';'); 1829 1830 when N_Freeze_Entity => 1831 if Dump_Original_Only then 1832 null; 1833 1834 -- A freeze node is output if it has some effect (i.e. non-empty 1835 -- actions, or freeze node for an itype, which causes elaboration 1836 -- of the itype), and is also always output if Dump_Freeze_Null 1837 -- is set True. 1838 1839 elsif Present (Actions (Node)) 1840 or else Is_Itype (Entity (Node)) 1841 or else Dump_Freeze_Null 1842 then 1843 Write_Indent; 1844 Write_Rewrite_Str ("<<<"); 1845 Write_Str_With_Col_Check_Sloc ("freeze "); 1846 Write_Id (Entity (Node)); 1847 Write_Str (" ["); 1848 1849 if No (Actions (Node)) then 1850 Write_Char (']'); 1851 1852 else 1853 -- Output freeze actions. We increment Freeze_Indent during 1854 -- this output to avoid generating extra blank lines before 1855 -- any procedures included in the freeze actions. 1856 1857 Freeze_Indent := Freeze_Indent + 1; 1858 Sprint_Indented_List (Actions (Node)); 1859 Freeze_Indent := Freeze_Indent - 1; 1860 Write_Indent_Str ("]"); 1861 end if; 1862 1863 Write_Rewrite_Str (">>>"); 1864 end if; 1865 1866 when N_Freeze_Generic_Entity => 1867 if Dump_Original_Only then 1868 null; 1869 1870 else 1871 Write_Indent; 1872 Write_Str_With_Col_Check_Sloc ("freeze_generic "); 1873 Write_Id (Entity (Node)); 1874 end if; 1875 1876 when N_Full_Type_Declaration => 1877 Write_Indent_Str_Sloc ("type "); 1878 Sprint_Node (Defining_Identifier (Node)); 1879 Write_Discr_Specs (Node); 1880 Write_Str_With_Col_Check (" is "); 1881 Sprint_Node (Type_Definition (Node)); 1882 Write_Char (';'); 1883 1884 when N_Function_Call => 1885 Set_Debug_Sloc; 1886 Write_Subprogram_Name (Name (Node)); 1887 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); 1888 1889 when N_Function_Instantiation => 1890 Write_Indent_Str_Sloc ("function "); 1891 Sprint_Node (Defining_Unit_Name (Node)); 1892 Write_Str_With_Col_Check (" is new "); 1893 Sprint_Node (Name (Node)); 1894 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); 1895 Write_Char (';'); 1896 1897 when N_Function_Specification => 1898 Write_Str_With_Col_Check_Sloc ("function "); 1899 Sprint_Node (Defining_Unit_Name (Node)); 1900 Write_Param_Specs (Node); 1901 Write_Str_With_Col_Check (" return "); 1902 1903 -- Ada 2005 (AI-231) 1904 1905 if Nkind (Result_Definition (Node)) /= N_Access_Definition 1906 and then Null_Exclusion_Present (Node) 1907 then 1908 Write_Str (" not null "); 1909 end if; 1910 1911 Sprint_Node (Result_Definition (Node)); 1912 1913 when N_Generic_Association => 1914 Set_Debug_Sloc; 1915 1916 if Present (Selector_Name (Node)) then 1917 Sprint_Node (Selector_Name (Node)); 1918 Write_Str (" => "); 1919 end if; 1920 1921 Sprint_Node (Explicit_Generic_Actual_Parameter (Node)); 1922 1923 when N_Generic_Function_Renaming_Declaration => 1924 Write_Indent_Str_Sloc ("generic function "); 1925 Sprint_Node (Defining_Unit_Name (Node)); 1926 Write_Str_With_Col_Check (" renames "); 1927 Sprint_Node (Name (Node)); 1928 Write_Char (';'); 1929 1930 when N_Generic_Package_Declaration => 1931 Extra_Blank_Line; 1932 Write_Indent_Str_Sloc ("generic "); 1933 Sprint_Indented_List (Generic_Formal_Declarations (Node)); 1934 Write_Indent; 1935 Sprint_Node (Specification (Node)); 1936 Write_Char (';'); 1937 1938 when N_Generic_Package_Renaming_Declaration => 1939 Write_Indent_Str_Sloc ("generic package "); 1940 Sprint_Node (Defining_Unit_Name (Node)); 1941 Write_Str_With_Col_Check (" renames "); 1942 Sprint_Node (Name (Node)); 1943 Write_Char (';'); 1944 1945 when N_Generic_Procedure_Renaming_Declaration => 1946 Write_Indent_Str_Sloc ("generic procedure "); 1947 Sprint_Node (Defining_Unit_Name (Node)); 1948 Write_Str_With_Col_Check (" renames "); 1949 Sprint_Node (Name (Node)); 1950 Write_Char (';'); 1951 1952 when N_Generic_Subprogram_Declaration => 1953 Extra_Blank_Line; 1954 Write_Indent_Str_Sloc ("generic "); 1955 Sprint_Indented_List (Generic_Formal_Declarations (Node)); 1956 Write_Indent; 1957 Sprint_Node (Specification (Node)); 1958 Write_Char (';'); 1959 1960 when N_Goto_Statement => 1961 Write_Indent_Str_Sloc ("goto "); 1962 Sprint_Node (Name (Node)); 1963 Write_Char (';'); 1964 1965 if Nkind (Next (Node)) = N_Label then 1966 Write_Indent; 1967 end if; 1968 1969 when N_Handled_Sequence_Of_Statements => 1970 Set_Debug_Sloc; 1971 Sprint_Indented_List (Statements (Node)); 1972 1973 if Present (Exception_Handlers (Node)) then 1974 Write_Indent_Str ("exception"); 1975 Indent_Begin; 1976 Sprint_Node_List (Exception_Handlers (Node)); 1977 Indent_End; 1978 end if; 1979 1980 if Present (At_End_Proc (Node)) then 1981 Write_Indent_Str ("at end"); 1982 Indent_Begin; 1983 Write_Indent; 1984 Sprint_Node (At_End_Proc (Node)); 1985 Write_Char (';'); 1986 Indent_End; 1987 end if; 1988 1989 when N_Identifier => 1990 Set_Debug_Sloc; 1991 Write_Id (Node); 1992 1993 when N_If_Expression => 1994 declare 1995 Has_Parens : constant Boolean := Paren_Count (Node) > 0; 1996 Condition : constant Node_Id := First (Expressions (Node)); 1997 Then_Expr : constant Node_Id := Next (Condition); 1998 1999 begin 2000 -- The syntax for if_expression does not include parentheses, 2001 -- but sometimes parentheses are required, so unconditionally 2002 -- generate them here unless already present. 2003 2004 if not Has_Parens then 2005 Write_Char ('('); 2006 end if; 2007 2008 Write_Str_With_Col_Check_Sloc ("if "); 2009 Sprint_Node (Condition); 2010 Write_Str_With_Col_Check (" then "); 2011 2012 -- Defense against junk here 2013 2014 if Present (Then_Expr) then 2015 Sprint_Node (Then_Expr); 2016 2017 if Present (Next (Then_Expr)) then 2018 Write_Str_With_Col_Check (" else "); 2019 Sprint_Node (Next (Then_Expr)); 2020 end if; 2021 end if; 2022 2023 if not Has_Parens then 2024 Write_Char (')'); 2025 end if; 2026 end; 2027 2028 when N_If_Statement => 2029 Write_Indent_Str_Sloc ("if "); 2030 Sprint_Node (Condition (Node)); 2031 Write_Str_With_Col_Check (" then"); 2032 Sprint_Indented_List (Then_Statements (Node)); 2033 Sprint_Opt_Node_List (Elsif_Parts (Node)); 2034 2035 if Present (Else_Statements (Node)) then 2036 Write_Indent_Str ("else"); 2037 Sprint_Indented_List (Else_Statements (Node)); 2038 end if; 2039 2040 Write_Indent_Str ("end if;"); 2041 2042 when N_Implicit_Label_Declaration => 2043 if not Dump_Original_Only then 2044 Write_Indent; 2045 Write_Rewrite_Str ("<<<"); 2046 Set_Debug_Sloc; 2047 Write_Id (Defining_Identifier (Node)); 2048 Write_Str (" : "); 2049 Write_Str_With_Col_Check ("label"); 2050 Write_Rewrite_Str (">>>"); 2051 end if; 2052 2053 when N_In => 2054 Sprint_Left_Opnd (Node); 2055 Write_Str_Sloc (" in "); 2056 2057 if Present (Right_Opnd (Node)) then 2058 Sprint_Right_Opnd (Node); 2059 else 2060 Sprint_Bar_List (Alternatives (Node)); 2061 end if; 2062 2063 when N_Incomplete_Type_Declaration => 2064 Write_Indent_Str_Sloc ("type "); 2065 Write_Id (Defining_Identifier (Node)); 2066 2067 if Present (Discriminant_Specifications (Node)) then 2068 Write_Discr_Specs (Node); 2069 elsif Unknown_Discriminants_Present (Node) then 2070 Write_Str_With_Col_Check ("(<>)"); 2071 end if; 2072 2073 Write_Char (';'); 2074 2075 when N_Index_Or_Discriminant_Constraint => 2076 Set_Debug_Sloc; 2077 Sprint_Paren_Comma_List (Constraints (Node)); 2078 2079 when N_Indexed_Component => 2080 Sprint_Node_Sloc (Prefix (Node)); 2081 Sprint_Opt_Paren_Comma_List (Expressions (Node)); 2082 2083 when N_Integer_Literal => 2084 if Print_In_Hex (Node) then 2085 Write_Uint_With_Col_Check_Sloc (Intval (Node), Hex); 2086 else 2087 Write_Uint_With_Col_Check_Sloc (Intval (Node), Auto); 2088 end if; 2089 2090 when N_Iteration_Scheme => 2091 if Present (Condition (Node)) then 2092 Write_Str_With_Col_Check_Sloc ("while "); 2093 Sprint_Node (Condition (Node)); 2094 else 2095 Write_Str_With_Col_Check_Sloc ("for "); 2096 2097 if Present (Iterator_Specification (Node)) then 2098 Sprint_Node (Iterator_Specification (Node)); 2099 else 2100 Sprint_Node (Loop_Parameter_Specification (Node)); 2101 end if; 2102 end if; 2103 2104 Write_Char (' '); 2105 2106 when N_Iterator_Specification => 2107 Set_Debug_Sloc; 2108 Write_Id (Defining_Identifier (Node)); 2109 2110 if Present (Subtype_Indication (Node)) then 2111 Write_Str_With_Col_Check (" : "); 2112 Sprint_Node (Subtype_Indication (Node)); 2113 end if; 2114 2115 if Of_Present (Node) then 2116 Write_Str_With_Col_Check (" of "); 2117 else 2118 Write_Str_With_Col_Check (" in "); 2119 end if; 2120 2121 if Reverse_Present (Node) then 2122 Write_Str_With_Col_Check ("reverse "); 2123 end if; 2124 2125 Sprint_Node (Name (Node)); 2126 2127 when N_Itype_Reference => 2128 Write_Indent_Str_Sloc ("reference "); 2129 Write_Id (Itype (Node)); 2130 2131 when N_Label => 2132 Write_Indent_Str_Sloc ("<<"); 2133 Write_Id (Identifier (Node)); 2134 Write_Str (">>"); 2135 2136 when N_Loop_Parameter_Specification => 2137 Set_Debug_Sloc; 2138 Write_Id (Defining_Identifier (Node)); 2139 Write_Str_With_Col_Check (" in "); 2140 2141 if Reverse_Present (Node) then 2142 Write_Str_With_Col_Check ("reverse "); 2143 end if; 2144 2145 Sprint_Node (Discrete_Subtype_Definition (Node)); 2146 2147 when N_Loop_Statement => 2148 Write_Indent; 2149 2150 if Present (Identifier (Node)) 2151 and then (not Has_Created_Identifier (Node) 2152 or else not Dump_Original_Only) 2153 then 2154 Write_Rewrite_Str ("<<<"); 2155 Write_Id (Identifier (Node)); 2156 Write_Str (" : "); 2157 Write_Rewrite_Str (">>>"); 2158 Sprint_Node (Iteration_Scheme (Node)); 2159 Write_Str_With_Col_Check_Sloc ("loop"); 2160 Sprint_Indented_List (Statements (Node)); 2161 Write_Indent_Str ("end loop "); 2162 Write_Rewrite_Str ("<<<"); 2163 Write_Id (Identifier (Node)); 2164 Write_Rewrite_Str (">>>"); 2165 Write_Char (';'); 2166 2167 else 2168 Sprint_Node (Iteration_Scheme (Node)); 2169 Write_Str_With_Col_Check_Sloc ("loop"); 2170 Sprint_Indented_List (Statements (Node)); 2171 Write_Indent_Str ("end loop;"); 2172 end if; 2173 2174 when N_Mod_Clause => 2175 Sprint_Node_List (Pragmas_Before (Node)); 2176 Write_Str_With_Col_Check_Sloc ("at mod "); 2177 Sprint_Node (Expression (Node)); 2178 2179 when N_Modular_Type_Definition => 2180 Write_Str_With_Col_Check_Sloc ("mod "); 2181 Sprint_Node (Expression (Node)); 2182 2183 when N_Not_In => 2184 Sprint_Left_Opnd (Node); 2185 Write_Str_Sloc (" not in "); 2186 2187 if Present (Right_Opnd (Node)) then 2188 Sprint_Right_Opnd (Node); 2189 else 2190 Sprint_Bar_List (Alternatives (Node)); 2191 end if; 2192 2193 when N_Null => 2194 Write_Str_With_Col_Check_Sloc ("null"); 2195 2196 when N_Null_Statement => 2197 if Comes_From_Source (Node) 2198 or else Dump_Freeze_Null 2199 or else not Is_List_Member (Node) 2200 or else (No (Prev (Node)) and then No (Next (Node))) 2201 then 2202 Write_Indent_Str_Sloc ("null;"); 2203 end if; 2204 2205 when N_Number_Declaration => 2206 Set_Debug_Sloc; 2207 2208 if Write_Indent_Identifiers (Node) then 2209 Write_Str_With_Col_Check (" : constant "); 2210 Write_Str (" := "); 2211 Sprint_Node (Expression (Node)); 2212 Write_Char (';'); 2213 end if; 2214 2215 when N_Object_Declaration => 2216 Set_Debug_Sloc; 2217 2218 if Write_Indent_Identifiers (Node) then 2219 declare 2220 Def_Id : constant Entity_Id := Defining_Identifier (Node); 2221 2222 begin 2223 Write_Str_With_Col_Check (" : "); 2224 2225 if Is_Statically_Allocated (Def_Id) then 2226 Write_Str_With_Col_Check ("static "); 2227 end if; 2228 2229 if Aliased_Present (Node) then 2230 Write_Str_With_Col_Check ("aliased "); 2231 end if; 2232 2233 if Constant_Present (Node) then 2234 Write_Str_With_Col_Check ("constant "); 2235 end if; 2236 2237 -- Ada 2005 (AI-231) 2238 2239 if Null_Exclusion_Present (Node) then 2240 Write_Str_With_Col_Check ("not null "); 2241 end if; 2242 2243 Sprint_Node (Object_Definition (Node)); 2244 2245 if Present (Expression (Node)) then 2246 Write_Str (" := "); 2247 Sprint_Node (Expression (Node)); 2248 end if; 2249 2250 Write_Char (';'); 2251 2252 -- Handle implicit importation and implicit exportation of 2253 -- object declarations: 2254 -- $pragma import (Convention_Id, Def_Id, "..."); 2255 -- $pragma export (Convention_Id, Def_Id, "..."); 2256 2257 if Is_Internal (Def_Id) 2258 and then Present (Interface_Name (Def_Id)) 2259 then 2260 Write_Indent_Str_Sloc ("$pragma "); 2261 2262 if Is_Imported (Def_Id) then 2263 Write_Str ("import ("); 2264 2265 else pragma Assert (Is_Exported (Def_Id)); 2266 Write_Str ("export ("); 2267 end if; 2268 2269 declare 2270 Prefix : constant String := "Convention_"; 2271 S : constant String := Convention (Def_Id)'Img; 2272 2273 begin 2274 Name_Len := S'Last - Prefix'Last; 2275 Name_Buffer (1 .. Name_Len) := 2276 S (Prefix'Last + 1 .. S'Last); 2277 Set_Casing (All_Lower_Case); 2278 Write_Str (Name_Buffer (1 .. Name_Len)); 2279 end; 2280 2281 Write_Str (", "); 2282 Write_Id (Def_Id); 2283 Write_Str (", "); 2284 Write_String_Table_Entry 2285 (Strval (Interface_Name (Def_Id))); 2286 Write_Str (");"); 2287 end if; 2288 end; 2289 end if; 2290 2291 when N_Object_Renaming_Declaration => 2292 Write_Indent; 2293 Set_Debug_Sloc; 2294 Sprint_Node (Defining_Identifier (Node)); 2295 Write_Str (" : "); 2296 2297 -- Ada 2005 (AI-230): Access renamings 2298 2299 if Present (Access_Definition (Node)) then 2300 Sprint_Node (Access_Definition (Node)); 2301 2302 elsif Present (Subtype_Mark (Node)) then 2303 2304 -- Ada 2005 (AI-423): Object renaming with a null exclusion 2305 2306 if Null_Exclusion_Present (Node) then 2307 Write_Str ("not null "); 2308 end if; 2309 2310 Sprint_Node (Subtype_Mark (Node)); 2311 2312 else 2313 Write_Str (" ??? "); 2314 end if; 2315 2316 Write_Str_With_Col_Check (" renames "); 2317 Sprint_Node (Name (Node)); 2318 Write_Char (';'); 2319 2320 when N_Op_Abs => 2321 Write_Operator (Node, "abs "); 2322 Sprint_Right_Opnd (Node); 2323 2324 when N_Op_Add => 2325 Sprint_Left_Opnd (Node); 2326 Write_Operator (Node, " + "); 2327 Sprint_Right_Opnd (Node); 2328 2329 when N_Op_And => 2330 Sprint_Left_Opnd (Node); 2331 Write_Operator (Node, " and "); 2332 Sprint_Right_Opnd (Node); 2333 2334 when N_Op_Concat => 2335 Sprint_Left_Opnd (Node); 2336 Write_Operator (Node, " & "); 2337 Sprint_Right_Opnd (Node); 2338 2339 when N_Op_Divide => 2340 Sprint_Left_Opnd (Node); 2341 Write_Char (' '); 2342 Process_TFAI_RR_Flags (Node); 2343 Write_Operator (Node, "/ "); 2344 Sprint_Right_Opnd (Node); 2345 2346 when N_Op_Eq => 2347 Sprint_Left_Opnd (Node); 2348 Write_Operator (Node, " = "); 2349 Sprint_Right_Opnd (Node); 2350 2351 when N_Op_Expon => 2352 Sprint_Left_Opnd (Node); 2353 Write_Operator (Node, " ** "); 2354 Sprint_Right_Opnd (Node); 2355 2356 when N_Op_Ge => 2357 Sprint_Left_Opnd (Node); 2358 Write_Operator (Node, " >= "); 2359 Sprint_Right_Opnd (Node); 2360 2361 when N_Op_Gt => 2362 Sprint_Left_Opnd (Node); 2363 Write_Operator (Node, " > "); 2364 Sprint_Right_Opnd (Node); 2365 2366 when N_Op_Le => 2367 Sprint_Left_Opnd (Node); 2368 Write_Operator (Node, " <= "); 2369 Sprint_Right_Opnd (Node); 2370 2371 when N_Op_Lt => 2372 Sprint_Left_Opnd (Node); 2373 Write_Operator (Node, " < "); 2374 Sprint_Right_Opnd (Node); 2375 2376 when N_Op_Minus => 2377 Write_Operator (Node, "-"); 2378 Sprint_Right_Opnd (Node); 2379 2380 when N_Op_Mod => 2381 Sprint_Left_Opnd (Node); 2382 2383 if Treat_Fixed_As_Integer (Node) then 2384 Write_Str (" #"); 2385 end if; 2386 2387 Write_Operator (Node, " mod "); 2388 Sprint_Right_Opnd (Node); 2389 2390 when N_Op_Multiply => 2391 Sprint_Left_Opnd (Node); 2392 Write_Char (' '); 2393 Process_TFAI_RR_Flags (Node); 2394 Write_Operator (Node, "* "); 2395 Sprint_Right_Opnd (Node); 2396 2397 when N_Op_Ne => 2398 Sprint_Left_Opnd (Node); 2399 Write_Operator (Node, " /= "); 2400 Sprint_Right_Opnd (Node); 2401 2402 when N_Op_Not => 2403 Write_Operator (Node, "not "); 2404 Sprint_Right_Opnd (Node); 2405 2406 when N_Op_Or => 2407 Sprint_Left_Opnd (Node); 2408 Write_Operator (Node, " or "); 2409 Sprint_Right_Opnd (Node); 2410 2411 when N_Op_Plus => 2412 Write_Operator (Node, "+"); 2413 Sprint_Right_Opnd (Node); 2414 2415 when N_Op_Rem => 2416 Sprint_Left_Opnd (Node); 2417 2418 if Treat_Fixed_As_Integer (Node) then 2419 Write_Str (" #"); 2420 end if; 2421 2422 Write_Operator (Node, " rem "); 2423 Sprint_Right_Opnd (Node); 2424 2425 when N_Op_Shift => 2426 Set_Debug_Sloc; 2427 Write_Id (Node); 2428 Write_Char ('!'); 2429 Write_Str_With_Col_Check ("("); 2430 Sprint_Node (Left_Opnd (Node)); 2431 Write_Str (", "); 2432 Sprint_Node (Right_Opnd (Node)); 2433 Write_Char (')'); 2434 2435 when N_Op_Subtract => 2436 Sprint_Left_Opnd (Node); 2437 Write_Operator (Node, " - "); 2438 Sprint_Right_Opnd (Node); 2439 2440 when N_Op_Xor => 2441 Sprint_Left_Opnd (Node); 2442 Write_Operator (Node, " xor "); 2443 Sprint_Right_Opnd (Node); 2444 2445 when N_Operator_Symbol => 2446 Write_Name_With_Col_Check_Sloc (Chars (Node)); 2447 2448 when N_Ordinary_Fixed_Point_Definition => 2449 Write_Str_With_Col_Check_Sloc ("delta "); 2450 Sprint_Node (Delta_Expression (Node)); 2451 Sprint_Opt_Node (Real_Range_Specification (Node)); 2452 2453 when N_Or_Else => 2454 Sprint_Left_Opnd (Node); 2455 Write_Str_Sloc (" or else "); 2456 Sprint_Right_Opnd (Node); 2457 2458 when N_Others_Choice => 2459 if All_Others (Node) then 2460 Write_Str_With_Col_Check ("all "); 2461 end if; 2462 2463 Write_Str_With_Col_Check_Sloc ("others"); 2464 2465 when N_Package_Body => 2466 Extra_Blank_Line; 2467 Write_Indent_Str_Sloc ("package body "); 2468 Sprint_Node (Defining_Unit_Name (Node)); 2469 Write_Str (" is"); 2470 Sprint_Indented_List (Declarations (Node)); 2471 2472 if Present (Handled_Statement_Sequence (Node)) then 2473 Write_Indent_Str ("begin"); 2474 Sprint_Node (Handled_Statement_Sequence (Node)); 2475 end if; 2476 2477 Write_Indent_Str ("end "); 2478 Sprint_End_Label 2479 (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node)); 2480 Write_Char (';'); 2481 2482 when N_Package_Body_Stub => 2483 Write_Indent_Str_Sloc ("package body "); 2484 Sprint_Node (Defining_Identifier (Node)); 2485 Write_Str_With_Col_Check (" is separate;"); 2486 2487 when N_Package_Declaration => 2488 Extra_Blank_Line; 2489 Write_Indent; 2490 Sprint_Node_Sloc (Specification (Node)); 2491 Write_Char (';'); 2492 2493 -- If this is an instantiation, get the aspects from the original 2494 -- instantiation node. 2495 2496 if Is_Generic_Instance (Defining_Entity (Node)) 2497 and then Has_Aspects 2498 (Package_Instantiation (Defining_Entity (Node))) 2499 then 2500 Sprint_Aspect_Specifications 2501 (Package_Instantiation (Defining_Entity (Node)), 2502 Semicolon => True); 2503 end if; 2504 2505 when N_Package_Instantiation => 2506 Extra_Blank_Line; 2507 Write_Indent_Str_Sloc ("package "); 2508 Sprint_Node (Defining_Unit_Name (Node)); 2509 Write_Str (" is new "); 2510 Sprint_Node (Name (Node)); 2511 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); 2512 Write_Char (';'); 2513 2514 when N_Package_Renaming_Declaration => 2515 Write_Indent_Str_Sloc ("package "); 2516 Sprint_Node (Defining_Unit_Name (Node)); 2517 Write_Str_With_Col_Check (" renames "); 2518 Sprint_Node (Name (Node)); 2519 Write_Char (';'); 2520 2521 when N_Package_Specification => 2522 Write_Str_With_Col_Check_Sloc ("package "); 2523 Sprint_Node (Defining_Unit_Name (Node)); 2524 2525 if Nkind (Parent (Node)) = N_Generic_Package_Declaration 2526 and then Has_Aspects (Parent (Node)) 2527 then 2528 Sprint_Aspect_Specifications 2529 (Parent (Node), Semicolon => False); 2530 2531 -- An instantiation is rewritten as a package declaration, but 2532 -- the aspects belong to the instantiation node. 2533 2534 elsif Nkind (Parent (Node)) = N_Package_Declaration then 2535 declare 2536 Pack : constant Entity_Id := Defining_Entity (Node); 2537 2538 begin 2539 if not Is_Generic_Instance (Pack) then 2540 if Has_Aspects (Parent (Node)) then 2541 Sprint_Aspect_Specifications 2542 (Parent (Node), Semicolon => False); 2543 end if; 2544 end if; 2545 end; 2546 end if; 2547 2548 Write_Str (" is"); 2549 Sprint_Indented_List (Visible_Declarations (Node)); 2550 2551 if Present (Private_Declarations (Node)) then 2552 Write_Indent_Str ("private"); 2553 Sprint_Indented_List (Private_Declarations (Node)); 2554 end if; 2555 2556 Write_Indent_Str ("end "); 2557 Sprint_Node (Defining_Unit_Name (Node)); 2558 2559 when N_Parameter_Association => 2560 Sprint_Node_Sloc (Selector_Name (Node)); 2561 Write_Str (" => "); 2562 Sprint_Node (Explicit_Actual_Parameter (Node)); 2563 2564 when N_Parameter_Specification => 2565 Set_Debug_Sloc; 2566 2567 if Write_Identifiers (Node) then 2568 Write_Str (" : "); 2569 2570 if In_Present (Node) then 2571 Write_Str_With_Col_Check ("in "); 2572 end if; 2573 2574 if Out_Present (Node) then 2575 Write_Str_With_Col_Check ("out "); 2576 end if; 2577 2578 -- Ada 2005 (AI-231): Parameter specification may carry null 2579 -- exclusion. Do not print it now if this is an access formal, 2580 -- it is emitted when the access definition is displayed. 2581 2582 if Null_Exclusion_Present (Node) 2583 and then Nkind (Parameter_Type (Node)) 2584 /= N_Access_Definition 2585 then 2586 Write_Str ("not null "); 2587 end if; 2588 2589 Sprint_Node (Parameter_Type (Node)); 2590 2591 if Present (Expression (Node)) then 2592 Write_Str (" := "); 2593 Sprint_Node (Expression (Node)); 2594 end if; 2595 else 2596 Write_Str (", "); 2597 end if; 2598 2599 when N_Pop_Constraint_Error_Label => 2600 Write_Indent_Str ("%pop_constraint_error_label"); 2601 2602 when N_Pop_Program_Error_Label => 2603 Write_Indent_Str ("%pop_program_error_label"); 2604 2605 when N_Pop_Storage_Error_Label => 2606 Write_Indent_Str ("%pop_storage_error_label"); 2607 2608 when N_Private_Extension_Declaration => 2609 Write_Indent_Str_Sloc ("type "); 2610 Write_Id (Defining_Identifier (Node)); 2611 2612 if Present (Discriminant_Specifications (Node)) then 2613 Write_Discr_Specs (Node); 2614 elsif Unknown_Discriminants_Present (Node) then 2615 Write_Str_With_Col_Check ("(<>)"); 2616 end if; 2617 2618 Write_Str_With_Col_Check (" is new "); 2619 Sprint_Node (Subtype_Indication (Node)); 2620 2621 if Present (Interface_List (Node)) then 2622 Write_Str_With_Col_Check (" and "); 2623 Sprint_And_List (Interface_List (Node)); 2624 end if; 2625 2626 Write_Str_With_Col_Check (" with private;"); 2627 2628 when N_Private_Type_Declaration => 2629 Write_Indent_Str_Sloc ("type "); 2630 Write_Id (Defining_Identifier (Node)); 2631 2632 if Present (Discriminant_Specifications (Node)) then 2633 Write_Discr_Specs (Node); 2634 elsif Unknown_Discriminants_Present (Node) then 2635 Write_Str_With_Col_Check ("(<>)"); 2636 end if; 2637 2638 Write_Str (" is "); 2639 2640 if Tagged_Present (Node) then 2641 Write_Str_With_Col_Check ("tagged "); 2642 end if; 2643 2644 if Limited_Present (Node) then 2645 Write_Str_With_Col_Check ("limited "); 2646 end if; 2647 2648 Write_Str_With_Col_Check ("private;"); 2649 2650 when N_Push_Constraint_Error_Label => 2651 Write_Indent_Str ("%push_constraint_error_label ("); 2652 2653 if Present (Exception_Label (Node)) then 2654 Write_Name_With_Col_Check (Chars (Exception_Label (Node))); 2655 end if; 2656 2657 Write_Str (")"); 2658 2659 when N_Push_Program_Error_Label => 2660 Write_Indent_Str ("%push_program_error_label ("); 2661 2662 if Present (Exception_Label (Node)) then 2663 Write_Name_With_Col_Check (Chars (Exception_Label (Node))); 2664 end if; 2665 2666 Write_Str (")"); 2667 2668 when N_Push_Storage_Error_Label => 2669 Write_Indent_Str ("%push_storage_error_label ("); 2670 2671 if Present (Exception_Label (Node)) then 2672 Write_Name_With_Col_Check (Chars (Exception_Label (Node))); 2673 end if; 2674 2675 Write_Str (")"); 2676 2677 when N_Pragma => 2678 Write_Indent_Str_Sloc ("pragma "); 2679 Write_Name_With_Col_Check (Pragma_Name (Node)); 2680 2681 if Present (Pragma_Argument_Associations (Node)) then 2682 Sprint_Opt_Paren_Comma_List 2683 (Pragma_Argument_Associations (Node)); 2684 end if; 2685 2686 Write_Char (';'); 2687 2688 when N_Pragma_Argument_Association => 2689 Set_Debug_Sloc; 2690 2691 if Chars (Node) /= No_Name then 2692 Write_Name_With_Col_Check (Chars (Node)); 2693 Write_Str (" => "); 2694 end if; 2695 2696 Sprint_Node (Expression (Node)); 2697 2698 when N_Procedure_Call_Statement => 2699 Write_Indent; 2700 Set_Debug_Sloc; 2701 Write_Subprogram_Name (Name (Node)); 2702 Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); 2703 Write_Char (';'); 2704 2705 when N_Procedure_Instantiation => 2706 Write_Indent_Str_Sloc ("procedure "); 2707 Sprint_Node (Defining_Unit_Name (Node)); 2708 Write_Str_With_Col_Check (" is new "); 2709 Sprint_Node (Name (Node)); 2710 Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); 2711 Write_Char (';'); 2712 2713 when N_Procedure_Specification => 2714 Write_Str_With_Col_Check_Sloc ("procedure "); 2715 Sprint_Node (Defining_Unit_Name (Node)); 2716 Write_Param_Specs (Node); 2717 2718 when N_Protected_Body => 2719 Write_Indent_Str_Sloc ("protected body "); 2720 Write_Id (Defining_Identifier (Node)); 2721 Write_Str (" is"); 2722 Sprint_Indented_List (Declarations (Node)); 2723 Write_Indent_Str ("end "); 2724 Write_Id (Defining_Identifier (Node)); 2725 Write_Char (';'); 2726 2727 when N_Protected_Body_Stub => 2728 Write_Indent_Str_Sloc ("protected body "); 2729 Write_Id (Defining_Identifier (Node)); 2730 Write_Str_With_Col_Check (" is separate;"); 2731 2732 when N_Protected_Definition => 2733 Set_Debug_Sloc; 2734 Sprint_Indented_List (Visible_Declarations (Node)); 2735 2736 if Present (Private_Declarations (Node)) then 2737 Write_Indent_Str ("private"); 2738 Sprint_Indented_List (Private_Declarations (Node)); 2739 end if; 2740 2741 Write_Indent_Str ("end "); 2742 2743 when N_Protected_Type_Declaration => 2744 Write_Indent_Str_Sloc ("protected type "); 2745 Sprint_Node (Defining_Identifier (Node)); 2746 Write_Discr_Specs (Node); 2747 2748 if Present (Interface_List (Node)) then 2749 Write_Str (" is new "); 2750 Sprint_And_List (Interface_List (Node)); 2751 Write_Str (" with "); 2752 else 2753 Write_Str (" is"); 2754 end if; 2755 2756 Sprint_Node (Protected_Definition (Node)); 2757 Write_Id (Defining_Identifier (Node)); 2758 Write_Char (';'); 2759 2760 when N_Qualified_Expression => 2761 Sprint_Node (Subtype_Mark (Node)); 2762 Write_Char_Sloc ('''); 2763 2764 -- Print expression, make sure we have at least one level of 2765 -- parentheses around the expression. For cases of qualified 2766 -- expressions in the source, this is always the case, but 2767 -- for generated qualifications, there may be no explicit 2768 -- parentheses present. 2769 2770 if Paren_Count (Expression (Node)) /= 0 then 2771 Sprint_Node (Expression (Node)); 2772 2773 else 2774 Write_Char ('('); 2775 Sprint_Node (Expression (Node)); 2776 2777 -- Odd case, for the qualified expressions used in machine 2778 -- code the argument may be a procedure call, resulting in 2779 -- a junk semicolon before the right parent, get rid of it. 2780 2781 Write_Erase_Char (';'); 2782 2783 -- Now we can add the terminating right paren 2784 2785 Write_Char (')'); 2786 end if; 2787 2788 when N_Quantified_Expression => 2789 Write_Str (" for"); 2790 2791 if All_Present (Node) then 2792 Write_Str (" all "); 2793 else 2794 Write_Str (" some "); 2795 end if; 2796 2797 if Present (Iterator_Specification (Node)) then 2798 Sprint_Node (Iterator_Specification (Node)); 2799 else 2800 Sprint_Node (Loop_Parameter_Specification (Node)); 2801 end if; 2802 2803 Write_Str (" => "); 2804 Sprint_Node (Condition (Node)); 2805 2806 when N_Raise_Expression => 2807 declare 2808 Has_Parens : constant Boolean := Paren_Count (Node) > 0; 2809 2810 begin 2811 -- The syntax for raise_expression does not include parentheses 2812 -- but sometimes parentheses are required, so unconditionally 2813 -- generate them here unless already present. 2814 2815 if not Has_Parens then 2816 Write_Char ('('); 2817 end if; 2818 2819 Write_Str_With_Col_Check_Sloc ("raise "); 2820 Sprint_Node (Name (Node)); 2821 2822 if Present (Expression (Node)) then 2823 Write_Str_With_Col_Check (" with "); 2824 Sprint_Node (Expression (Node)); 2825 end if; 2826 2827 if not Has_Parens then 2828 Write_Char (')'); 2829 end if; 2830 end; 2831 2832 when N_Raise_Constraint_Error => 2833 2834 -- This node can be used either as a subexpression or as a 2835 -- statement form. The following test is a reasonably reliable 2836 -- way to distinguish the two cases. 2837 2838 if Is_List_Member (Node) 2839 and then Nkind (Parent (Node)) not in N_Subexpr 2840 then 2841 Write_Indent; 2842 end if; 2843 2844 Write_Str_With_Col_Check_Sloc ("[constraint_error"); 2845 Write_Condition_And_Reason (Node); 2846 2847 when N_Raise_Program_Error => 2848 2849 -- This node can be used either as a subexpression or as a 2850 -- statement form. The following test is a reasonably reliable 2851 -- way to distinguish the two cases. 2852 2853 if Is_List_Member (Node) 2854 and then Nkind (Parent (Node)) not in N_Subexpr 2855 then 2856 Write_Indent; 2857 end if; 2858 2859 Write_Str_With_Col_Check_Sloc ("[program_error"); 2860 Write_Condition_And_Reason (Node); 2861 2862 when N_Raise_Storage_Error => 2863 2864 -- This node can be used either as a subexpression or as a 2865 -- statement form. The following test is a reasonably reliable 2866 -- way to distinguish the two cases. 2867 2868 if Is_List_Member (Node) 2869 and then Nkind (Parent (Node)) not in N_Subexpr 2870 then 2871 Write_Indent; 2872 end if; 2873 2874 Write_Str_With_Col_Check_Sloc ("[storage_error"); 2875 Write_Condition_And_Reason (Node); 2876 2877 when N_Raise_Statement => 2878 Write_Indent_Str_Sloc ("raise "); 2879 Sprint_Node (Name (Node)); 2880 Write_Char (';'); 2881 2882 when N_Range => 2883 Sprint_Node (Low_Bound (Node)); 2884 Write_Str_Sloc (" .. "); 2885 Sprint_Node (High_Bound (Node)); 2886 Update_Itype (Node); 2887 2888 when N_Range_Constraint => 2889 Write_Str_With_Col_Check_Sloc ("range "); 2890 Sprint_Node (Range_Expression (Node)); 2891 2892 when N_Real_Literal => 2893 Write_Ureal_With_Col_Check_Sloc (Realval (Node)); 2894 2895 when N_Real_Range_Specification => 2896 Write_Str_With_Col_Check_Sloc ("range "); 2897 Sprint_Node (Low_Bound (Node)); 2898 Write_Str (" .. "); 2899 Sprint_Node (High_Bound (Node)); 2900 2901 when N_Record_Definition => 2902 if Abstract_Present (Node) then 2903 Write_Str_With_Col_Check ("abstract "); 2904 end if; 2905 2906 if Tagged_Present (Node) then 2907 Write_Str_With_Col_Check ("tagged "); 2908 end if; 2909 2910 if Limited_Present (Node) then 2911 Write_Str_With_Col_Check ("limited "); 2912 end if; 2913 2914 if Null_Present (Node) then 2915 Write_Str_With_Col_Check_Sloc ("null record"); 2916 2917 else 2918 Write_Str_With_Col_Check_Sloc ("record"); 2919 Sprint_Node (Component_List (Node)); 2920 Write_Indent_Str ("end record"); 2921 end if; 2922 2923 when N_Record_Representation_Clause => 2924 Write_Indent_Str_Sloc ("for "); 2925 Sprint_Node (Identifier (Node)); 2926 Write_Str_With_Col_Check (" use record "); 2927 2928 if Present (Mod_Clause (Node)) then 2929 Sprint_Node (Mod_Clause (Node)); 2930 end if; 2931 2932 Sprint_Indented_List (Component_Clauses (Node)); 2933 Write_Indent_Str ("end record;"); 2934 2935 when N_Reference => 2936 Sprint_Node (Prefix (Node)); 2937 Write_Str_With_Col_Check_Sloc ("'reference"); 2938 2939 when N_Requeue_Statement => 2940 Write_Indent_Str_Sloc ("requeue "); 2941 Sprint_Node (Name (Node)); 2942 2943 if Abort_Present (Node) then 2944 Write_Str_With_Col_Check (" with abort"); 2945 end if; 2946 2947 Write_Char (';'); 2948 2949 -- Don't we want to print more detail??? 2950 2951 -- Doc of this extended syntax belongs in sinfo.ads and/or 2952 -- sprint.ads ??? 2953 2954 when N_SCIL_Dispatch_Table_Tag_Init => 2955 Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); 2956 2957 when N_SCIL_Dispatching_Call => 2958 Write_Indent_Str ("[N_SCIL_Dispatching_Node]"); 2959 2960 when N_SCIL_Membership_Test => 2961 Write_Indent_Str ("[N_SCIL_Membership_Test]"); 2962 2963 when N_Simple_Return_Statement => 2964 if Present (Expression (Node)) then 2965 Write_Indent_Str_Sloc ("return "); 2966 Sprint_Node (Expression (Node)); 2967 Write_Char (';'); 2968 else 2969 Write_Indent_Str_Sloc ("return;"); 2970 end if; 2971 2972 when N_Selective_Accept => 2973 Write_Indent_Str_Sloc ("select"); 2974 2975 declare 2976 Alt_Node : Node_Id; 2977 begin 2978 Alt_Node := First (Select_Alternatives (Node)); 2979 loop 2980 Indent_Begin; 2981 Sprint_Node (Alt_Node); 2982 Indent_End; 2983 Next (Alt_Node); 2984 exit when No (Alt_Node); 2985 Write_Indent_Str ("or"); 2986 end loop; 2987 end; 2988 2989 if Present (Else_Statements (Node)) then 2990 Write_Indent_Str ("else"); 2991 Sprint_Indented_List (Else_Statements (Node)); 2992 end if; 2993 2994 Write_Indent_Str ("end select;"); 2995 2996 when N_Signed_Integer_Type_Definition => 2997 Write_Str_With_Col_Check_Sloc ("range "); 2998 Sprint_Node (Low_Bound (Node)); 2999 Write_Str (" .. "); 3000 Sprint_Node (High_Bound (Node)); 3001 3002 when N_Single_Protected_Declaration => 3003 Write_Indent_Str_Sloc ("protected "); 3004 Write_Id (Defining_Identifier (Node)); 3005 Write_Str (" is"); 3006 Sprint_Node (Protected_Definition (Node)); 3007 Write_Id (Defining_Identifier (Node)); 3008 Write_Char (';'); 3009 3010 when N_Single_Task_Declaration => 3011 Write_Indent_Str_Sloc ("task "); 3012 Sprint_Node (Defining_Identifier (Node)); 3013 3014 if Present (Task_Definition (Node)) then 3015 Write_Str (" is"); 3016 Sprint_Node (Task_Definition (Node)); 3017 end if; 3018 3019 Write_Char (';'); 3020 3021 when N_Selected_Component => 3022 Sprint_Node (Prefix (Node)); 3023 Write_Char_Sloc ('.'); 3024 Sprint_Node (Selector_Name (Node)); 3025 3026 when N_Slice => 3027 Set_Debug_Sloc; 3028 Sprint_Node (Prefix (Node)); 3029 Write_Str_With_Col_Check (" ("); 3030 Sprint_Node (Discrete_Range (Node)); 3031 Write_Char (')'); 3032 3033 when N_String_Literal => 3034 if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then 3035 Write_Indent_Str (" "); 3036 end if; 3037 3038 Set_Debug_Sloc; 3039 Write_String_Table_Entry (Strval (Node)); 3040 3041 when N_Subprogram_Body => 3042 3043 -- Output extra blank line unless we are in freeze actions 3044 3045 if Freeze_Indent = 0 then 3046 Extra_Blank_Line; 3047 end if; 3048 3049 Write_Indent; 3050 3051 if Present (Corresponding_Spec (Node)) then 3052 Sprint_Node_Sloc (Parent (Corresponding_Spec (Node))); 3053 else 3054 Sprint_Node_Sloc (Specification (Node)); 3055 end if; 3056 3057 Write_Str (" is"); 3058 3059 Sprint_Indented_List (Declarations (Node)); 3060 Write_Indent_Str ("begin"); 3061 Sprint_Node (Handled_Statement_Sequence (Node)); 3062 3063 Write_Indent_Str ("end "); 3064 3065 Sprint_End_Label 3066 (Handled_Statement_Sequence (Node), 3067 Defining_Unit_Name (Specification (Node))); 3068 Write_Char (';'); 3069 3070 if Is_List_Member (Node) 3071 and then Present (Next (Node)) 3072 and then Nkind (Next (Node)) /= N_Subprogram_Body 3073 then 3074 Write_Indent; 3075 end if; 3076 3077 when N_Subprogram_Body_Stub => 3078 Write_Indent; 3079 Sprint_Node_Sloc (Specification (Node)); 3080 Write_Str_With_Col_Check (" is separate;"); 3081 3082 when N_Subprogram_Declaration => 3083 Write_Indent; 3084 Sprint_Node_Sloc (Specification (Node)); 3085 3086 if Nkind (Specification (Node)) = N_Procedure_Specification 3087 and then Null_Present (Specification (Node)) 3088 then 3089 Write_Str_With_Col_Check (" is null"); 3090 end if; 3091 3092 Write_Char (';'); 3093 3094 when N_Subprogram_Renaming_Declaration => 3095 Write_Indent; 3096 Sprint_Node (Specification (Node)); 3097 Write_Str_With_Col_Check_Sloc (" renames "); 3098 Sprint_Node (Name (Node)); 3099 Write_Char (';'); 3100 3101 when N_Subtype_Declaration => 3102 Write_Indent_Str_Sloc ("subtype "); 3103 Sprint_Node (Defining_Identifier (Node)); 3104 Write_Str (" is "); 3105 3106 -- Ada 2005 (AI-231) 3107 3108 if Null_Exclusion_Present (Node) then 3109 Write_Str ("not null "); 3110 end if; 3111 3112 Sprint_Node (Subtype_Indication (Node)); 3113 Write_Char (';'); 3114 3115 when N_Subtype_Indication => 3116 Sprint_Node_Sloc (Subtype_Mark (Node)); 3117 Write_Char (' '); 3118 Sprint_Node (Constraint (Node)); 3119 3120 when N_Subunit => 3121 Write_Indent_Str_Sloc ("separate ("); 3122 Sprint_Node (Name (Node)); 3123 Write_Char (')'); 3124 Extra_Blank_Line; 3125 Sprint_Node (Proper_Body (Node)); 3126 3127 when N_Task_Body => 3128 Write_Indent_Str_Sloc ("task body "); 3129 Write_Id (Defining_Identifier (Node)); 3130 Write_Str (" is"); 3131 Sprint_Indented_List (Declarations (Node)); 3132 Write_Indent_Str ("begin"); 3133 Sprint_Node (Handled_Statement_Sequence (Node)); 3134 Write_Indent_Str ("end "); 3135 Sprint_End_Label 3136 (Handled_Statement_Sequence (Node), Defining_Identifier (Node)); 3137 Write_Char (';'); 3138 3139 when N_Task_Body_Stub => 3140 Write_Indent_Str_Sloc ("task body "); 3141 Write_Id (Defining_Identifier (Node)); 3142 Write_Str_With_Col_Check (" is separate;"); 3143 3144 when N_Task_Definition => 3145 Set_Debug_Sloc; 3146 Sprint_Indented_List (Visible_Declarations (Node)); 3147 3148 if Present (Private_Declarations (Node)) then 3149 Write_Indent_Str ("private"); 3150 Sprint_Indented_List (Private_Declarations (Node)); 3151 end if; 3152 3153 Write_Indent_Str ("end "); 3154 Sprint_End_Label (Node, Defining_Identifier (Parent (Node))); 3155 3156 when N_Task_Type_Declaration => 3157 Write_Indent_Str_Sloc ("task type "); 3158 Sprint_Node (Defining_Identifier (Node)); 3159 Write_Discr_Specs (Node); 3160 3161 if Present (Interface_List (Node)) then 3162 Write_Str (" is new "); 3163 Sprint_And_List (Interface_List (Node)); 3164 end if; 3165 3166 if Present (Task_Definition (Node)) then 3167 if No (Interface_List (Node)) then 3168 Write_Str (" is"); 3169 else 3170 Write_Str (" with "); 3171 end if; 3172 3173 Sprint_Node (Task_Definition (Node)); 3174 end if; 3175 3176 Write_Char (';'); 3177 3178 when N_Terminate_Alternative => 3179 Sprint_Node_List (Pragmas_Before (Node)); 3180 Write_Indent; 3181 3182 if Present (Condition (Node)) then 3183 Write_Str_With_Col_Check ("when "); 3184 Sprint_Node (Condition (Node)); 3185 Write_Str (" => "); 3186 end if; 3187 3188 Write_Str_With_Col_Check_Sloc ("terminate;"); 3189 Sprint_Node_List (Pragmas_After (Node)); 3190 3191 when N_Timed_Entry_Call => 3192 Write_Indent_Str_Sloc ("select"); 3193 Indent_Begin; 3194 Sprint_Node (Entry_Call_Alternative (Node)); 3195 Indent_End; 3196 Write_Indent_Str ("or"); 3197 Indent_Begin; 3198 Sprint_Node (Delay_Alternative (Node)); 3199 Indent_End; 3200 Write_Indent_Str ("end select;"); 3201 3202 when N_Triggering_Alternative => 3203 Sprint_Node_List (Pragmas_Before (Node)); 3204 Sprint_Node_Sloc (Triggering_Statement (Node)); 3205 Sprint_Node_List (Statements (Node)); 3206 3207 when N_Type_Conversion => 3208 Set_Debug_Sloc; 3209 Sprint_Node (Subtype_Mark (Node)); 3210 Col_Check (4); 3211 3212 if Conversion_OK (Node) then 3213 Write_Char ('?'); 3214 end if; 3215 3216 if Float_Truncate (Node) then 3217 Write_Char ('^'); 3218 end if; 3219 3220 if Rounded_Result (Node) then 3221 Write_Char ('@'); 3222 end if; 3223 3224 Write_Char ('('); 3225 Sprint_Node (Expression (Node)); 3226 Write_Char (')'); 3227 3228 when N_Unchecked_Expression => 3229 Col_Check (10); 3230 Write_Str ("`("); 3231 Sprint_Node_Sloc (Expression (Node)); 3232 Write_Char (')'); 3233 3234 when N_Unchecked_Type_Conversion => 3235 Sprint_Node (Subtype_Mark (Node)); 3236 Write_Char ('!'); 3237 Write_Str_With_Col_Check ("("); 3238 Sprint_Node_Sloc (Expression (Node)); 3239 Write_Char (')'); 3240 3241 when N_Unconstrained_Array_Definition => 3242 Write_Str_With_Col_Check_Sloc ("array ("); 3243 3244 declare 3245 Node1 : Node_Id; 3246 begin 3247 Node1 := First (Subtype_Marks (Node)); 3248 loop 3249 Sprint_Node (Node1); 3250 Write_Str_With_Col_Check (" range <>"); 3251 Next (Node1); 3252 exit when Node1 = Empty; 3253 Write_Str (", "); 3254 end loop; 3255 end; 3256 3257 Write_Str (") of "); 3258 Sprint_Node (Component_Definition (Node)); 3259 3260 when N_Unused_At_Start | N_Unused_At_End => 3261 Write_Indent_Str ("***** Error, unused node encountered *****"); 3262 Write_Eol; 3263 3264 when N_Use_Package_Clause => 3265 Write_Indent_Str_Sloc ("use "); 3266 Sprint_Comma_List (Names (Node)); 3267 Write_Char (';'); 3268 3269 when N_Use_Type_Clause => 3270 Write_Indent_Str_Sloc ("use type "); 3271 Sprint_Comma_List (Subtype_Marks (Node)); 3272 Write_Char (';'); 3273 3274 when N_Validate_Unchecked_Conversion => 3275 Write_Indent_Str_Sloc ("validate unchecked_conversion ("); 3276 Sprint_Node (Source_Type (Node)); 3277 Write_Str (", "); 3278 Sprint_Node (Target_Type (Node)); 3279 Write_Str (");"); 3280 3281 when N_Variant => 3282 Write_Indent_Str_Sloc ("when "); 3283 Sprint_Bar_List (Discrete_Choices (Node)); 3284 Write_Str (" => "); 3285 Sprint_Node (Component_List (Node)); 3286 3287 when N_Variant_Part => 3288 Indent_Begin; 3289 Write_Indent_Str_Sloc ("case "); 3290 Sprint_Node (Name (Node)); 3291 Write_Str (" is "); 3292 Sprint_Indented_List (Variants (Node)); 3293 Write_Indent_Str ("end case"); 3294 Indent_End; 3295 3296 when N_With_Clause => 3297 3298 -- Special test, if we are dumping the original tree only, 3299 -- then we want to eliminate the bogus with clauses that 3300 -- correspond to the non-existent children of Text_IO. 3301 3302 if Dump_Original_Only 3303 and then Is_Text_IO_Kludge_Unit (Name (Node)) 3304 then 3305 null; 3306 3307 -- Normal case, output the with clause 3308 3309 else 3310 if First_Name (Node) or else not Dump_Original_Only then 3311 3312 -- Ada 2005 (AI-50217): Print limited with_clauses 3313 3314 if Private_Present (Node) and Limited_Present (Node) then 3315 Write_Indent_Str ("limited private with "); 3316 3317 elsif Private_Present (Node) then 3318 Write_Indent_Str ("private with "); 3319 3320 elsif Limited_Present (Node) then 3321 Write_Indent_Str ("limited with "); 3322 3323 else 3324 Write_Indent_Str ("with "); 3325 end if; 3326 3327 else 3328 Write_Str (", "); 3329 end if; 3330 3331 Sprint_Node_Sloc (Name (Node)); 3332 3333 if Last_Name (Node) or else not Dump_Original_Only then 3334 Write_Char (';'); 3335 end if; 3336 end if; 3337 end case; 3338 3339 -- Print aspects, except for special case of package declaration, 3340 -- where the aspects are printed inside the package specification. 3341 3342 if Has_Aspects (Node) 3343 and then not Nkind_In (Node, N_Package_Declaration, 3344 N_Generic_Package_Declaration) 3345 then 3346 Sprint_Aspect_Specifications (Node, Semicolon => True); 3347 end if; 3348 3349 if Nkind (Node) in N_Subexpr 3350 and then Do_Range_Check (Node) 3351 then 3352 Write_Str ("}"); 3353 end if; 3354 3355 for J in 1 .. Paren_Count (Node) loop 3356 Write_Char (')'); 3357 end loop; 3358 3359 Dump_Node := Save_Dump_Node; 3360 end Sprint_Node_Actual; 3361 3362 ---------------------- 3363 -- Sprint_Node_List -- 3364 ---------------------- 3365 3366 procedure Sprint_Node_List (List : List_Id; New_Lines : Boolean := False) is 3367 Node : Node_Id; 3368 3369 begin 3370 if Is_Non_Empty_List (List) then 3371 Node := First (List); 3372 3373 loop 3374 Sprint_Node (Node); 3375 Next (Node); 3376 exit when Node = Empty; 3377 end loop; 3378 end if; 3379 3380 if New_Lines and then Column /= 1 then 3381 Write_Eol; 3382 end if; 3383 end Sprint_Node_List; 3384 3385 ---------------------- 3386 -- Sprint_Node_Sloc -- 3387 ---------------------- 3388 3389 procedure Sprint_Node_Sloc (Node : Node_Id) is 3390 begin 3391 Sprint_Node (Node); 3392 3393 if Debug_Generated_Code and then Present (Dump_Node) then 3394 Set_Sloc (Dump_Node, Sloc (Node)); 3395 Dump_Node := Empty; 3396 end if; 3397 end Sprint_Node_Sloc; 3398 3399 --------------------- 3400 -- Sprint_Opt_Node -- 3401 --------------------- 3402 3403 procedure Sprint_Opt_Node (Node : Node_Id) is 3404 begin 3405 if Present (Node) then 3406 Write_Char (' '); 3407 Sprint_Node (Node); 3408 end if; 3409 end Sprint_Opt_Node; 3410 3411 -------------------------- 3412 -- Sprint_Opt_Node_List -- 3413 -------------------------- 3414 3415 procedure Sprint_Opt_Node_List (List : List_Id) is 3416 begin 3417 if Present (List) then 3418 Sprint_Node_List (List); 3419 end if; 3420 end Sprint_Opt_Node_List; 3421 3422 --------------------------------- 3423 -- Sprint_Opt_Paren_Comma_List -- 3424 --------------------------------- 3425 3426 procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is 3427 begin 3428 if Is_Non_Empty_List (List) then 3429 Write_Char (' '); 3430 Sprint_Paren_Comma_List (List); 3431 end if; 3432 end Sprint_Opt_Paren_Comma_List; 3433 3434 ----------------------------- 3435 -- Sprint_Paren_Comma_List -- 3436 ----------------------------- 3437 3438 procedure Sprint_Paren_Comma_List (List : List_Id) is 3439 N : Node_Id; 3440 Node_Exists : Boolean := False; 3441 3442 begin 3443 3444 if Is_Non_Empty_List (List) then 3445 3446 if Dump_Original_Only then 3447 N := First (List); 3448 while Present (N) loop 3449 if not Is_Rewrite_Insertion (N) then 3450 Node_Exists := True; 3451 exit; 3452 end if; 3453 3454 Next (N); 3455 end loop; 3456 3457 if not Node_Exists then 3458 return; 3459 end if; 3460 end if; 3461 3462 Write_Str_With_Col_Check ("("); 3463 Sprint_Comma_List (List); 3464 Write_Char (')'); 3465 end if; 3466 end Sprint_Paren_Comma_List; 3467 3468 ---------------------- 3469 -- Sprint_Right_Opnd -- 3470 ---------------------- 3471 3472 procedure Sprint_Right_Opnd (N : Node_Id) is 3473 Opnd : constant Node_Id := Right_Opnd (N); 3474 3475 begin 3476 if Paren_Count (Opnd) /= 0 3477 or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N)) 3478 then 3479 Sprint_Node (Opnd); 3480 3481 else 3482 Write_Char ('('); 3483 Sprint_Node (Opnd); 3484 Write_Char (')'); 3485 end if; 3486 end Sprint_Right_Opnd; 3487 3488 ------------------ 3489 -- Update_Itype -- 3490 ------------------ 3491 3492 procedure Update_Itype (Node : Node_Id) is 3493 begin 3494 if Present (Etype (Node)) 3495 and then Is_Itype (Etype (Node)) 3496 and then Debug_Generated_Code 3497 then 3498 Set_Sloc (Etype (Node), Sloc (Node)); 3499 end if; 3500 end Update_Itype; 3501 3502 --------------------- 3503 -- Write_Char_Sloc -- 3504 --------------------- 3505 3506 procedure Write_Char_Sloc (C : Character) is 3507 begin 3508 if Debug_Generated_Code and then C /= ' ' then 3509 Set_Debug_Sloc; 3510 end if; 3511 3512 Write_Char (C); 3513 end Write_Char_Sloc; 3514 3515 -------------------------------- 3516 -- Write_Condition_And_Reason -- 3517 -------------------------------- 3518 3519 procedure Write_Condition_And_Reason (Node : Node_Id) is 3520 Cond : constant Node_Id := Condition (Node); 3521 Image : constant String := RT_Exception_Code'Image 3522 (RT_Exception_Code'Val 3523 (UI_To_Int (Reason (Node)))); 3524 3525 begin 3526 if Present (Cond) then 3527 3528 -- If condition is a single entity, or NOT with a single entity, 3529 -- output all on one line, since it will likely fit just fine. 3530 3531 if Is_Entity_Name (Cond) 3532 or else (Nkind (Cond) = N_Op_Not 3533 and then Is_Entity_Name (Right_Opnd (Cond))) 3534 then 3535 Write_Str_With_Col_Check (" when "); 3536 Sprint_Node (Cond); 3537 Write_Char (' '); 3538 3539 -- Otherwise for more complex condition, multiple lines 3540 3541 else 3542 Write_Str_With_Col_Check (" when"); 3543 Indent := Indent + 2; 3544 Write_Indent; 3545 Sprint_Node (Cond); 3546 Write_Indent; 3547 Indent := Indent - 2; 3548 end if; 3549 3550 -- If no condition, just need a space (all on one line) 3551 3552 else 3553 Write_Char (' '); 3554 end if; 3555 3556 -- Write the reason 3557 3558 Write_Char ('"'); 3559 3560 for J in 4 .. Image'Last loop 3561 if Image (J) = '_' then 3562 Write_Char (' '); 3563 else 3564 Write_Char (Fold_Lower (Image (J))); 3565 end if; 3566 end loop; 3567 3568 Write_Str ("""]"); 3569 end Write_Condition_And_Reason; 3570 3571 -------------------------------- 3572 -- Write_Corresponding_Source -- 3573 -------------------------------- 3574 3575 procedure Write_Corresponding_Source (S : String) is 3576 Loc : Source_Ptr; 3577 Src : Source_Buffer_Ptr; 3578 3579 begin 3580 -- Ignore if not in dump source text mode, or if in freeze actions 3581 3582 if Dump_Source_Text and then Freeze_Indent = 0 then 3583 3584 -- Ignore null string 3585 3586 if S = "" then 3587 return; 3588 end if; 3589 3590 -- Ignore space or semicolon at end of given string 3591 3592 if S (S'Last) = ' ' or else S (S'Last) = ';' then 3593 Write_Corresponding_Source (S (S'First .. S'Last - 1)); 3594 return; 3595 end if; 3596 3597 -- Loop to look at next lines not yet printed in source file 3598 3599 for L in 3600 Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File) 3601 loop 3602 Src := Source_Text (Current_Source_File); 3603 Loc := Line_Start (L, Current_Source_File); 3604 3605 -- If comment, keep looking 3606 3607 if Src (Loc .. Loc + 1) = "--" then 3608 null; 3609 3610 -- Search to first non-blank 3611 3612 else 3613 while Src (Loc) not in Line_Terminator loop 3614 3615 -- Non-blank found 3616 3617 if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then 3618 3619 -- Loop through characters in string to see if we match 3620 3621 for J in S'Range loop 3622 3623 -- If mismatch, then not the case we are looking for 3624 3625 if Src (Loc) /= S (J) then 3626 return; 3627 end if; 3628 3629 Loc := Loc + 1; 3630 end loop; 3631 3632 -- If we fall through, string matched, if white space or 3633 -- semicolon after the matched string, this is the case 3634 -- we are looking for. 3635 3636 if Src (Loc) in Line_Terminator 3637 or else Src (Loc) = ' ' 3638 or else Src (Loc) = ASCII.HT 3639 or else Src (Loc) = ';' 3640 then 3641 -- So output source lines up to and including this one 3642 3643 Write_Source_Lines (L); 3644 return; 3645 end if; 3646 end if; 3647 3648 Loc := Loc + 1; 3649 end loop; 3650 end if; 3651 3652 -- Line was all blanks, or a comment line, keep looking 3653 3654 end loop; 3655 end if; 3656 end Write_Corresponding_Source; 3657 3658 ----------------------- 3659 -- Write_Discr_Specs -- 3660 ----------------------- 3661 3662 procedure Write_Discr_Specs (N : Node_Id) is 3663 Specs : List_Id; 3664 Spec : Node_Id; 3665 3666 begin 3667 Specs := Discriminant_Specifications (N); 3668 3669 if Present (Specs) then 3670 Write_Str_With_Col_Check (" ("); 3671 Spec := First (Specs); 3672 3673 loop 3674 Sprint_Node (Spec); 3675 Next (Spec); 3676 exit when Spec = Empty; 3677 3678 -- Add semicolon, unless we are printing original tree and the 3679 -- next specification is part of a list (but not the first 3680 -- element of that list) 3681 3682 if not Dump_Original_Only or else not Prev_Ids (Spec) then 3683 Write_Str ("; "); 3684 end if; 3685 end loop; 3686 3687 Write_Char (')'); 3688 end if; 3689 end Write_Discr_Specs; 3690 3691 ----------------- 3692 -- Write_Ekind -- 3693 ----------------- 3694 3695 procedure Write_Ekind (E : Entity_Id) is 3696 S : constant String := Entity_Kind'Image (Ekind (E)); 3697 3698 begin 3699 Name_Len := S'Length; 3700 Name_Buffer (1 .. Name_Len) := S; 3701 Set_Casing (Mixed_Case); 3702 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 3703 end Write_Ekind; 3704 3705 -------------- 3706 -- Write_Id -- 3707 -------------- 3708 3709 procedure Write_Id (N : Node_Id) is 3710 begin 3711 -- Deal with outputting Itype 3712 3713 -- Note: if we are printing the full tree with -gnatds, then we may 3714 -- end up picking up the Associated_Node link from a generic template 3715 -- here which overlaps the Entity field, but as documented, Write_Itype 3716 -- is defended against junk calls. 3717 3718 if Nkind (N) in N_Entity then 3719 Write_Itype (N); 3720 elsif Nkind (N) in N_Has_Entity then 3721 Write_Itype (Entity (N)); 3722 end if; 3723 3724 -- Case of a defining identifier 3725 3726 if Nkind (N) = N_Defining_Identifier then 3727 3728 -- If defining identifier has an interface name (and no 3729 -- address clause), then we output the interface name. 3730 3731 if (Is_Imported (N) or else Is_Exported (N)) 3732 and then Present (Interface_Name (N)) 3733 and then No (Address_Clause (N)) 3734 then 3735 String_To_Name_Buffer (Strval (Interface_Name (N))); 3736 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 3737 3738 -- If no interface name (or inactive because there was 3739 -- an address clause), then just output the Chars name. 3740 3741 else 3742 Write_Name_With_Col_Check (Chars (N)); 3743 end if; 3744 3745 -- Case of selector of an expanded name where the expanded name 3746 -- has an associated entity, output this entity. Check that the 3747 -- entity or associated node is of the right kind, see above. 3748 3749 elsif Nkind (Parent (N)) = N_Expanded_Name 3750 and then Selector_Name (Parent (N)) = N 3751 and then Present (Entity_Or_Associated_Node (Parent (N))) 3752 and then Nkind (Entity (Parent (N))) in N_Entity 3753 then 3754 Write_Id (Entity (Parent (N))); 3755 3756 -- For any other node with an associated entity, output it 3757 3758 elsif Nkind (N) in N_Has_Entity 3759 and then Present (Entity_Or_Associated_Node (N)) 3760 and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity 3761 then 3762 Write_Id (Entity (N)); 3763 3764 -- All other cases, we just print the Chars field 3765 3766 else 3767 Write_Name_With_Col_Check (Chars (N)); 3768 end if; 3769 end Write_Id; 3770 3771 ----------------------- 3772 -- Write_Identifiers -- 3773 ----------------------- 3774 3775 function Write_Identifiers (Node : Node_Id) return Boolean is 3776 begin 3777 Sprint_Node (Defining_Identifier (Node)); 3778 Update_Itype (Defining_Identifier (Node)); 3779 3780 -- The remainder of the declaration must be printed unless we are 3781 -- printing the original tree and this is not the last identifier 3782 3783 return 3784 not Dump_Original_Only or else not More_Ids (Node); 3785 3786 end Write_Identifiers; 3787 3788 ------------------------ 3789 -- Write_Implicit_Def -- 3790 ------------------------ 3791 3792 procedure Write_Implicit_Def (E : Entity_Id) is 3793 Ind : Node_Id; 3794 3795 begin 3796 case Ekind (E) is 3797 when E_Array_Subtype => 3798 Write_Str_With_Col_Check ("subtype "); 3799 Write_Id (E); 3800 Write_Str_With_Col_Check (" is "); 3801 Write_Id (Base_Type (E)); 3802 Write_Str_With_Col_Check (" ("); 3803 3804 Ind := First_Index (E); 3805 while Present (Ind) loop 3806 Sprint_Node (Ind); 3807 Next_Index (Ind); 3808 3809 if Present (Ind) then 3810 Write_Str (", "); 3811 end if; 3812 end loop; 3813 3814 Write_Str (");"); 3815 3816 when E_Signed_Integer_Subtype | E_Enumeration_Subtype => 3817 Write_Str_With_Col_Check ("subtype "); 3818 Write_Id (E); 3819 Write_Str (" is "); 3820 Write_Id (Etype (E)); 3821 Write_Str_With_Col_Check (" range "); 3822 Sprint_Node (Scalar_Range (E)); 3823 Write_Str (";"); 3824 3825 when others => 3826 Write_Str_With_Col_Check ("type "); 3827 Write_Id (E); 3828 Write_Str_With_Col_Check (" is <"); 3829 Write_Ekind (E); 3830 Write_Str (">;"); 3831 end case; 3832 3833 end Write_Implicit_Def; 3834 3835 ------------------ 3836 -- Write_Indent -- 3837 ------------------ 3838 3839 procedure Write_Indent is 3840 Loc : constant Source_Ptr := Sloc (Dump_Node); 3841 3842 begin 3843 if Indent_Annull_Flag then 3844 Indent_Annull_Flag := False; 3845 else 3846 -- Deal with Dump_Source_Text output. Note that we ignore implicit 3847 -- label declarations, since they typically have the sloc of the 3848 -- corresponding label, which really messes up the -gnatL output. 3849 3850 if Dump_Source_Text 3851 and then Loc > No_Location 3852 and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration 3853 then 3854 if Get_Source_File_Index (Loc) = Current_Source_File then 3855 Write_Source_Lines 3856 (Get_Physical_Line_Number (Sloc (Dump_Node))); 3857 end if; 3858 end if; 3859 3860 Write_Eol; 3861 3862 for J in 1 .. Indent loop 3863 Write_Char (' '); 3864 end loop; 3865 end if; 3866 end Write_Indent; 3867 3868 ------------------------------ 3869 -- Write_Indent_Identifiers -- 3870 ------------------------------ 3871 3872 function Write_Indent_Identifiers (Node : Node_Id) return Boolean is 3873 begin 3874 -- We need to start a new line for every node, except in the case 3875 -- where we are printing the original tree and this is not the first 3876 -- defining identifier in the list. 3877 3878 if not Dump_Original_Only or else not Prev_Ids (Node) then 3879 Write_Indent; 3880 3881 -- If printing original tree and this is not the first defining 3882 -- identifier in the list, then the previous call to this procedure 3883 -- printed only the name, and we add a comma to separate the names. 3884 3885 else 3886 Write_Str (", "); 3887 end if; 3888 3889 Sprint_Node (Defining_Identifier (Node)); 3890 3891 -- The remainder of the declaration must be printed unless we are 3892 -- printing the original tree and this is not the last identifier 3893 3894 return 3895 not Dump_Original_Only or else not More_Ids (Node); 3896 end Write_Indent_Identifiers; 3897 3898 ----------------------------------- 3899 -- Write_Indent_Identifiers_Sloc -- 3900 ----------------------------------- 3901 3902 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is 3903 begin 3904 -- We need to start a new line for every node, except in the case 3905 -- where we are printing the original tree and this is not the first 3906 -- defining identifier in the list. 3907 3908 if not Dump_Original_Only or else not Prev_Ids (Node) then 3909 Write_Indent; 3910 3911 -- If printing original tree and this is not the first defining 3912 -- identifier in the list, then the previous call to this procedure 3913 -- printed only the name, and we add a comma to separate the names. 3914 3915 else 3916 Write_Str (", "); 3917 end if; 3918 3919 Set_Debug_Sloc; 3920 Sprint_Node (Defining_Identifier (Node)); 3921 3922 -- The remainder of the declaration must be printed unless we are 3923 -- printing the original tree and this is not the last identifier 3924 3925 return not Dump_Original_Only or else not More_Ids (Node); 3926 end Write_Indent_Identifiers_Sloc; 3927 3928 ---------------------- 3929 -- Write_Indent_Str -- 3930 ---------------------- 3931 3932 procedure Write_Indent_Str (S : String) is 3933 begin 3934 Write_Corresponding_Source (S); 3935 Write_Indent; 3936 Write_Str (S); 3937 end Write_Indent_Str; 3938 3939 --------------------------- 3940 -- Write_Indent_Str_Sloc -- 3941 --------------------------- 3942 3943 procedure Write_Indent_Str_Sloc (S : String) is 3944 begin 3945 Write_Corresponding_Source (S); 3946 Write_Indent; 3947 Write_Str_Sloc (S); 3948 end Write_Indent_Str_Sloc; 3949 3950 ----------------- 3951 -- Write_Itype -- 3952 ----------------- 3953 3954 procedure Write_Itype (Typ : Entity_Id) is 3955 3956 procedure Write_Header (T : Boolean := True); 3957 -- Write type if T is True, subtype if T is false 3958 3959 ------------------ 3960 -- Write_Header -- 3961 ------------------ 3962 3963 procedure Write_Header (T : Boolean := True) is 3964 begin 3965 if T then 3966 Write_Str ("[type "); 3967 else 3968 Write_Str ("[subtype "); 3969 end if; 3970 3971 Write_Name_With_Col_Check (Chars (Typ)); 3972 Write_Str (" is "); 3973 end Write_Header; 3974 3975 -- Start of processing for Write_Itype 3976 3977 begin 3978 if Nkind (Typ) in N_Entity 3979 and then Is_Itype (Typ) 3980 and then not Itype_Printed (Typ) 3981 then 3982 -- Itype to be printed 3983 3984 declare 3985 B : constant Node_Id := Etype (Typ); 3986 X : Node_Id; 3987 P : constant Node_Id := Parent (Typ); 3988 3989 S : constant Saved_Output_Buffer := Save_Output_Buffer; 3990 -- Save current output buffer 3991 3992 Old_Sloc : Source_Ptr; 3993 -- Save sloc of related node, so it is not modified when 3994 -- printing with -gnatD. 3995 3996 begin 3997 -- Write indentation at start of line 3998 3999 for J in 1 .. Indent loop 4000 Write_Char (' '); 4001 end loop; 4002 4003 -- If we have a constructed declaration for the itype, print it 4004 4005 if Present (P) 4006 and then Nkind (P) in N_Declaration 4007 and then Defining_Entity (P) = Typ 4008 then 4009 -- We must set Itype_Printed true before the recursive call to 4010 -- print the node, otherwise we get an infinite recursion. 4011 4012 Set_Itype_Printed (Typ, True); 4013 4014 -- Write the declaration enclosed in [], avoiding new line 4015 -- at start of declaration, and semicolon at end. 4016 4017 -- Note: The itype may be imported from another unit, in which 4018 -- case we do not want to modify the Sloc of the declaration. 4019 -- Otherwise the itype may appear to be in the current unit, 4020 -- and the back-end will reject a reference out of scope. 4021 4022 Write_Char ('['); 4023 Indent_Annull_Flag := True; 4024 Old_Sloc := Sloc (P); 4025 Sprint_Node (P); 4026 Set_Sloc (P, Old_Sloc); 4027 Write_Erase_Char (';'); 4028 4029 -- If no constructed declaration, then we have to concoct the 4030 -- source corresponding to the type entity that we have at hand. 4031 4032 else 4033 case Ekind (Typ) is 4034 4035 -- Access types and subtypes 4036 4037 when Access_Kind => 4038 Write_Header (Ekind (Typ) = E_Access_Type); 4039 4040 if Can_Never_Be_Null (Typ) then 4041 Write_Str ("not null "); 4042 end if; 4043 4044 Write_Str ("access "); 4045 4046 if Is_Access_Constant (Typ) then 4047 Write_Str ("constant "); 4048 end if; 4049 4050 Write_Id (Directly_Designated_Type (Typ)); 4051 4052 -- Array types and string types 4053 4054 when E_Array_Type | E_String_Type => 4055 Write_Header; 4056 Write_Str ("array ("); 4057 4058 X := First_Index (Typ); 4059 loop 4060 Sprint_Node (X); 4061 4062 if not Is_Constrained (Typ) then 4063 Write_Str (" range <>"); 4064 end if; 4065 4066 Next_Index (X); 4067 exit when No (X); 4068 Write_Str (", "); 4069 end loop; 4070 4071 Write_Str (") of "); 4072 X := Component_Type (Typ); 4073 4074 -- Preserve sloc of component type, which is defined 4075 -- elsewhere than the itype (see comment above). 4076 4077 Old_Sloc := Sloc (X); 4078 Sprint_Node (X); 4079 Set_Sloc (X, Old_Sloc); 4080 4081 -- Array subtypes and string subtypes. 4082 -- Preserve Sloc of index subtypes, as above. 4083 4084 when E_Array_Subtype | E_String_Subtype => 4085 Write_Header (False); 4086 Write_Id (Etype (Typ)); 4087 Write_Str (" ("); 4088 4089 X := First_Index (Typ); 4090 loop 4091 Old_Sloc := Sloc (X); 4092 Sprint_Node (X); 4093 Set_Sloc (X, Old_Sloc); 4094 Next_Index (X); 4095 exit when No (X); 4096 Write_Str (", "); 4097 end loop; 4098 4099 Write_Char (')'); 4100 4101 -- Signed integer types, and modular integer subtypes, 4102 -- and also enumeration subtypes. 4103 4104 when E_Signed_Integer_Type | 4105 E_Signed_Integer_Subtype | 4106 E_Modular_Integer_Subtype | 4107 E_Enumeration_Subtype => 4108 4109 Write_Header (Ekind (Typ) = E_Signed_Integer_Type); 4110 4111 if Ekind (Typ) = E_Signed_Integer_Type then 4112 Write_Str ("new "); 4113 end if; 4114 4115 Write_Id (B); 4116 4117 -- Print bounds if different from base type 4118 4119 declare 4120 L : constant Node_Id := Type_Low_Bound (Typ); 4121 H : constant Node_Id := Type_High_Bound (Typ); 4122 LE : Node_Id; 4123 HE : Node_Id; 4124 4125 begin 4126 -- B can either be a scalar type, in which case the 4127 -- declaration of Typ may constrain it with different 4128 -- bounds, or a private type, in which case we know 4129 -- that the declaration of Typ cannot have a scalar 4130 -- constraint. 4131 4132 if Is_Scalar_Type (B) then 4133 LE := Type_Low_Bound (B); 4134 HE := Type_High_Bound (B); 4135 else 4136 LE := Empty; 4137 HE := Empty; 4138 end if; 4139 4140 if No (LE) 4141 or else (True 4142 and then Nkind (L) = N_Integer_Literal 4143 and then Nkind (H) = N_Integer_Literal 4144 and then Nkind (LE) = N_Integer_Literal 4145 and then Nkind (HE) = N_Integer_Literal 4146 and then UI_Eq (Intval (L), Intval (LE)) 4147 and then UI_Eq (Intval (H), Intval (HE))) 4148 then 4149 null; 4150 4151 else 4152 Write_Str (" range "); 4153 Sprint_Node (Type_Low_Bound (Typ)); 4154 Write_Str (" .. "); 4155 Sprint_Node (Type_High_Bound (Typ)); 4156 end if; 4157 end; 4158 4159 -- Modular integer types 4160 4161 when E_Modular_Integer_Type => 4162 Write_Header; 4163 Write_Str ("mod "); 4164 Write_Uint_With_Col_Check (Modulus (Typ), Auto); 4165 4166 -- Floating point types and subtypes 4167 4168 when E_Floating_Point_Type | 4169 E_Floating_Point_Subtype => 4170 4171 Write_Header (Ekind (Typ) = E_Floating_Point_Type); 4172 4173 if Ekind (Typ) = E_Floating_Point_Type then 4174 Write_Str ("new "); 4175 end if; 4176 4177 Write_Id (Etype (Typ)); 4178 4179 if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then 4180 Write_Str (" digits "); 4181 Write_Uint_With_Col_Check 4182 (Digits_Value (Typ), Decimal); 4183 end if; 4184 4185 -- Print bounds if not different from base type 4186 4187 declare 4188 L : constant Node_Id := Type_Low_Bound (Typ); 4189 H : constant Node_Id := Type_High_Bound (Typ); 4190 LE : constant Node_Id := Type_Low_Bound (B); 4191 HE : constant Node_Id := Type_High_Bound (B); 4192 4193 begin 4194 if Nkind (L) = N_Real_Literal 4195 and then Nkind (H) = N_Real_Literal 4196 and then Nkind (LE) = N_Real_Literal 4197 and then Nkind (HE) = N_Real_Literal 4198 and then UR_Eq (Realval (L), Realval (LE)) 4199 and then UR_Eq (Realval (H), Realval (HE)) 4200 then 4201 null; 4202 4203 else 4204 Write_Str (" range "); 4205 Sprint_Node (Type_Low_Bound (Typ)); 4206 Write_Str (" .. "); 4207 Sprint_Node (Type_High_Bound (Typ)); 4208 end if; 4209 end; 4210 4211 -- Record subtypes 4212 4213 when E_Record_Subtype | E_Record_Subtype_With_Private => 4214 Write_Header (False); 4215 Write_Str ("record"); 4216 Indent_Begin; 4217 4218 declare 4219 C : Entity_Id; 4220 begin 4221 C := First_Entity (Typ); 4222 while Present (C) loop 4223 Write_Indent; 4224 Write_Id (C); 4225 Write_Str (" : "); 4226 Write_Id (Etype (C)); 4227 Next_Entity (C); 4228 end loop; 4229 end; 4230 4231 Indent_End; 4232 Write_Indent_Str (" end record"); 4233 4234 -- Class-Wide types 4235 4236 when E_Class_Wide_Type | 4237 E_Class_Wide_Subtype => 4238 Write_Header (Ekind (Typ) = E_Class_Wide_Type); 4239 Write_Name_With_Col_Check (Chars (Etype (Typ))); 4240 Write_Str ("'Class"); 4241 4242 -- Subprogram types 4243 4244 when E_Subprogram_Type => 4245 Write_Header; 4246 4247 if Etype (Typ) = Standard_Void_Type then 4248 Write_Str ("procedure"); 4249 else 4250 Write_Str ("function"); 4251 end if; 4252 4253 if Present (First_Entity (Typ)) then 4254 Write_Str (" ("); 4255 4256 declare 4257 Param : Entity_Id; 4258 4259 begin 4260 Param := First_Entity (Typ); 4261 loop 4262 Write_Id (Param); 4263 Write_Str (" : "); 4264 4265 if Ekind (Param) = E_In_Out_Parameter then 4266 Write_Str ("in out "); 4267 elsif Ekind (Param) = E_Out_Parameter then 4268 Write_Str ("out "); 4269 end if; 4270 4271 Write_Id (Etype (Param)); 4272 Next_Entity (Param); 4273 exit when No (Param); 4274 Write_Str (", "); 4275 end loop; 4276 4277 Write_Char (')'); 4278 end; 4279 end if; 4280 4281 if Etype (Typ) /= Standard_Void_Type then 4282 Write_Str (" return "); 4283 Write_Id (Etype (Typ)); 4284 end if; 4285 4286 when E_String_Literal_Subtype => 4287 declare 4288 LB : constant Uint := 4289 Expr_Value (String_Literal_Low_Bound (Typ)); 4290 Len : constant Uint := 4291 String_Literal_Length (Typ); 4292 begin 4293 Write_Str ("String ("); 4294 Write_Int (UI_To_Int (LB)); 4295 Write_Str (" .. "); 4296 Write_Int (UI_To_Int (LB + Len) - 1); 4297 Write_Str (");"); 4298 end; 4299 4300 -- For all other Itypes, print ??? (fill in later) 4301 4302 when others => 4303 Write_Header (True); 4304 Write_Str ("???"); 4305 4306 end case; 4307 end if; 4308 4309 -- Add terminating bracket and restore output buffer 4310 4311 Write_Char (']'); 4312 Write_Eol; 4313 Restore_Output_Buffer (S); 4314 end; 4315 4316 Set_Itype_Printed (Typ); 4317 end if; 4318 end Write_Itype; 4319 4320 ------------------------------- 4321 -- Write_Name_With_Col_Check -- 4322 ------------------------------- 4323 4324 procedure Write_Name_With_Col_Check (N : Name_Id) is 4325 J : Natural; 4326 K : Natural; 4327 L : Natural; 4328 4329 begin 4330 Get_Name_String (N); 4331 4332 -- Deal with -gnatdI which replaces any sequence Cnnnb where C is an 4333 -- upper case letter, nnn is one or more digits and b is a lower case 4334 -- letter by C...b, so that listings do not depend on serial numbers. 4335 4336 if Debug_Flag_II then 4337 J := 1; 4338 while J < Name_Len - 1 loop 4339 if Name_Buffer (J) in 'A' .. 'Z' 4340 and then Name_Buffer (J + 1) in '0' .. '9' 4341 then 4342 K := J + 1; 4343 while K < Name_Len loop 4344 exit when Name_Buffer (K) not in '0' .. '9'; 4345 K := K + 1; 4346 end loop; 4347 4348 if Name_Buffer (K) in 'a' .. 'z' then 4349 L := Name_Len - K + 1; 4350 4351 Name_Buffer (J + 4 .. J + L + 3) := 4352 Name_Buffer (K .. Name_Len); 4353 Name_Buffer (J + 1 .. J + 3) := "..."; 4354 Name_Len := J + L + 3; 4355 J := J + 5; 4356 4357 else 4358 J := K; 4359 end if; 4360 4361 else 4362 J := J + 1; 4363 end if; 4364 end loop; 4365 end if; 4366 4367 -- Fall through for normal case 4368 4369 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 4370 end Write_Name_With_Col_Check; 4371 4372 ------------------------------------ 4373 -- Write_Name_With_Col_Check_Sloc -- 4374 ------------------------------------ 4375 4376 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is 4377 begin 4378 Get_Name_String (N); 4379 Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len)); 4380 end Write_Name_With_Col_Check_Sloc; 4381 4382 -------------------- 4383 -- Write_Operator -- 4384 -------------------- 4385 4386 procedure Write_Operator (N : Node_Id; S : String) is 4387 F : Natural := S'First; 4388 T : Natural := S'Last; 4389 4390 begin 4391 -- If no overflow check, just write string out, and we are done 4392 4393 if not Do_Overflow_Check (N) then 4394 Write_Str_Sloc (S); 4395 4396 -- If overflow check, we want to surround the operator with curly 4397 -- brackets, but not include spaces within the brackets. 4398 4399 else 4400 if S (F) = ' ' then 4401 Write_Char (' '); 4402 F := F + 1; 4403 end if; 4404 4405 if S (T) = ' ' then 4406 T := T - 1; 4407 end if; 4408 4409 Write_Char ('{'); 4410 Write_Str_Sloc (S (F .. T)); 4411 Write_Char ('}'); 4412 4413 if S (S'Last) = ' ' then 4414 Write_Char (' '); 4415 end if; 4416 end if; 4417 end Write_Operator; 4418 4419 ----------------------- 4420 -- Write_Param_Specs -- 4421 ----------------------- 4422 4423 procedure Write_Param_Specs (N : Node_Id) is 4424 Specs : List_Id; 4425 Spec : Node_Id; 4426 Formal : Node_Id; 4427 4428 begin 4429 Specs := Parameter_Specifications (N); 4430 4431 if Is_Non_Empty_List (Specs) then 4432 Write_Str_With_Col_Check (" ("); 4433 Spec := First (Specs); 4434 4435 loop 4436 Sprint_Node (Spec); 4437 Formal := Defining_Identifier (Spec); 4438 Next (Spec); 4439 exit when Spec = Empty; 4440 4441 -- Add semicolon, unless we are printing original tree and the 4442 -- next specification is part of a list (but not the first element 4443 -- of that list). 4444 4445 if not Dump_Original_Only or else not Prev_Ids (Spec) then 4446 Write_Str ("; "); 4447 end if; 4448 end loop; 4449 4450 -- Write out any extra formals 4451 4452 while Present (Extra_Formal (Formal)) loop 4453 Formal := Extra_Formal (Formal); 4454 Write_Str ("; "); 4455 Write_Name_With_Col_Check (Chars (Formal)); 4456 Write_Str (" : "); 4457 Write_Name_With_Col_Check (Chars (Etype (Formal))); 4458 end loop; 4459 4460 Write_Char (')'); 4461 end if; 4462 end Write_Param_Specs; 4463 4464 ----------------------- 4465 -- Write_Rewrite_Str -- 4466 ----------------------- 4467 4468 procedure Write_Rewrite_Str (S : String) is 4469 begin 4470 if not Dump_Generated_Only then 4471 if S'Length = 3 and then S = ">>>" then 4472 Write_Str (">>>"); 4473 else 4474 Write_Str_With_Col_Check (S); 4475 end if; 4476 end if; 4477 end Write_Rewrite_Str; 4478 4479 ----------------------- 4480 -- Write_Source_Line -- 4481 ----------------------- 4482 4483 procedure Write_Source_Line (L : Physical_Line_Number) is 4484 Loc : Source_Ptr; 4485 Src : Source_Buffer_Ptr; 4486 Scn : Source_Ptr; 4487 4488 begin 4489 if Dump_Source_Text then 4490 Src := Source_Text (Current_Source_File); 4491 Loc := Line_Start (L, Current_Source_File); 4492 Write_Eol; 4493 4494 -- See if line is a comment line, if not, and if not line one, 4495 -- precede with blank line. 4496 4497 Scn := Loc; 4498 while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop 4499 Scn := Scn + 1; 4500 end loop; 4501 4502 if (Src (Scn) in Line_Terminator 4503 or else Src (Scn .. Scn + 1) /= "--") 4504 and then L /= 1 4505 then 4506 Write_Eol; 4507 end if; 4508 4509 -- Now write the source text of the line 4510 4511 Write_Str ("-- "); 4512 Write_Int (Int (L)); 4513 Write_Str (": "); 4514 4515 while Src (Loc) not in Line_Terminator loop 4516 Write_Char (Src (Loc)); 4517 Loc := Loc + 1; 4518 end loop; 4519 end if; 4520 end Write_Source_Line; 4521 4522 ------------------------ 4523 -- Write_Source_Lines -- 4524 ------------------------ 4525 4526 procedure Write_Source_Lines (L : Physical_Line_Number) is 4527 begin 4528 while Last_Line_Printed < L loop 4529 Last_Line_Printed := Last_Line_Printed + 1; 4530 Write_Source_Line (Last_Line_Printed); 4531 end loop; 4532 end Write_Source_Lines; 4533 4534 -------------------- 4535 -- Write_Str_Sloc -- 4536 -------------------- 4537 4538 procedure Write_Str_Sloc (S : String) is 4539 begin 4540 for J in S'Range loop 4541 Write_Char_Sloc (S (J)); 4542 end loop; 4543 end Write_Str_Sloc; 4544 4545 ------------------------------ 4546 -- Write_Str_With_Col_Check -- 4547 ------------------------------ 4548 4549 procedure Write_Str_With_Col_Check (S : String) is 4550 begin 4551 if Int (S'Last) + Column > Sprint_Line_Limit then 4552 Write_Indent_Str (" "); 4553 4554 if S (S'First) = ' ' then 4555 Write_Str (S (S'First + 1 .. S'Last)); 4556 else 4557 Write_Str (S); 4558 end if; 4559 4560 else 4561 Write_Str (S); 4562 end if; 4563 end Write_Str_With_Col_Check; 4564 4565 ----------------------------------- 4566 -- Write_Str_With_Col_Check_Sloc -- 4567 ----------------------------------- 4568 4569 procedure Write_Str_With_Col_Check_Sloc (S : String) is 4570 begin 4571 if Int (S'Last) + Column > Sprint_Line_Limit then 4572 Write_Indent_Str (" "); 4573 4574 if S (S'First) = ' ' then 4575 Write_Str_Sloc (S (S'First + 1 .. S'Last)); 4576 else 4577 Write_Str_Sloc (S); 4578 end if; 4579 4580 else 4581 Write_Str_Sloc (S); 4582 end if; 4583 end Write_Str_With_Col_Check_Sloc; 4584 4585 --------------------------- 4586 -- Write_Subprogram_Name -- 4587 --------------------------- 4588 4589 procedure Write_Subprogram_Name (N : Node_Id) is 4590 begin 4591 if not Comes_From_Source (N) 4592 and then Is_Entity_Name (N) 4593 then 4594 declare 4595 Ent : constant Entity_Id := Entity (N); 4596 begin 4597 if not In_Extended_Main_Source_Unit (Ent) 4598 and then 4599 Is_Predefined_File_Name 4600 (Unit_File_Name (Get_Source_Unit (Ent))) 4601 then 4602 -- Run-time routine name, output name with a preceding dollar 4603 -- making sure that we do not get a line split between them. 4604 4605 Col_Check (Length_Of_Name (Chars (Ent)) + 1); 4606 Write_Char ('$'); 4607 Write_Name (Chars (Ent)); 4608 return; 4609 end if; 4610 end; 4611 end if; 4612 4613 -- Normal case, not a run-time routine name 4614 4615 Sprint_Node (N); 4616 end Write_Subprogram_Name; 4617 4618 ------------------------------- 4619 -- Write_Uint_With_Col_Check -- 4620 ------------------------------- 4621 4622 procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is 4623 begin 4624 Col_Check (UI_Decimal_Digits_Hi (U)); 4625 UI_Write (U, Format); 4626 end Write_Uint_With_Col_Check; 4627 4628 ------------------------------------ 4629 -- Write_Uint_With_Col_Check_Sloc -- 4630 ------------------------------------ 4631 4632 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is 4633 begin 4634 Col_Check (UI_Decimal_Digits_Hi (U)); 4635 Set_Debug_Sloc; 4636 UI_Write (U, Format); 4637 end Write_Uint_With_Col_Check_Sloc; 4638 4639 ------------------------------------- 4640 -- Write_Ureal_With_Col_Check_Sloc -- 4641 ------------------------------------- 4642 4643 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is 4644 D : constant Uint := Denominator (U); 4645 N : constant Uint := Numerator (U); 4646 begin 4647 Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); 4648 Set_Debug_Sloc; 4649 UR_Write (U, Brackets => True); 4650 end Write_Ureal_With_Col_Check_Sloc; 4651 4652end Sprint; 4653