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