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