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