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