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