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-2018, 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 Set_Special_Output (null); 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_Reduction_Expression => 3114 Write_Str (" for"); 3115 3116 if Present (Iterator_Specification (Node)) then 3117 Sprint_Node (Iterator_Specification (Node)); 3118 else 3119 Sprint_Node (Loop_Parameter_Specification (Node)); 3120 end if; 3121 3122 Write_Str (" => "); 3123 Sprint_Node (Expression (Node)); 3124 null; 3125 3126 when N_Reduction_Expression_Parameter => 3127 Write_Char ('<'); 3128 3129 if Present (Expression (Node)) then 3130 Sprint_Node (Expression (Node)); 3131 end if; 3132 3133 Write_Char ('>'); 3134 3135 when N_Reference => 3136 Sprint_Node (Prefix (Node)); 3137 Write_Str_With_Col_Check_Sloc ("'reference"); 3138 3139 when N_Requeue_Statement => 3140 Write_Indent_Str_Sloc ("requeue "); 3141 Sprint_Node (Name (Node)); 3142 3143 if Abort_Present (Node) then 3144 Write_Str_With_Col_Check (" with abort"); 3145 end if; 3146 3147 Write_Char (';'); 3148 3149 -- Don't we want to print more detail??? 3150 3151 -- Doc of this extended syntax belongs in sinfo.ads and/or 3152 -- sprint.ads ??? 3153 3154 when N_SCIL_Dispatch_Table_Tag_Init => 3155 Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); 3156 3157 when N_SCIL_Dispatching_Call => 3158 Write_Indent_Str ("[N_SCIL_Dispatching_Node]"); 3159 3160 when N_SCIL_Membership_Test => 3161 Write_Indent_Str ("[N_SCIL_Membership_Test]"); 3162 3163 when N_Simple_Return_Statement => 3164 if Present (Expression (Node)) then 3165 Write_Indent_Str_Sloc ("return "); 3166 Sprint_Node (Expression (Node)); 3167 Write_Char (';'); 3168 else 3169 Write_Indent_Str_Sloc ("return;"); 3170 end if; 3171 3172 when N_Selective_Accept => 3173 Write_Indent_Str_Sloc ("select"); 3174 3175 declare 3176 Alt_Node : Node_Id; 3177 begin 3178 Alt_Node := First (Select_Alternatives (Node)); 3179 loop 3180 Indent_Begin; 3181 Sprint_Node (Alt_Node); 3182 Indent_End; 3183 Next (Alt_Node); 3184 exit when No (Alt_Node); 3185 Write_Indent_Str ("or"); 3186 end loop; 3187 end; 3188 3189 if Present (Else_Statements (Node)) then 3190 Write_Indent_Str ("else"); 3191 Sprint_Indented_List (Else_Statements (Node)); 3192 end if; 3193 3194 Write_Indent_Str ("end select;"); 3195 3196 when N_Signed_Integer_Type_Definition => 3197 Write_Str_With_Col_Check_Sloc ("range "); 3198 Sprint_Node (Low_Bound (Node)); 3199 Write_Str (" .. "); 3200 Sprint_Node (High_Bound (Node)); 3201 3202 when N_Single_Protected_Declaration => 3203 Write_Indent_Str_Sloc ("protected "); 3204 Write_Id (Defining_Identifier (Node)); 3205 Write_Str (" is"); 3206 Sprint_Node (Protected_Definition (Node)); 3207 Write_Id (Defining_Identifier (Node)); 3208 Write_Char (';'); 3209 3210 when N_Single_Task_Declaration => 3211 Write_Indent_Str_Sloc ("task "); 3212 Sprint_Node (Defining_Identifier (Node)); 3213 3214 if Present (Task_Definition (Node)) then 3215 Write_Str (" is"); 3216 Sprint_Node (Task_Definition (Node)); 3217 end if; 3218 3219 Write_Char (';'); 3220 3221 when N_Selected_Component => 3222 Sprint_Node (Prefix (Node)); 3223 Write_Char_Sloc ('.'); 3224 Sprint_Node (Selector_Name (Node)); 3225 3226 when N_Slice => 3227 Set_Debug_Sloc; 3228 Sprint_Node (Prefix (Node)); 3229 Write_Str_With_Col_Check (" ("); 3230 Sprint_Node (Discrete_Range (Node)); 3231 Write_Char (')'); 3232 3233 when N_String_Literal => 3234 if String_Length (Strval (Node)) + Column > Sprint_Line_Limit then 3235 Write_Indent_Str (" "); 3236 end if; 3237 3238 Set_Debug_Sloc; 3239 Write_String_Table_Entry (Strval (Node)); 3240 3241 when N_Subprogram_Body => 3242 3243 -- Output extra blank line unless we are in freeze actions 3244 3245 if Freeze_Indent = 0 then 3246 Extra_Blank_Line; 3247 end if; 3248 3249 Write_Indent; 3250 3251 if Present (Corresponding_Spec (Node)) then 3252 Sprint_Node_Sloc (Parent (Corresponding_Spec (Node))); 3253 else 3254 Sprint_Node_Sloc (Specification (Node)); 3255 end if; 3256 3257 Write_Str (" is"); 3258 3259 Sprint_Indented_List (Declarations (Node)); 3260 Write_Indent_Str ("begin"); 3261 Sprint_Node (Handled_Statement_Sequence (Node)); 3262 3263 Write_Indent_Str ("end "); 3264 3265 Sprint_End_Label 3266 (Handled_Statement_Sequence (Node), 3267 Defining_Unit_Name (Specification (Node))); 3268 Write_Char (';'); 3269 3270 if Is_List_Member (Node) 3271 and then Present (Next (Node)) 3272 and then Nkind (Next (Node)) /= N_Subprogram_Body 3273 then 3274 Write_Indent; 3275 end if; 3276 3277 when N_Subprogram_Body_Stub => 3278 Write_Indent; 3279 Sprint_Node_Sloc (Specification (Node)); 3280 Write_Str_With_Col_Check (" is separate;"); 3281 3282 when N_Subprogram_Declaration => 3283 Write_Indent; 3284 Sprint_Node_Sloc (Specification (Node)); 3285 3286 if Nkind (Specification (Node)) = N_Procedure_Specification 3287 and then Null_Present (Specification (Node)) 3288 then 3289 Write_Str_With_Col_Check (" is null"); 3290 end if; 3291 3292 Write_Char (';'); 3293 3294 when N_Subprogram_Renaming_Declaration => 3295 Write_Indent; 3296 Sprint_Node (Specification (Node)); 3297 Write_Str_With_Col_Check_Sloc (" renames "); 3298 Sprint_Node (Name (Node)); 3299 Write_Char (';'); 3300 3301 when N_Subtype_Declaration => 3302 Write_Indent_Str_Sloc ("subtype "); 3303 Sprint_Node (Defining_Identifier (Node)); 3304 Write_Str (" is "); 3305 3306 -- Ada 2005 (AI-231) 3307 3308 if Null_Exclusion_Present (Node) then 3309 Write_Str ("not null "); 3310 end if; 3311 3312 Sprint_Node (Subtype_Indication (Node)); 3313 Write_Char (';'); 3314 3315 when N_Subtype_Indication => 3316 Sprint_Node_Sloc (Subtype_Mark (Node)); 3317 Write_Char (' '); 3318 Sprint_Node (Constraint (Node)); 3319 3320 when N_Subunit => 3321 Write_Indent_Str_Sloc ("separate ("); 3322 Sprint_Node (Name (Node)); 3323 Write_Char (')'); 3324 Extra_Blank_Line; 3325 Sprint_Node (Proper_Body (Node)); 3326 3327 when N_Target_Name => 3328 Write_Char ('@'); 3329 3330 when N_Task_Body => 3331 Write_Indent_Str_Sloc ("task body "); 3332 Write_Id (Defining_Identifier (Node)); 3333 Write_Str (" is"); 3334 Sprint_Indented_List (Declarations (Node)); 3335 Write_Indent_Str ("begin"); 3336 Sprint_Node (Handled_Statement_Sequence (Node)); 3337 Write_Indent_Str ("end "); 3338 Sprint_End_Label 3339 (Handled_Statement_Sequence (Node), Defining_Identifier (Node)); 3340 Write_Char (';'); 3341 3342 when N_Task_Body_Stub => 3343 Write_Indent_Str_Sloc ("task body "); 3344 Write_Id (Defining_Identifier (Node)); 3345 Write_Str_With_Col_Check (" is separate;"); 3346 3347 when N_Task_Definition => 3348 Set_Debug_Sloc; 3349 Sprint_Indented_List (Visible_Declarations (Node)); 3350 3351 if Present (Private_Declarations (Node)) then 3352 Write_Indent_Str ("private"); 3353 Sprint_Indented_List (Private_Declarations (Node)); 3354 end if; 3355 3356 Write_Indent_Str ("end "); 3357 Sprint_End_Label (Node, Defining_Identifier (Parent (Node))); 3358 3359 when N_Task_Type_Declaration => 3360 Write_Indent_Str_Sloc ("task type "); 3361 Sprint_Node (Defining_Identifier (Node)); 3362 Write_Discr_Specs (Node); 3363 3364 if Present (Interface_List (Node)) then 3365 Write_Str (" is new "); 3366 Sprint_And_List (Interface_List (Node)); 3367 end if; 3368 3369 if Present (Task_Definition (Node)) then 3370 if No (Interface_List (Node)) then 3371 Write_Str (" is"); 3372 else 3373 Write_Str (" with "); 3374 end if; 3375 3376 Sprint_Node (Task_Definition (Node)); 3377 end if; 3378 3379 Write_Char (';'); 3380 3381 when N_Terminate_Alternative => 3382 Sprint_Node_List (Pragmas_Before (Node)); 3383 Write_Indent; 3384 3385 if Present (Condition (Node)) then 3386 Write_Str_With_Col_Check ("when "); 3387 Sprint_Node (Condition (Node)); 3388 Write_Str (" => "); 3389 end if; 3390 3391 Write_Str_With_Col_Check_Sloc ("terminate;"); 3392 Sprint_Node_List (Pragmas_After (Node)); 3393 3394 when N_Timed_Entry_Call => 3395 Write_Indent_Str_Sloc ("select"); 3396 Indent_Begin; 3397 Sprint_Node (Entry_Call_Alternative (Node)); 3398 Indent_End; 3399 Write_Indent_Str ("or"); 3400 Indent_Begin; 3401 Sprint_Node (Delay_Alternative (Node)); 3402 Indent_End; 3403 Write_Indent_Str ("end select;"); 3404 3405 when N_Triggering_Alternative => 3406 Sprint_Node_List (Pragmas_Before (Node)); 3407 Sprint_Node_Sloc (Triggering_Statement (Node)); 3408 Sprint_Node_List (Statements (Node)); 3409 3410 when N_Type_Conversion => 3411 Set_Debug_Sloc; 3412 Sprint_Node (Subtype_Mark (Node)); 3413 Col_Check (4); 3414 3415 if Conversion_OK (Node) then 3416 Write_Char ('?'); 3417 end if; 3418 3419 if Float_Truncate (Node) then 3420 Write_Char ('^'); 3421 end if; 3422 3423 if Rounded_Result (Node) then 3424 Write_Char ('@'); 3425 end if; 3426 3427 Write_Char ('('); 3428 Sprint_Node (Expression (Node)); 3429 Write_Char (')'); 3430 3431 when N_Unchecked_Expression => 3432 Col_Check (10); 3433 Write_Str ("`("); 3434 Sprint_Node_Sloc (Expression (Node)); 3435 Write_Char (')'); 3436 3437 when N_Unchecked_Type_Conversion => 3438 Sprint_Node (Subtype_Mark (Node)); 3439 Write_Char ('!'); 3440 Write_Str_With_Col_Check ("("); 3441 Sprint_Node_Sloc (Expression (Node)); 3442 Write_Char (')'); 3443 3444 when N_Unconstrained_Array_Definition => 3445 Write_Str_With_Col_Check_Sloc ("array ("); 3446 3447 declare 3448 Node1 : Node_Id; 3449 begin 3450 Node1 := First (Subtype_Marks (Node)); 3451 loop 3452 Sprint_Node (Node1); 3453 Write_Str_With_Col_Check (" range <>"); 3454 Next (Node1); 3455 exit when Node1 = Empty; 3456 Write_Str (", "); 3457 end loop; 3458 end; 3459 3460 Write_Str (") of "); 3461 Sprint_Node (Component_Definition (Node)); 3462 3463 when N_Unused_At_Start | N_Unused_At_End => 3464 Write_Indent_Str ("***** Error, unused node encountered *****"); 3465 Write_Eol; 3466 3467 when N_Use_Package_Clause => 3468 Write_Indent_Str_Sloc ("use "); 3469 Sprint_Node_Sloc (Name (Node)); 3470 Write_Char (';'); 3471 3472 when N_Use_Type_Clause => 3473 Write_Indent_Str_Sloc ("use type "); 3474 Sprint_Node_Sloc (Subtype_Mark (Node)); 3475 Write_Char (';'); 3476 3477 when N_Validate_Unchecked_Conversion => 3478 Write_Indent_Str_Sloc ("validate unchecked_conversion ("); 3479 Sprint_Node (Source_Type (Node)); 3480 Write_Str (", "); 3481 Sprint_Node (Target_Type (Node)); 3482 Write_Str (");"); 3483 3484 when N_Variable_Reference_Marker => 3485 null; 3486 3487 -- Enable the following code for debugging purposes only 3488 3489 -- if Is_Read (Node) and then Is_Write (Node) then 3490 -- Write_Indent_Str ("rw#"); 3491 3492 -- elsif Is_Read (Node) then 3493 -- Write_Indent_Str ("r#"); 3494 3495 -- else 3496 -- pragma Assert (Is_Write (Node)); 3497 -- Write_Indent_Str ("w#"); 3498 -- end if; 3499 3500 -- Write_Id (Target (Node)); 3501 -- Write_Char ('#'); 3502 3503 when N_Variant => 3504 Write_Indent_Str_Sloc ("when "); 3505 Sprint_Bar_List (Discrete_Choices (Node)); 3506 Write_Str (" => "); 3507 Sprint_Node (Component_List (Node)); 3508 3509 when N_Variant_Part => 3510 Indent_Begin; 3511 Write_Indent_Str_Sloc ("case "); 3512 Sprint_Node (Name (Node)); 3513 Write_Str (" is "); 3514 Sprint_Indented_List (Variants (Node)); 3515 Write_Indent_Str ("end case"); 3516 Indent_End; 3517 3518 when N_With_Clause => 3519 3520 -- Special test, if we are dumping the original tree only, 3521 -- then we want to eliminate the bogus with clauses that 3522 -- correspond to the non-existent children of Text_IO. 3523 3524 if Dump_Original_Only 3525 and then Is_Text_IO_Special_Unit (Name (Node)) 3526 then 3527 null; 3528 3529 -- Normal case, output the with clause 3530 3531 else 3532 if First_Name (Node) or else not Dump_Original_Only then 3533 3534 -- Ada 2005 (AI-50217): Print limited with_clauses 3535 3536 if Private_Present (Node) and Limited_Present (Node) then 3537 Write_Indent_Str ("limited private with "); 3538 3539 elsif Private_Present (Node) then 3540 Write_Indent_Str ("private with "); 3541 3542 elsif Limited_Present (Node) then 3543 Write_Indent_Str ("limited with "); 3544 3545 else 3546 Write_Indent_Str ("with "); 3547 end if; 3548 3549 else 3550 Write_Str (", "); 3551 end if; 3552 3553 Sprint_Node_Sloc (Name (Node)); 3554 3555 if Last_Name (Node) or else not Dump_Original_Only then 3556 Write_Char (';'); 3557 end if; 3558 end if; 3559 end case; 3560 3561 -- Print aspects, except for special case of package declaration, 3562 -- where the aspects are printed inside the package specification. 3563 3564 if Has_Aspects (Node) 3565 and then not Nkind_In (Node, N_Package_Declaration, 3566 N_Generic_Package_Declaration) 3567 then 3568 Sprint_Aspect_Specifications (Node, Semicolon => True); 3569 end if; 3570 3571 if Nkind (Node) in N_Subexpr 3572 and then Do_Range_Check (Node) 3573 then 3574 Write_Str ("}"); 3575 end if; 3576 3577 for J in 1 .. Paren_Count (Node) loop 3578 Write_Char (')'); 3579 end loop; 3580 3581 Dump_Node := Save_Dump_Node; 3582 end Sprint_Node_Actual; 3583 3584 ---------------------- 3585 -- Sprint_Node_List -- 3586 ---------------------- 3587 3588 procedure Sprint_Node_List (List : List_Id; New_Lines : Boolean := False) is 3589 Node : Node_Id; 3590 3591 begin 3592 if Is_Non_Empty_List (List) then 3593 Node := First (List); 3594 3595 loop 3596 Sprint_Node (Node); 3597 Next (Node); 3598 exit when Node = Empty; 3599 end loop; 3600 end if; 3601 3602 if New_Lines and then Column /= 1 then 3603 Write_Eol; 3604 end if; 3605 end Sprint_Node_List; 3606 3607 ---------------------- 3608 -- Sprint_Node_Sloc -- 3609 ---------------------- 3610 3611 procedure Sprint_Node_Sloc (Node : Node_Id) is 3612 begin 3613 Sprint_Node (Node); 3614 3615 if Debug_Generated_Code and then Present (Dump_Node) then 3616 Set_Sloc (Dump_Node, Sloc (Node)); 3617 Dump_Node := Empty; 3618 end if; 3619 end Sprint_Node_Sloc; 3620 3621 --------------------- 3622 -- Sprint_Opt_Node -- 3623 --------------------- 3624 3625 procedure Sprint_Opt_Node (Node : Node_Id) is 3626 begin 3627 if Present (Node) then 3628 Write_Char (' '); 3629 Sprint_Node (Node); 3630 end if; 3631 end Sprint_Opt_Node; 3632 3633 -------------------------- 3634 -- Sprint_Opt_Node_List -- 3635 -------------------------- 3636 3637 procedure Sprint_Opt_Node_List (List : List_Id) is 3638 begin 3639 if Present (List) then 3640 Sprint_Node_List (List); 3641 end if; 3642 end Sprint_Opt_Node_List; 3643 3644 --------------------------------- 3645 -- Sprint_Opt_Paren_Comma_List -- 3646 --------------------------------- 3647 3648 procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is 3649 begin 3650 if Is_Non_Empty_List (List) then 3651 Write_Char (' '); 3652 Sprint_Paren_Comma_List (List); 3653 end if; 3654 end Sprint_Opt_Paren_Comma_List; 3655 3656 ----------------------------- 3657 -- Sprint_Paren_Comma_List -- 3658 ----------------------------- 3659 3660 procedure Sprint_Paren_Comma_List (List : List_Id) is 3661 N : Node_Id; 3662 Node_Exists : Boolean := False; 3663 3664 begin 3665 3666 if Is_Non_Empty_List (List) then 3667 3668 if Dump_Original_Only then 3669 N := First (List); 3670 while Present (N) loop 3671 if not Is_Rewrite_Insertion (N) then 3672 Node_Exists := True; 3673 exit; 3674 end if; 3675 3676 Next (N); 3677 end loop; 3678 3679 if not Node_Exists then 3680 return; 3681 end if; 3682 end if; 3683 3684 Write_Str_With_Col_Check ("("); 3685 Sprint_Comma_List (List); 3686 Write_Char (')'); 3687 end if; 3688 end Sprint_Paren_Comma_List; 3689 3690 ---------------------- 3691 -- Sprint_Right_Opnd -- 3692 ---------------------- 3693 3694 procedure Sprint_Right_Opnd (N : Node_Id) is 3695 Opnd : constant Node_Id := Right_Opnd (N); 3696 3697 begin 3698 if Paren_Count (Opnd) /= 0 3699 or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N)) 3700 then 3701 Sprint_Node (Opnd); 3702 3703 else 3704 Write_Char ('('); 3705 Sprint_Node (Opnd); 3706 Write_Char (')'); 3707 end if; 3708 end Sprint_Right_Opnd; 3709 3710 ------------------ 3711 -- Update_Itype -- 3712 ------------------ 3713 3714 procedure Update_Itype (Node : Node_Id) is 3715 begin 3716 if Present (Etype (Node)) 3717 and then Is_Itype (Etype (Node)) 3718 and then Debug_Generated_Code 3719 then 3720 Set_Sloc (Etype (Node), Sloc (Node)); 3721 end if; 3722 end Update_Itype; 3723 3724 --------------------- 3725 -- Write_Char_Sloc -- 3726 --------------------- 3727 3728 procedure Write_Char_Sloc (C : Character) is 3729 begin 3730 if Debug_Generated_Code and then C /= ' ' then 3731 Set_Debug_Sloc; 3732 end if; 3733 3734 Write_Char (C); 3735 end Write_Char_Sloc; 3736 3737 -------------------------------- 3738 -- Write_Condition_And_Reason -- 3739 -------------------------------- 3740 3741 procedure Write_Condition_And_Reason (Node : Node_Id) is 3742 Cond : constant Node_Id := Condition (Node); 3743 Image : constant String := RT_Exception_Code'Image 3744 (RT_Exception_Code'Val 3745 (UI_To_Int (Reason (Node)))); 3746 3747 begin 3748 if Present (Cond) then 3749 3750 -- If condition is a single entity, or NOT with a single entity, 3751 -- output all on one line, since it will likely fit just fine. 3752 3753 if Is_Entity_Name (Cond) 3754 or else (Nkind (Cond) = N_Op_Not 3755 and then Is_Entity_Name (Right_Opnd (Cond))) 3756 then 3757 Write_Str_With_Col_Check (" when "); 3758 Sprint_Node (Cond); 3759 Write_Char (' '); 3760 3761 -- Otherwise for more complex condition, multiple lines 3762 3763 else 3764 Write_Str_With_Col_Check (" when"); 3765 Indent := Indent + 2; 3766 Write_Indent; 3767 Sprint_Node (Cond); 3768 Write_Indent; 3769 Indent := Indent - 2; 3770 end if; 3771 3772 -- If no condition, just need a space (all on one line) 3773 3774 else 3775 Write_Char (' '); 3776 end if; 3777 3778 -- Write the reason 3779 3780 Write_Char ('"'); 3781 3782 for J in 4 .. Image'Last loop 3783 if Image (J) = '_' then 3784 Write_Char (' '); 3785 else 3786 Write_Char (Fold_Lower (Image (J))); 3787 end if; 3788 end loop; 3789 3790 Write_Str ("""]"); 3791 end Write_Condition_And_Reason; 3792 3793 -------------------------------- 3794 -- Write_Corresponding_Source -- 3795 -------------------------------- 3796 3797 procedure Write_Corresponding_Source (S : String) is 3798 Loc : Source_Ptr; 3799 Src : Source_Buffer_Ptr; 3800 3801 begin 3802 -- Ignore if there is no current source file, or we're not in dump 3803 -- source text mode, or if in freeze actions. 3804 3805 if Current_Source_File > No_Source_File 3806 and then Dump_Source_Text 3807 and then Freeze_Indent = 0 3808 then 3809 3810 -- Ignore null string 3811 3812 if S = "" then 3813 return; 3814 end if; 3815 3816 -- Ignore space or semicolon at end of given string 3817 3818 if S (S'Last) = ' ' or else S (S'Last) = ';' then 3819 Write_Corresponding_Source (S (S'First .. S'Last - 1)); 3820 return; 3821 end if; 3822 3823 -- Loop to look at next lines not yet printed in source file 3824 3825 for L in 3826 Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File) 3827 loop 3828 Src := Source_Text (Current_Source_File); 3829 Loc := Line_Start (L, Current_Source_File); 3830 3831 -- If comment, keep looking 3832 3833 if Src (Loc .. Loc + 1) = "--" then 3834 null; 3835 3836 -- Search to first non-blank 3837 3838 else 3839 while Src (Loc) not in Line_Terminator loop 3840 3841 -- Non-blank found 3842 3843 if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then 3844 3845 -- Loop through characters in string to see if we match 3846 3847 for J in S'Range loop 3848 3849 -- If mismatch, then not the case we are looking for 3850 3851 if Src (Loc) /= S (J) then 3852 return; 3853 end if; 3854 3855 Loc := Loc + 1; 3856 end loop; 3857 3858 -- If we fall through, string matched, if white space or 3859 -- semicolon after the matched string, this is the case 3860 -- we are looking for. 3861 3862 if Src (Loc) in Line_Terminator 3863 or else Src (Loc) = ' ' 3864 or else Src (Loc) = ASCII.HT 3865 or else Src (Loc) = ';' 3866 then 3867 -- So output source lines up to and including this one 3868 3869 Write_Source_Lines (L); 3870 return; 3871 end if; 3872 end if; 3873 3874 Loc := Loc + 1; 3875 end loop; 3876 end if; 3877 3878 -- Line was all blanks, or a comment line, keep looking 3879 3880 end loop; 3881 end if; 3882 end Write_Corresponding_Source; 3883 3884 ----------------------- 3885 -- Write_Discr_Specs -- 3886 ----------------------- 3887 3888 procedure Write_Discr_Specs (N : Node_Id) is 3889 Specs : List_Id; 3890 Spec : Node_Id; 3891 3892 begin 3893 Specs := Discriminant_Specifications (N); 3894 3895 if Present (Specs) then 3896 Write_Str_With_Col_Check (" ("); 3897 Spec := First (Specs); 3898 3899 loop 3900 Sprint_Node (Spec); 3901 Next (Spec); 3902 exit when Spec = Empty; 3903 3904 -- Add semicolon, unless we are printing original tree and the 3905 -- next specification is part of a list (but not the first 3906 -- element of that list) 3907 3908 if not Dump_Original_Only or else not Prev_Ids (Spec) then 3909 Write_Str ("; "); 3910 end if; 3911 end loop; 3912 3913 Write_Char (')'); 3914 end if; 3915 end Write_Discr_Specs; 3916 3917 ----------------- 3918 -- Write_Ekind -- 3919 ----------------- 3920 3921 procedure Write_Ekind (E : Entity_Id) is 3922 S : constant String := Entity_Kind'Image (Ekind (E)); 3923 3924 begin 3925 Name_Len := S'Length; 3926 Name_Buffer (1 .. Name_Len) := S; 3927 Set_Casing (Mixed_Case); 3928 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 3929 end Write_Ekind; 3930 3931 -------------- 3932 -- Write_Id -- 3933 -------------- 3934 3935 procedure Write_Id (N : Node_Id) is 3936 begin 3937 -- Deal with outputting Itype 3938 3939 -- Note: if we are printing the full tree with -gnatds, then we may 3940 -- end up picking up the Associated_Node link from a generic template 3941 -- here which overlaps the Entity field, but as documented, Write_Itype 3942 -- is defended against junk calls. 3943 3944 if Nkind (N) in N_Entity then 3945 Write_Itype (N); 3946 elsif Nkind (N) in N_Has_Entity then 3947 Write_Itype (Entity (N)); 3948 end if; 3949 3950 -- Case of a defining identifier 3951 3952 if Nkind (N) = N_Defining_Identifier then 3953 3954 -- If defining identifier has an interface name (and no 3955 -- address clause), then we output the interface name. 3956 3957 if (Is_Imported (N) or else Is_Exported (N)) 3958 and then Present (Interface_Name (N)) 3959 and then No (Address_Clause (N)) 3960 then 3961 String_To_Name_Buffer (Strval (Interface_Name (N))); 3962 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 3963 3964 -- If no interface name (or inactive because there was 3965 -- an address clause), then just output the Chars name. 3966 3967 else 3968 Write_Name_With_Col_Check (Chars (N)); 3969 end if; 3970 3971 -- Case of selector of an expanded name where the expanded name 3972 -- has an associated entity, output this entity. Check that the 3973 -- entity or associated node is of the right kind, see above. 3974 3975 elsif Nkind (Parent (N)) = N_Expanded_Name 3976 and then Selector_Name (Parent (N)) = N 3977 and then Present (Entity_Or_Associated_Node (Parent (N))) 3978 and then Nkind (Entity (Parent (N))) in N_Entity 3979 then 3980 Write_Id (Entity (Parent (N))); 3981 3982 -- For any other node with an associated entity, output it 3983 3984 elsif Nkind (N) in N_Has_Entity 3985 and then Present (Entity_Or_Associated_Node (N)) 3986 and then Nkind (Entity_Or_Associated_Node (N)) in N_Entity 3987 then 3988 Write_Id (Entity (N)); 3989 3990 -- All other cases, we just print the Chars field 3991 3992 else 3993 Write_Name_With_Col_Check (Chars (N)); 3994 end if; 3995 end Write_Id; 3996 3997 ----------------------- 3998 -- Write_Identifiers -- 3999 ----------------------- 4000 4001 function Write_Identifiers (Node : Node_Id) return Boolean is 4002 begin 4003 Sprint_Node (Defining_Identifier (Node)); 4004 Update_Itype (Defining_Identifier (Node)); 4005 4006 -- The remainder of the declaration must be printed unless we are 4007 -- printing the original tree and this is not the last identifier 4008 4009 return 4010 not Dump_Original_Only or else not More_Ids (Node); 4011 4012 end Write_Identifiers; 4013 4014 ------------------------ 4015 -- Write_Implicit_Def -- 4016 ------------------------ 4017 4018 procedure Write_Implicit_Def (E : Entity_Id) is 4019 Ind : Node_Id; 4020 4021 begin 4022 case Ekind (E) is 4023 when E_Array_Subtype => 4024 Write_Str_With_Col_Check ("subtype "); 4025 Write_Id (E); 4026 Write_Str_With_Col_Check (" is "); 4027 Write_Id (Base_Type (E)); 4028 Write_Str_With_Col_Check (" ("); 4029 4030 Ind := First_Index (E); 4031 while Present (Ind) loop 4032 Sprint_Node (Ind); 4033 Next_Index (Ind); 4034 4035 if Present (Ind) then 4036 Write_Str (", "); 4037 end if; 4038 end loop; 4039 4040 Write_Str (");"); 4041 4042 when E_Enumeration_Subtype 4043 | E_Signed_Integer_Subtype 4044 => 4045 Write_Str_With_Col_Check ("subtype "); 4046 Write_Id (E); 4047 Write_Str (" is "); 4048 Write_Id (Etype (E)); 4049 Write_Str_With_Col_Check (" range "); 4050 Sprint_Node (Scalar_Range (E)); 4051 Write_Str (";"); 4052 4053 when others => 4054 Write_Str_With_Col_Check ("type "); 4055 Write_Id (E); 4056 Write_Str_With_Col_Check (" is <"); 4057 Write_Ekind (E); 4058 Write_Str (">;"); 4059 end case; 4060 end Write_Implicit_Def; 4061 4062 ------------------ 4063 -- Write_Indent -- 4064 ------------------ 4065 4066 procedure Write_Indent is 4067 Loc : constant Source_Ptr := Sloc (Dump_Node); 4068 4069 begin 4070 if Indent_Annull_Flag then 4071 Indent_Annull_Flag := False; 4072 else 4073 -- Deal with Dump_Source_Text output. Note that we ignore implicit 4074 -- label declarations, since they typically have the sloc of the 4075 -- corresponding label, which really messes up the -gnatL output. 4076 4077 if Dump_Source_Text 4078 and then Loc > No_Location 4079 and then Nkind (Dump_Node) /= N_Implicit_Label_Declaration 4080 then 4081 if Get_Source_File_Index (Loc) = Current_Source_File then 4082 Write_Source_Lines 4083 (Get_Physical_Line_Number (Sloc (Dump_Node))); 4084 end if; 4085 end if; 4086 4087 Write_Eol; 4088 4089 for J in 1 .. Indent loop 4090 Write_Char (' '); 4091 end loop; 4092 end if; 4093 end Write_Indent; 4094 4095 ------------------------------ 4096 -- Write_Indent_Identifiers -- 4097 ------------------------------ 4098 4099 function Write_Indent_Identifiers (Node : Node_Id) return Boolean is 4100 begin 4101 -- We need to start a new line for every node, except in the case 4102 -- where we are printing the original tree and this is not the first 4103 -- defining identifier in the list. 4104 4105 if not Dump_Original_Only or else not Prev_Ids (Node) then 4106 Write_Indent; 4107 4108 -- If printing original tree and this is not the first defining 4109 -- identifier in the list, then the previous call to this procedure 4110 -- printed only the name, and we add a comma to separate the names. 4111 4112 else 4113 Write_Str (", "); 4114 end if; 4115 4116 Sprint_Node (Defining_Identifier (Node)); 4117 4118 -- The remainder of the declaration must be printed unless we are 4119 -- printing the original tree and this is not the last identifier 4120 4121 return 4122 not Dump_Original_Only or else not More_Ids (Node); 4123 end Write_Indent_Identifiers; 4124 4125 ----------------------------------- 4126 -- Write_Indent_Identifiers_Sloc -- 4127 ----------------------------------- 4128 4129 function Write_Indent_Identifiers_Sloc (Node : Node_Id) return Boolean is 4130 begin 4131 -- We need to start a new line for every node, except in the case 4132 -- where we are printing the original tree and this is not the first 4133 -- defining identifier in the list. 4134 4135 if not Dump_Original_Only or else not Prev_Ids (Node) then 4136 Write_Indent; 4137 4138 -- If printing original tree and this is not the first defining 4139 -- identifier in the list, then the previous call to this procedure 4140 -- printed only the name, and we add a comma to separate the names. 4141 4142 else 4143 Write_Str (", "); 4144 end if; 4145 4146 Set_Debug_Sloc; 4147 Sprint_Node (Defining_Identifier (Node)); 4148 4149 -- The remainder of the declaration must be printed unless we are 4150 -- printing the original tree and this is not the last identifier 4151 4152 return not Dump_Original_Only or else not More_Ids (Node); 4153 end Write_Indent_Identifiers_Sloc; 4154 4155 ---------------------- 4156 -- Write_Indent_Str -- 4157 ---------------------- 4158 4159 procedure Write_Indent_Str (S : String) is 4160 begin 4161 Write_Corresponding_Source (S); 4162 Write_Indent; 4163 Write_Str (S); 4164 end Write_Indent_Str; 4165 4166 --------------------------- 4167 -- Write_Indent_Str_Sloc -- 4168 --------------------------- 4169 4170 procedure Write_Indent_Str_Sloc (S : String) is 4171 begin 4172 Write_Corresponding_Source (S); 4173 Write_Indent; 4174 Write_Str_Sloc (S); 4175 end Write_Indent_Str_Sloc; 4176 4177 ----------------- 4178 -- Write_Itype -- 4179 ----------------- 4180 4181 procedure Write_Itype (Typ : Entity_Id) is 4182 4183 procedure Write_Header (T : Boolean := True); 4184 -- Write type if T is True, subtype if T is false 4185 4186 ------------------ 4187 -- Write_Header -- 4188 ------------------ 4189 4190 procedure Write_Header (T : Boolean := True) is 4191 begin 4192 if T then 4193 Write_Str ("[type "); 4194 else 4195 Write_Str ("[subtype "); 4196 end if; 4197 4198 Write_Name_With_Col_Check (Chars (Typ)); 4199 Write_Str (" is "); 4200 end Write_Header; 4201 4202 -- Start of processing for Write_Itype 4203 4204 begin 4205 if Nkind (Typ) in N_Entity 4206 and then Is_Itype (Typ) 4207 and then not Itype_Printed (Typ) 4208 then 4209 -- Itype to be printed 4210 4211 declare 4212 B : constant Node_Id := Etype (Typ); 4213 X : Node_Id; 4214 P : constant Node_Id := Parent (Typ); 4215 4216 S : constant Saved_Output_Buffer := Save_Output_Buffer; 4217 -- Save current output buffer 4218 4219 Old_Sloc : Source_Ptr; 4220 -- Save sloc of related node, so it is not modified when 4221 -- printing with -gnatD. 4222 4223 begin 4224 -- Write indentation at start of line 4225 4226 for J in 1 .. Indent loop 4227 Write_Char (' '); 4228 end loop; 4229 4230 -- If we have a constructed declaration for the itype, print it 4231 4232 if Present (P) 4233 and then Nkind (P) in N_Declaration 4234 and then Defining_Entity (P) = Typ 4235 then 4236 -- We must set Itype_Printed true before the recursive call to 4237 -- print the node, otherwise we get an infinite recursion. 4238 4239 Set_Itype_Printed (Typ, True); 4240 4241 -- Write the declaration enclosed in [], avoiding new line 4242 -- at start of declaration, and semicolon at end. 4243 4244 -- Note: The itype may be imported from another unit, in which 4245 -- case we do not want to modify the Sloc of the declaration. 4246 -- Otherwise the itype may appear to be in the current unit, 4247 -- and the back-end will reject a reference out of scope. 4248 4249 Write_Char ('['); 4250 Indent_Annull_Flag := True; 4251 Old_Sloc := Sloc (P); 4252 Sprint_Node (P); 4253 Set_Sloc (P, Old_Sloc); 4254 Write_Erase_Char (';'); 4255 4256 -- If no constructed declaration, then we have to concoct the 4257 -- source corresponding to the type entity that we have at hand. 4258 4259 else 4260 case Ekind (Typ) is 4261 4262 -- Access types and subtypes 4263 4264 when Access_Kind => 4265 Write_Header (Ekind (Typ) = E_Access_Type); 4266 4267 if Can_Never_Be_Null (Typ) then 4268 Write_Str ("not null "); 4269 end if; 4270 4271 Write_Str ("access "); 4272 4273 if Is_Access_Constant (Typ) then 4274 Write_Str ("constant "); 4275 end if; 4276 4277 Write_Id (Directly_Designated_Type (Typ)); 4278 4279 -- Array types 4280 4281 when E_Array_Type => 4282 Write_Header; 4283 Write_Str ("array ("); 4284 4285 X := First_Index (Typ); 4286 loop 4287 Sprint_Node (X); 4288 4289 if not Is_Constrained (Typ) then 4290 Write_Str (" range <>"); 4291 end if; 4292 4293 Next_Index (X); 4294 exit when No (X); 4295 Write_Str (", "); 4296 end loop; 4297 4298 Write_Str (") of "); 4299 X := Component_Type (Typ); 4300 4301 -- Preserve sloc of component type, which is defined 4302 -- elsewhere than the itype (see comment above). 4303 4304 Old_Sloc := Sloc (X); 4305 Sprint_Node (X); 4306 Set_Sloc (X, Old_Sloc); 4307 4308 -- Array subtypes 4309 4310 -- Preserve Sloc of index subtypes, as above 4311 4312 when E_Array_Subtype => 4313 Write_Header (False); 4314 Write_Id (Etype (Typ)); 4315 Write_Str (" ("); 4316 4317 X := First_Index (Typ); 4318 loop 4319 Old_Sloc := Sloc (X); 4320 Sprint_Node (X); 4321 Set_Sloc (X, Old_Sloc); 4322 Next_Index (X); 4323 exit when No (X); 4324 Write_Str (", "); 4325 end loop; 4326 4327 Write_Char (')'); 4328 4329 -- Signed integer types, and modular integer subtypes, 4330 -- and also enumeration subtypes. 4331 4332 when E_Enumeration_Subtype 4333 | E_Modular_Integer_Subtype 4334 | E_Signed_Integer_Subtype 4335 | E_Signed_Integer_Type 4336 => 4337 Write_Header (Ekind (Typ) = E_Signed_Integer_Type); 4338 4339 if Ekind (Typ) = E_Signed_Integer_Type then 4340 Write_Str ("new "); 4341 end if; 4342 4343 Write_Id (B); 4344 4345 -- Print bounds if different from base type 4346 4347 declare 4348 L : constant Node_Id := Type_Low_Bound (Typ); 4349 H : constant Node_Id := Type_High_Bound (Typ); 4350 LE : Node_Id; 4351 HE : Node_Id; 4352 4353 begin 4354 -- B can either be a scalar type, in which case the 4355 -- declaration of Typ may constrain it with different 4356 -- bounds, or a private type, in which case we know 4357 -- that the declaration of Typ cannot have a scalar 4358 -- constraint. 4359 4360 if Is_Scalar_Type (B) then 4361 LE := Type_Low_Bound (B); 4362 HE := Type_High_Bound (B); 4363 else 4364 LE := Empty; 4365 HE := Empty; 4366 end if; 4367 4368 if No (LE) 4369 or else (True 4370 and then Nkind (L) = N_Integer_Literal 4371 and then Nkind (H) = N_Integer_Literal 4372 and then Nkind (LE) = N_Integer_Literal 4373 and then Nkind (HE) = N_Integer_Literal 4374 and then UI_Eq (Intval (L), Intval (LE)) 4375 and then UI_Eq (Intval (H), Intval (HE))) 4376 then 4377 null; 4378 4379 else 4380 Write_Str (" range "); 4381 Sprint_Node (Type_Low_Bound (Typ)); 4382 Write_Str (" .. "); 4383 Sprint_Node (Type_High_Bound (Typ)); 4384 end if; 4385 end; 4386 4387 -- Modular integer types 4388 4389 when E_Modular_Integer_Type => 4390 Write_Header; 4391 Write_Str ("mod "); 4392 Write_Uint_With_Col_Check (Modulus (Typ), Auto); 4393 4394 -- Floating point types and subtypes 4395 4396 when E_Floating_Point_Subtype 4397 | E_Floating_Point_Type 4398 => 4399 Write_Header (Ekind (Typ) = E_Floating_Point_Type); 4400 4401 if Ekind (Typ) = E_Floating_Point_Type then 4402 Write_Str ("new "); 4403 end if; 4404 4405 Write_Id (Etype (Typ)); 4406 4407 if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then 4408 Write_Str (" digits "); 4409 Write_Uint_With_Col_Check 4410 (Digits_Value (Typ), Decimal); 4411 end if; 4412 4413 -- Print bounds if not different from base type 4414 4415 declare 4416 L : constant Node_Id := Type_Low_Bound (Typ); 4417 H : constant Node_Id := Type_High_Bound (Typ); 4418 LE : constant Node_Id := Type_Low_Bound (B); 4419 HE : constant Node_Id := Type_High_Bound (B); 4420 4421 begin 4422 if Nkind (L) = N_Real_Literal 4423 and then Nkind (H) = N_Real_Literal 4424 and then Nkind (LE) = N_Real_Literal 4425 and then Nkind (HE) = N_Real_Literal 4426 and then UR_Eq (Realval (L), Realval (LE)) 4427 and then UR_Eq (Realval (H), Realval (HE)) 4428 then 4429 null; 4430 4431 else 4432 Write_Str (" range "); 4433 Sprint_Node (Type_Low_Bound (Typ)); 4434 Write_Str (" .. "); 4435 Sprint_Node (Type_High_Bound (Typ)); 4436 end if; 4437 end; 4438 4439 -- Record subtypes 4440 4441 when E_Record_Subtype 4442 | E_Record_Subtype_With_Private 4443 => 4444 Write_Header (False); 4445 Write_Str ("record"); 4446 Indent_Begin; 4447 4448 declare 4449 C : Entity_Id; 4450 begin 4451 C := First_Entity (Typ); 4452 while Present (C) loop 4453 Write_Indent; 4454 Write_Id (C); 4455 Write_Str (" : "); 4456 Write_Id (Etype (C)); 4457 Next_Entity (C); 4458 end loop; 4459 end; 4460 4461 Indent_End; 4462 Write_Indent_Str (" end record"); 4463 4464 -- Class-Wide types 4465 4466 when E_Class_Wide_Subtype 4467 | E_Class_Wide_Type 4468 => 4469 Write_Header (Ekind (Typ) = E_Class_Wide_Type); 4470 Write_Name_With_Col_Check (Chars (Etype (Typ))); 4471 Write_Str ("'Class"); 4472 4473 -- Subprogram types 4474 4475 when E_Subprogram_Type => 4476 Write_Header; 4477 4478 if Etype (Typ) = Standard_Void_Type then 4479 Write_Str ("procedure"); 4480 else 4481 Write_Str ("function"); 4482 end if; 4483 4484 if Present (First_Entity (Typ)) then 4485 Write_Str (" ("); 4486 4487 declare 4488 Param : Entity_Id; 4489 4490 begin 4491 Param := First_Entity (Typ); 4492 loop 4493 Write_Id (Param); 4494 Write_Str (" : "); 4495 4496 if Ekind (Param) = E_In_Out_Parameter then 4497 Write_Str ("in out "); 4498 elsif Ekind (Param) = E_Out_Parameter then 4499 Write_Str ("out "); 4500 end if; 4501 4502 Write_Id (Etype (Param)); 4503 Next_Entity (Param); 4504 exit when No (Param); 4505 Write_Str (", "); 4506 end loop; 4507 4508 Write_Char (')'); 4509 end; 4510 end if; 4511 4512 if Etype (Typ) /= Standard_Void_Type then 4513 Write_Str (" return "); 4514 Write_Id (Etype (Typ)); 4515 end if; 4516 4517 when E_String_Literal_Subtype => 4518 declare 4519 LB : constant Uint := 4520 Expr_Value (String_Literal_Low_Bound (Typ)); 4521 Len : constant Uint := 4522 String_Literal_Length (Typ); 4523 begin 4524 Write_Header (False); 4525 Write_Str ("String ("); 4526 Write_Int (UI_To_Int (LB)); 4527 Write_Str (" .. "); 4528 Write_Int (UI_To_Int (LB + Len) - 1); 4529 Write_Str (");"); 4530 end; 4531 4532 -- For all other Itypes, print ??? (fill in later) 4533 4534 when others => 4535 Write_Header (True); 4536 Write_Str ("???"); 4537 end case; 4538 end if; 4539 4540 -- Add terminating bracket and restore output buffer 4541 4542 Write_Char (']'); 4543 Write_Eol; 4544 Restore_Output_Buffer (S); 4545 end; 4546 4547 Set_Itype_Printed (Typ); 4548 end if; 4549 end Write_Itype; 4550 4551 ------------------------------- 4552 -- Write_Name_With_Col_Check -- 4553 ------------------------------- 4554 4555 procedure Write_Name_With_Col_Check (N : Name_Id) is 4556 J : Natural; 4557 K : Natural; 4558 L : Natural; 4559 4560 begin 4561 -- Avoid crashing on invalid Name_Ids 4562 4563 if not Is_Valid_Name (N) then 4564 Write_Str ("<invalid name "); 4565 Write_Int (Int (N)); 4566 Write_Str (">"); 4567 return; 4568 end if; 4569 4570 Get_Name_String (N); 4571 4572 -- Deal with -gnatdI which replaces any sequence Cnnnb where C is an 4573 -- upper case letter, nnn is one or more digits and b is a lower case 4574 -- letter by C...b, so that listings do not depend on serial numbers. 4575 4576 if Debug_Flag_II then 4577 J := 1; 4578 while J < Name_Len - 1 loop 4579 if Name_Buffer (J) in 'A' .. 'Z' 4580 and then Name_Buffer (J + 1) in '0' .. '9' 4581 then 4582 K := J + 1; 4583 while K < Name_Len loop 4584 exit when Name_Buffer (K) not in '0' .. '9'; 4585 K := K + 1; 4586 end loop; 4587 4588 if Name_Buffer (K) in 'a' .. 'z' then 4589 L := Name_Len - K + 1; 4590 4591 Name_Buffer (J + 4 .. J + L + 3) := 4592 Name_Buffer (K .. Name_Len); 4593 Name_Buffer (J + 1 .. J + 3) := "..."; 4594 Name_Len := J + L + 3; 4595 J := J + 5; 4596 4597 else 4598 J := K; 4599 end if; 4600 4601 else 4602 J := J + 1; 4603 end if; 4604 end loop; 4605 end if; 4606 4607 -- Fall through for normal case 4608 4609 Write_Str_With_Col_Check (Name_Buffer (1 .. Name_Len)); 4610 end Write_Name_With_Col_Check; 4611 4612 ------------------------------------ 4613 -- Write_Name_With_Col_Check_Sloc -- 4614 ------------------------------------ 4615 4616 procedure Write_Name_With_Col_Check_Sloc (N : Name_Id) is 4617 begin 4618 -- Avoid crashing on invalid Name_Ids 4619 4620 if not Is_Valid_Name (N) then 4621 Write_Str ("<invalid name "); 4622 Write_Int (Int (N)); 4623 Write_Str (">"); 4624 return; 4625 end if; 4626 4627 Get_Name_String (N); 4628 Write_Str_With_Col_Check_Sloc (Name_Buffer (1 .. Name_Len)); 4629 end Write_Name_With_Col_Check_Sloc; 4630 4631 -------------------- 4632 -- Write_Operator -- 4633 -------------------- 4634 4635 procedure Write_Operator (N : Node_Id; S : String) is 4636 F : Natural := S'First; 4637 T : Natural := S'Last; 4638 4639 begin 4640 -- If no overflow check, just write string out, and we are done 4641 4642 if not Do_Overflow_Check (N) then 4643 Write_Str_Sloc (S); 4644 4645 -- If overflow check, we want to surround the operator with curly 4646 -- brackets, but not include spaces within the brackets. 4647 4648 else 4649 if S (F) = ' ' then 4650 Write_Char (' '); 4651 F := F + 1; 4652 end if; 4653 4654 if S (T) = ' ' then 4655 T := T - 1; 4656 end if; 4657 4658 Write_Char ('{'); 4659 Write_Str_Sloc (S (F .. T)); 4660 Write_Char ('}'); 4661 4662 if S (S'Last) = ' ' then 4663 Write_Char (' '); 4664 end if; 4665 end if; 4666 end Write_Operator; 4667 4668 ----------------------- 4669 -- Write_Param_Specs -- 4670 ----------------------- 4671 4672 procedure Write_Param_Specs (N : Node_Id) is 4673 Specs : constant List_Id := Parameter_Specifications (N); 4674 Specs_Present : constant Boolean := Is_Non_Empty_List (Specs); 4675 4676 Ent : Entity_Id; 4677 Extras : Node_Id; 4678 Spec : Node_Id; 4679 Formal : Node_Id; 4680 4681 Output : Boolean := False; 4682 -- Set true if we output at least one parameter 4683 4684 begin 4685 -- Write out explicit specs from Parameter_Speficiations list 4686 4687 if Specs_Present then 4688 Write_Str_With_Col_Check (" ("); 4689 Output := True; 4690 4691 Spec := First (Specs); 4692 loop 4693 Sprint_Node (Spec); 4694 Formal := Defining_Identifier (Spec); 4695 Next (Spec); 4696 exit when Spec = Empty; 4697 4698 -- Add semicolon, unless we are printing original tree and the 4699 -- next specification is part of a list (but not the first element 4700 -- of that list). 4701 4702 if not Dump_Original_Only or else not Prev_Ids (Spec) then 4703 Write_Str ("; "); 4704 end if; 4705 end loop; 4706 end if; 4707 4708 -- See if we have extra formals 4709 4710 if Nkind_In (N, N_Function_Specification, 4711 N_Procedure_Specification) 4712 then 4713 Ent := Defining_Entity (N); 4714 4715 -- Loop to write extra formals (if any) 4716 4717 if Present (Ent) and then Is_Subprogram (Ent) then 4718 Extras := Extra_Formals (Ent); 4719 4720 if Present (Extras) then 4721 if not Specs_Present then 4722 Write_Str_With_Col_Check (" ("); 4723 Output := True; 4724 end if; 4725 4726 Formal := Extras; 4727 while Present (Formal) loop 4728 if Specs_Present or else Formal /= Extras then 4729 Write_Str ("; "); 4730 end if; 4731 4732 Write_Name_With_Col_Check (Chars (Formal)); 4733 Write_Str (" : "); 4734 Write_Name_With_Col_Check (Chars (Etype (Formal))); 4735 Formal := Extra_Formal (Formal); 4736 end loop; 4737 end if; 4738 end if; 4739 end if; 4740 4741 if Output then 4742 Write_Char (')'); 4743 end if; 4744 end Write_Param_Specs; 4745 4746 ----------------------- 4747 -- Write_Rewrite_Str -- 4748 ----------------------- 4749 4750 procedure Write_Rewrite_Str (S : String) is 4751 begin 4752 if not Dump_Generated_Only then 4753 if S'Length = 3 and then S = ">>>" then 4754 Write_Str (">>>"); 4755 else 4756 Write_Str_With_Col_Check (S); 4757 end if; 4758 end if; 4759 end Write_Rewrite_Str; 4760 4761 ----------------------- 4762 -- Write_Source_Line -- 4763 ----------------------- 4764 4765 procedure Write_Source_Line (L : Physical_Line_Number) is 4766 Loc : Source_Ptr; 4767 Src : Source_Buffer_Ptr; 4768 Scn : Source_Ptr; 4769 4770 begin 4771 if Dump_Source_Text then 4772 Src := Source_Text (Current_Source_File); 4773 Loc := Line_Start (L, Current_Source_File); 4774 Write_Eol; 4775 4776 -- See if line is a comment line, if not, and if not line one, 4777 -- precede with blank line. 4778 4779 Scn := Loc; 4780 while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop 4781 Scn := Scn + 1; 4782 end loop; 4783 4784 if (Src (Scn) in Line_Terminator 4785 or else Src (Scn .. Scn + 1) /= "--") 4786 and then L /= 1 4787 then 4788 Write_Eol; 4789 end if; 4790 4791 -- Now write the source text of the line 4792 4793 Write_Str ("-- "); 4794 Write_Int (Int (L)); 4795 Write_Str (": "); 4796 4797 while Src (Loc) not in Line_Terminator loop 4798 Write_Char (Src (Loc)); 4799 Loc := Loc + 1; 4800 end loop; 4801 end if; 4802 end Write_Source_Line; 4803 4804 ------------------------ 4805 -- Write_Source_Lines -- 4806 ------------------------ 4807 4808 procedure Write_Source_Lines (L : Physical_Line_Number) is 4809 begin 4810 while Last_Line_Printed < L loop 4811 Last_Line_Printed := Last_Line_Printed + 1; 4812 Write_Source_Line (Last_Line_Printed); 4813 end loop; 4814 end Write_Source_Lines; 4815 4816 -------------------- 4817 -- Write_Str_Sloc -- 4818 -------------------- 4819 4820 procedure Write_Str_Sloc (S : String) is 4821 begin 4822 for J in S'Range loop 4823 Write_Char_Sloc (S (J)); 4824 end loop; 4825 end Write_Str_Sloc; 4826 4827 ------------------------------ 4828 -- Write_Str_With_Col_Check -- 4829 ------------------------------ 4830 4831 procedure Write_Str_With_Col_Check (S : String) is 4832 begin 4833 if Int (S'Last) + Column > Sprint_Line_Limit then 4834 Write_Indent_Str (" "); 4835 4836 if S (S'First) = ' ' then 4837 Write_Str (S (S'First + 1 .. S'Last)); 4838 else 4839 Write_Str (S); 4840 end if; 4841 4842 else 4843 Write_Str (S); 4844 end if; 4845 end Write_Str_With_Col_Check; 4846 4847 ----------------------------------- 4848 -- Write_Str_With_Col_Check_Sloc -- 4849 ----------------------------------- 4850 4851 procedure Write_Str_With_Col_Check_Sloc (S : String) is 4852 begin 4853 if Int (S'Last) + Column > Sprint_Line_Limit then 4854 Write_Indent_Str (" "); 4855 4856 if S (S'First) = ' ' then 4857 Write_Str_Sloc (S (S'First + 1 .. S'Last)); 4858 else 4859 Write_Str_Sloc (S); 4860 end if; 4861 4862 else 4863 Write_Str_Sloc (S); 4864 end if; 4865 end Write_Str_With_Col_Check_Sloc; 4866 4867 --------------------------- 4868 -- Write_Subprogram_Name -- 4869 --------------------------- 4870 4871 procedure Write_Subprogram_Name (N : Node_Id) is 4872 begin 4873 if not Comes_From_Source (N) 4874 and then Is_Entity_Name (N) 4875 then 4876 declare 4877 Ent : constant Entity_Id := Entity (N); 4878 begin 4879 if not In_Extended_Main_Source_Unit (Ent) 4880 and then In_Predefined_Unit (Ent) 4881 then 4882 -- Run-time routine name, output name with a preceding dollar 4883 -- making sure that we do not get a line split between them. 4884 4885 Col_Check (Length_Of_Name (Chars (Ent)) + 1); 4886 Write_Char ('$'); 4887 Write_Name (Chars (Ent)); 4888 return; 4889 end if; 4890 end; 4891 end if; 4892 4893 -- Normal case, not a run-time routine name 4894 4895 Sprint_Node (N); 4896 end Write_Subprogram_Name; 4897 4898 ------------------------------- 4899 -- Write_Uint_With_Col_Check -- 4900 ------------------------------- 4901 4902 procedure Write_Uint_With_Col_Check (U : Uint; Format : UI_Format) is 4903 begin 4904 Col_Check (UI_Decimal_Digits_Hi (U)); 4905 UI_Write (U, Format); 4906 end Write_Uint_With_Col_Check; 4907 4908 ------------------------------------ 4909 -- Write_Uint_With_Col_Check_Sloc -- 4910 ------------------------------------ 4911 4912 procedure Write_Uint_With_Col_Check_Sloc (U : Uint; Format : UI_Format) is 4913 begin 4914 Col_Check (UI_Decimal_Digits_Hi (U)); 4915 Set_Debug_Sloc; 4916 UI_Write (U, Format); 4917 end Write_Uint_With_Col_Check_Sloc; 4918 4919 ------------------------------------- 4920 -- Write_Ureal_With_Col_Check_Sloc -- 4921 ------------------------------------- 4922 4923 procedure Write_Ureal_With_Col_Check_Sloc (U : Ureal) is 4924 D : constant Uint := Denominator (U); 4925 N : constant Uint := Numerator (U); 4926 begin 4927 Col_Check (UI_Decimal_Digits_Hi (D) + UI_Decimal_Digits_Hi (N) + 4); 4928 Set_Debug_Sloc; 4929 UR_Write (U, Brackets => True); 4930 end Write_Ureal_With_Col_Check_Sloc; 4931 4932end Sprint; 4933