1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P P R I N T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2008-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 Atree; use Atree; 27with Csets; use Csets; 28with Einfo; use Einfo; 29with Namet; use Namet; 30with Nlists; use Nlists; 31with Opt; use Opt; 32with Sinfo; use Sinfo; 33with Sinput; use Sinput; 34with Snames; use Snames; 35with Uintp; use Uintp; 36 37package body Pprint is 38 39 List_Name_Count : Integer := 0; 40 -- Counter used to prevent infinite recursion while computing name of 41 -- complex expressions. 42 43 ---------------------- 44 -- Expression_Image -- 45 ---------------------- 46 47 function Expression_Image 48 (Expr : Node_Id; 49 Default : String) return String 50 is 51 From_Source : constant Boolean := 52 Comes_From_Source (Expr) 53 and then not Opt.Debug_Generated_Code; 54 Append_Paren : Natural := 0; 55 Left : Node_Id := Original_Node (Expr); 56 Right : Node_Id := Original_Node (Expr); 57 58 function Expr_Name 59 (Expr : Node_Id; 60 Take_Prefix : Boolean := True; 61 Expand_Type : Boolean := True) return String; 62 -- Return string corresponding to Expr. If no string can be extracted, 63 -- return "...". If Take_Prefix is True, go back to prefix when needed, 64 -- otherwise only consider the right-hand side of an expression. If 65 -- Expand_Type is True and Expr is a type, try to expand Expr (an 66 -- internally generated type) into a user understandable name. 67 68 Max_List : constant := 3; 69 -- Limit number of list elements to dump 70 71 Max_Expr_Elements : constant := 24; 72 -- Limit number of elements in an expression for use by Expr_Name 73 74 Num_Elements : Natural := 0; 75 -- Current number of elements processed by Expr_Name 76 77 function List_Name 78 (List : Node_Id; 79 Add_Space : Boolean := True; 80 Add_Paren : Boolean := True) return String; 81 -- Return a string corresponding to List 82 83 --------------- 84 -- List_Name -- 85 --------------- 86 87 function List_Name 88 (List : Node_Id; 89 Add_Space : Boolean := True; 90 Add_Paren : Boolean := True) return String 91 is 92 function Internal_List_Name 93 (List : Node_Id; 94 First : Boolean := True; 95 Add_Space : Boolean := True; 96 Add_Paren : Boolean := True; 97 Num : Natural := 1) return String; 98 -- ??? what does this do 99 100 ------------------------ 101 -- Internal_List_Name -- 102 ------------------------ 103 104 function Internal_List_Name 105 (List : Node_Id; 106 First : Boolean := True; 107 Add_Space : Boolean := True; 108 Add_Paren : Boolean := True; 109 Num : Natural := 1) return String 110 is 111 function Prepend (S : String) return String; 112 -- ??? what does this do 113 114 ------------- 115 -- Prepend -- 116 ------------- 117 118 function Prepend (S : String) return String is 119 begin 120 if Add_Space then 121 if Add_Paren then 122 return " (" & S; 123 else 124 return ' ' & S; 125 end if; 126 elsif Add_Paren then 127 return '(' & S; 128 else 129 return S; 130 end if; 131 end Prepend; 132 133 -- Start of processing for Internal_List_Name 134 135 begin 136 if not Present (List) then 137 if First or else not Add_Paren then 138 return ""; 139 else 140 return ")"; 141 end if; 142 elsif Num > Max_List then 143 if Add_Paren then 144 return ", ...)"; 145 else 146 return ", ..."; 147 end if; 148 end if; 149 150 -- ??? the Internal_List_Name calls can be factored out 151 152 if First then 153 return Prepend (Expr_Name (List) 154 & Internal_List_Name 155 (List => Next (List), 156 First => False, 157 Add_Paren => Add_Paren, 158 Num => Num + 1)); 159 else 160 return ", " & Expr_Name (List) 161 & Internal_List_Name 162 (List => Next (List), 163 First => False, 164 Add_Paren => Add_Paren, 165 Num => Num + 1); 166 end if; 167 end Internal_List_Name; 168 169 -- Start of processing for List_Name 170 171 begin 172 -- Prevent infinite recursion by limiting depth to 3 173 174 if List_Name_Count > 3 then 175 return "..."; 176 end if; 177 178 List_Name_Count := List_Name_Count + 1; 179 180 declare 181 Result : constant String := 182 Internal_List_Name 183 (List => List, 184 Add_Space => Add_Space, 185 Add_Paren => Add_Paren); 186 begin 187 List_Name_Count := List_Name_Count - 1; 188 return Result; 189 end; 190 end List_Name; 191 192 --------------- 193 -- Expr_Name -- 194 --------------- 195 196 function Expr_Name 197 (Expr : Node_Id; 198 Take_Prefix : Boolean := True; 199 Expand_Type : Boolean := True) return String 200 is 201 begin 202 Num_Elements := Num_Elements + 1; 203 204 if Num_Elements > Max_Expr_Elements then 205 return "..."; 206 end if; 207 208 case Nkind (Expr) is 209 when N_Defining_Identifier 210 | N_Identifier 211 => 212 return Ident_Image (Expr, Expression_Image.Expr, Expand_Type); 213 214 when N_Character_Literal => 215 declare 216 Char : constant Int := UI_To_Int (Char_Literal_Value (Expr)); 217 begin 218 if Char in 32 .. 127 then 219 return "'" & Character'Val (Char) & "'"; 220 else 221 UI_Image (Char_Literal_Value (Expr)); 222 return 223 "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'"; 224 end if; 225 end; 226 227 when N_Integer_Literal => 228 UI_Image (Intval (Expr)); 229 return UI_Image_Buffer (1 .. UI_Image_Length); 230 231 when N_Real_Literal => 232 return Real_Image (Realval (Expr)); 233 234 when N_String_Literal => 235 return String_Image (Strval (Expr)); 236 237 when N_Allocator => 238 return "new " & Expr_Name (Expression (Expr)); 239 240 when N_Aggregate => 241 if Present (Sinfo.Expressions (Expr)) then 242 return 243 List_Name 244 (List => First (Sinfo.Expressions (Expr)), 245 Add_Space => False); 246 247 -- Do not return empty string for (others => <>) aggregate 248 -- of a componentless record type. At least one caller (the 249 -- recursive call below in the N_Qualified_Expression case) 250 -- is not prepared to deal with a zero-length result. 251 252 elsif Null_Record_Present (Expr) 253 or else not Present (First (Component_Associations (Expr))) 254 then 255 return ("(null record)"); 256 257 else 258 return 259 List_Name 260 (List => First (Component_Associations (Expr)), 261 Add_Space => False, 262 Add_Paren => False); 263 end if; 264 265 when N_Extension_Aggregate => 266 return "(" & Expr_Name (Ancestor_Part (Expr)) & " with " 267 & List_Name 268 (List => First (Sinfo.Expressions (Expr)), 269 Add_Space => False, 270 Add_Paren => False) & ")"; 271 272 when N_Attribute_Reference => 273 if Take_Prefix then 274 declare 275 function To_Mixed_Case (S : String) return String; 276 -- Transform given string into the corresponding one in 277 -- mixed case form. 278 279 ------------------- 280 -- To_Mixed_Case -- 281 ------------------- 282 283 function To_Mixed_Case (S : String) return String is 284 Result : String (S'Range); 285 Ucase : Boolean := True; 286 287 begin 288 for J in S'Range loop 289 if Ucase then 290 Result (J) := Fold_Upper (S (J)); 291 else 292 Result (J) := Fold_Lower (S (J)); 293 end if; 294 295 Ucase := (S (J) = '_'); 296 end loop; 297 298 return Result; 299 end To_Mixed_Case; 300 301 Id : constant Attribute_Id := 302 Get_Attribute_Id (Attribute_Name (Expr)); 303 304 -- Always use mixed case for attributes 305 306 Str : constant String := 307 Expr_Name (Prefix (Expr)) 308 & "'" 309 & To_Mixed_Case 310 (Get_Name_String (Attribute_Name (Expr))); 311 312 N : Node_Id; 313 Ranges : List_Id; 314 315 begin 316 if (Id = Attribute_First or else Id = Attribute_Last) 317 and then Str (Str'First) = '$' 318 then 319 N := Associated_Node_For_Itype (Etype (Prefix (Expr))); 320 321 if Present (N) then 322 if Nkind (N) = N_Full_Type_Declaration then 323 N := Type_Definition (N); 324 end if; 325 326 if Nkind (N) = N_Subtype_Declaration then 327 Ranges := 328 Constraints 329 (Constraint (Subtype_Indication (N))); 330 331 if List_Length (Ranges) = 1 332 and then Nkind (First (Ranges)) in 333 N_Range | 334 N_Real_Range_Specification | 335 N_Signed_Integer_Type_Definition 336 then 337 if Id = Attribute_First then 338 return 339 Expression_Image 340 (Low_Bound (First (Ranges)), Str); 341 else 342 return 343 Expression_Image 344 (High_Bound (First (Ranges)), Str); 345 end if; 346 end if; 347 end if; 348 end if; 349 end if; 350 351 return Str; 352 end; 353 else 354 return "'" & Get_Name_String (Attribute_Name (Expr)); 355 end if; 356 357 when N_Explicit_Dereference => 358 Explicit_Dereference : declare 359 function Deref_Suffix return String; 360 -- Usually returns ".all", but will return "" if 361 -- Hide_Temp_Derefs is true and the prefix is a use of a 362 -- not-from-source object declared as 363 -- X : constant Some_Access_Type := Some_Expr'Reference; 364 -- (as is sometimes done in Exp_Util.Remove_Side_Effects). 365 366 ------------------ 367 -- Deref_Suffix -- 368 ------------------ 369 370 function Deref_Suffix return String is 371 Decl : Node_Id; 372 373 begin 374 if Hide_Temp_Derefs 375 and then Nkind (Prefix (Expr)) = N_Identifier 376 and then Nkind (Entity (Prefix (Expr))) = 377 N_Defining_Identifier 378 then 379 Decl := Parent (Entity (Prefix (Expr))); 380 381 if Present (Decl) 382 and then Nkind (Decl) = N_Object_Declaration 383 and then not Comes_From_Source (Decl) 384 and then Constant_Present (Decl) 385 and then Present (Sinfo.Expression (Decl)) 386 and then Nkind (Sinfo.Expression (Decl)) = 387 N_Reference 388 then 389 return ""; 390 end if; 391 end if; 392 393 -- The default case 394 395 return ".all"; 396 end Deref_Suffix; 397 398 -- Start of processing for Explicit_Dereference 399 400 begin 401 if Hide_Parameter_Blocks 402 and then Nkind (Prefix (Expr)) = N_Selected_Component 403 and then Present (Etype (Prefix (Expr))) 404 and then Is_Access_Type (Etype (Prefix (Expr))) 405 and then Is_Param_Block_Component_Type 406 (Etype (Prefix (Expr))) 407 then 408 -- Return "Foo" instead of "Parameter_Block.Foo.all" 409 410 return Expr_Name (Selector_Name (Prefix (Expr))); 411 412 elsif Take_Prefix then 413 return Expr_Name (Prefix (Expr)) & Deref_Suffix; 414 else 415 return Deref_Suffix; 416 end if; 417 end Explicit_Dereference; 418 419 when N_Expanded_Name 420 | N_Selected_Component 421 => 422 if Take_Prefix then 423 return 424 Expr_Name (Prefix (Expr)) & "." & 425 Expr_Name (Selector_Name (Expr)); 426 else 427 return "." & Expr_Name (Selector_Name (Expr)); 428 end if; 429 430 when N_Component_Association => 431 return "(" 432 & List_Name 433 (List => First (Choices (Expr)), 434 Add_Space => False, 435 Add_Paren => False) 436 & " => " & Expr_Name (Expression (Expr)) & ")"; 437 438 when N_If_Expression => 439 declare 440 N : constant Node_Id := First (Sinfo.Expressions (Expr)); 441 begin 442 return 443 "if " & Expr_Name (N) & " then " 444 & Expr_Name (Next (N)) & " else " 445 & Expr_Name (Next (Next (N))); 446 end; 447 448 when N_Qualified_Expression => 449 declare 450 Mark : constant String := 451 Expr_Name 452 (Subtype_Mark (Expr), Expand_Type => False); 453 Str : constant String := Expr_Name (Expression (Expr)); 454 begin 455 if Str (Str'First) = '(' and then Str (Str'Last) = ')' then 456 return Mark & "'" & Str; 457 else 458 return Mark & "'(" & Str & ")"; 459 end if; 460 end; 461 462 when N_Expression_With_Actions 463 | N_Unchecked_Expression 464 => 465 return Expr_Name (Expression (Expr)); 466 467 when N_Raise_Constraint_Error => 468 if Present (Condition (Expr)) then 469 return 470 "[constraint_error when " 471 & Expr_Name (Condition (Expr)) & "]"; 472 else 473 return "[constraint_error]"; 474 end if; 475 476 when N_Raise_Program_Error => 477 if Present (Condition (Expr)) then 478 return 479 "[program_error when " 480 & Expr_Name (Condition (Expr)) & "]"; 481 else 482 return "[program_error]"; 483 end if; 484 485 when N_Range => 486 return 487 Expr_Name (Low_Bound (Expr)) & ".." & 488 Expr_Name (High_Bound (Expr)); 489 490 when N_Slice => 491 return 492 Expr_Name (Prefix (Expr)) & " (" & 493 Expr_Name (Discrete_Range (Expr)) & ")"; 494 495 when N_And_Then => 496 return 497 Expr_Name (Left_Opnd (Expr)) & " and then " & 498 Expr_Name (Right_Opnd (Expr)); 499 500 when N_In => 501 return 502 Expr_Name (Left_Opnd (Expr)) & " in " & 503 Expr_Name (Right_Opnd (Expr)); 504 505 when N_Not_In => 506 return 507 Expr_Name (Left_Opnd (Expr)) & " not in " & 508 Expr_Name (Right_Opnd (Expr)); 509 510 when N_Or_Else => 511 return 512 Expr_Name (Left_Opnd (Expr)) & " or else " & 513 Expr_Name (Right_Opnd (Expr)); 514 515 when N_Op_And => 516 return 517 Expr_Name (Left_Opnd (Expr)) & " and " & 518 Expr_Name (Right_Opnd (Expr)); 519 520 when N_Op_Or => 521 return 522 Expr_Name (Left_Opnd (Expr)) & " or " & 523 Expr_Name (Right_Opnd (Expr)); 524 525 when N_Op_Xor => 526 return 527 Expr_Name (Left_Opnd (Expr)) & " xor " & 528 Expr_Name (Right_Opnd (Expr)); 529 530 when N_Op_Eq => 531 return 532 Expr_Name (Left_Opnd (Expr)) & " = " & 533 Expr_Name (Right_Opnd (Expr)); 534 535 when N_Op_Ne => 536 return 537 Expr_Name (Left_Opnd (Expr)) & " /= " & 538 Expr_Name (Right_Opnd (Expr)); 539 540 when N_Op_Lt => 541 return 542 Expr_Name (Left_Opnd (Expr)) & " < " & 543 Expr_Name (Right_Opnd (Expr)); 544 545 when N_Op_Le => 546 return 547 Expr_Name (Left_Opnd (Expr)) & " <= " & 548 Expr_Name (Right_Opnd (Expr)); 549 550 when N_Op_Gt => 551 return 552 Expr_Name (Left_Opnd (Expr)) & " > " & 553 Expr_Name (Right_Opnd (Expr)); 554 555 when N_Op_Ge => 556 return 557 Expr_Name (Left_Opnd (Expr)) & " >= " & 558 Expr_Name (Right_Opnd (Expr)); 559 560 when N_Op_Add => 561 return 562 Expr_Name (Left_Opnd (Expr)) & " + " & 563 Expr_Name (Right_Opnd (Expr)); 564 565 when N_Op_Subtract => 566 return 567 Expr_Name (Left_Opnd (Expr)) & " - " & 568 Expr_Name (Right_Opnd (Expr)); 569 570 when N_Op_Multiply => 571 return 572 Expr_Name (Left_Opnd (Expr)) & " * " & 573 Expr_Name (Right_Opnd (Expr)); 574 575 when N_Op_Divide => 576 return 577 Expr_Name (Left_Opnd (Expr)) & " / " & 578 Expr_Name (Right_Opnd (Expr)); 579 580 when N_Op_Mod => 581 return 582 Expr_Name (Left_Opnd (Expr)) & " mod " & 583 Expr_Name (Right_Opnd (Expr)); 584 585 when N_Op_Rem => 586 return 587 Expr_Name (Left_Opnd (Expr)) & " rem " & 588 Expr_Name (Right_Opnd (Expr)); 589 590 when N_Op_Expon => 591 return 592 Expr_Name (Left_Opnd (Expr)) & " ** " & 593 Expr_Name (Right_Opnd (Expr)); 594 595 when N_Op_Shift_Left => 596 return 597 Expr_Name (Left_Opnd (Expr)) & " << " & 598 Expr_Name (Right_Opnd (Expr)); 599 600 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic => 601 return 602 Expr_Name (Left_Opnd (Expr)) & " >> " & 603 Expr_Name (Right_Opnd (Expr)); 604 605 when N_Op_Concat => 606 return 607 Expr_Name (Left_Opnd (Expr)) & " & " & 608 Expr_Name (Right_Opnd (Expr)); 609 610 when N_Op_Plus => 611 return "+" & Expr_Name (Right_Opnd (Expr)); 612 613 when N_Op_Minus => 614 return "-" & Expr_Name (Right_Opnd (Expr)); 615 616 when N_Op_Abs => 617 return "abs " & Expr_Name (Right_Opnd (Expr)); 618 619 when N_Op_Not => 620 return "not (" & Expr_Name (Right_Opnd (Expr)) & ")"; 621 622 when N_Parameter_Association => 623 return Expr_Name (Explicit_Actual_Parameter (Expr)); 624 625 when N_Type_Conversion => 626 627 -- Most conversions are not very interesting (used inside 628 -- expanded checks to convert to larger ranges), so skip them. 629 630 return Expr_Name (Expression (Expr)); 631 632 when N_Unchecked_Type_Conversion => 633 634 -- Only keep the type conversion in complex cases 635 636 if not Is_Scalar_Type (Etype (Expr)) 637 or else not Is_Scalar_Type (Etype (Expression (Expr))) 638 or else Is_Modular_Integer_Type (Etype (Expr)) /= 639 Is_Modular_Integer_Type (Etype (Expression (Expr))) 640 then 641 return Expr_Name (Subtype_Mark (Expr)) & 642 "(" & Expr_Name (Expression (Expr)) & ")"; 643 else 644 return Expr_Name (Expression (Expr)); 645 end if; 646 647 when N_Indexed_Component => 648 if Take_Prefix then 649 return 650 Expr_Name (Prefix (Expr)) 651 & List_Name (First (Sinfo.Expressions (Expr))); 652 else 653 return List_Name (First (Sinfo.Expressions (Expr))); 654 end if; 655 656 when N_Function_Call => 657 658 -- If Default = "", it means we're expanding the name of 659 -- a gnat temporary (and not really a function call), so add 660 -- parentheses around function call to mark it specially. 661 662 if Default = "" then 663 return '(' 664 & Expr_Name (Name (Expr)) 665 & List_Name (First (Sinfo.Parameter_Associations (Expr))) 666 & ')'; 667 else 668 return 669 Expr_Name (Name (Expr)) 670 & List_Name 671 (First (Sinfo.Parameter_Associations (Expr))); 672 end if; 673 674 when N_Null => 675 return "null"; 676 677 when N_Others_Choice => 678 return "others"; 679 680 when others => 681 return "..."; 682 end case; 683 end Expr_Name; 684 685 -- Start of processing for Expression_Name 686 687 begin 688 if not From_Source then 689 declare 690 S : constant String := Expr_Name (Expr); 691 begin 692 if S = "..." then 693 return Default; 694 else 695 return S; 696 end if; 697 end; 698 end if; 699 700 -- Compute left (start) and right (end) slocs for the expression 701 -- Consider using Sinput.Sloc_Range instead, except that it does not 702 -- work properly currently??? 703 704 loop 705 case Nkind (Left) is 706 when N_And_Then 707 | N_Binary_Op 708 | N_Membership_Test 709 | N_Or_Else 710 => 711 Left := Original_Node (Left_Opnd (Left)); 712 713 when N_Attribute_Reference 714 | N_Expanded_Name 715 | N_Explicit_Dereference 716 | N_Indexed_Component 717 | N_Reference 718 | N_Selected_Component 719 | N_Slice 720 => 721 Left := Original_Node (Prefix (Left)); 722 723 when N_Defining_Program_Unit_Name 724 | N_Designator 725 | N_Function_Call 726 => 727 Left := Original_Node (Name (Left)); 728 729 when N_Range => 730 Left := Original_Node (Low_Bound (Left)); 731 732 when N_Qualified_Expression 733 | N_Type_Conversion 734 => 735 Left := Original_Node (Subtype_Mark (Left)); 736 737 -- For any other item, quit loop 738 739 when others => 740 exit; 741 end case; 742 end loop; 743 744 loop 745 case Nkind (Right) is 746 when N_And_Then 747 | N_Membership_Test 748 | N_Op 749 | N_Or_Else 750 => 751 Right := Original_Node (Right_Opnd (Right)); 752 753 when N_Expanded_Name 754 | N_Selected_Component 755 => 756 Right := Original_Node (Selector_Name (Right)); 757 758 when N_Qualified_Expression 759 | N_Type_Conversion 760 => 761 Right := Original_Node (Expression (Right)); 762 763 -- If argument does not already account for a closing 764 -- parenthesis, count one here. 765 766 if Nkind (Right) not in N_Aggregate | N_Quantified_Expression 767 then 768 Append_Paren := Append_Paren + 1; 769 end if; 770 771 when N_Designator => 772 Right := Original_Node (Identifier (Right)); 773 774 when N_Defining_Program_Unit_Name => 775 Right := Original_Node (Defining_Identifier (Right)); 776 777 when N_Range => 778 Right := Original_Node (High_Bound (Right)); 779 780 when N_Parameter_Association => 781 Right := Original_Node (Explicit_Actual_Parameter (Right)); 782 783 when N_Component_Association => 784 if Present (Expression (Right)) then 785 Right := Expression (Right); 786 else 787 Right := Last (Choices (Right)); 788 end if; 789 790 when N_Indexed_Component => 791 Right := Original_Node (Last (Sinfo.Expressions (Right))); 792 Append_Paren := Append_Paren + 1; 793 794 when N_Function_Call => 795 if Present (Sinfo.Parameter_Associations (Right)) then 796 declare 797 Rover : Node_Id; 798 Found : Boolean; 799 800 begin 801 -- Avoid source position confusion associated with 802 -- parameters for which Comes_From_Source is False. 803 804 Rover := First (Sinfo.Parameter_Associations (Right)); 805 Found := False; 806 while Present (Rover) loop 807 if Comes_From_Source (Original_Node (Rover)) then 808 Right := Original_Node (Rover); 809 Found := True; 810 end if; 811 812 Next (Rover); 813 end loop; 814 815 if Found then 816 Append_Paren := Append_Paren + 1; 817 end if; 818 819 -- Quit loop if no Comes_From_Source parameters 820 821 exit when not Found; 822 end; 823 824 -- Quit loop if no parameters 825 826 else 827 exit; 828 end if; 829 830 when N_Quantified_Expression => 831 Right := Original_Node (Condition (Right)); 832 Append_Paren := Append_Paren + 1; 833 834 when N_Aggregate => 835 declare 836 Aggr : constant Node_Id := Right; 837 Sub : Node_Id; 838 839 begin 840 Sub := First (Expressions (Aggr)); 841 while Present (Sub) loop 842 if Sloc (Sub) > Sloc (Right) then 843 Right := Sub; 844 end if; 845 846 Next (Sub); 847 end loop; 848 849 Sub := First (Component_Associations (Aggr)); 850 while Present (Sub) loop 851 if Sloc (Sub) > Sloc (Right) then 852 Right := Sub; 853 end if; 854 855 Next (Sub); 856 end loop; 857 858 exit when Right = Aggr; 859 860 Append_Paren := Append_Paren + 1; 861 end; 862 863 -- For all other items, quit the loop 864 865 when others => 866 exit; 867 end case; 868 end loop; 869 870 declare 871 Scn : Source_Ptr := Original_Location (Sloc (Left)); 872 End_Sloc : constant Source_Ptr := 873 Original_Location (Sloc (Right)); 874 Src : constant Source_Buffer_Ptr := 875 Source_Text (Get_Source_File_Index (Scn)); 876 877 begin 878 if Scn > End_Sloc then 879 return Default; 880 end if; 881 882 declare 883 Threshold : constant := 256; 884 Buffer : String (1 .. Natural (End_Sloc - Scn)); 885 Index : Natural := 0; 886 Skipping_Comment : Boolean := False; 887 Underscore : Boolean := False; 888 889 begin 890 if Right /= Expr then 891 while Scn < End_Sloc loop 892 case Src (Scn) is 893 894 -- Give up on non ASCII characters 895 896 when Character'Val (128) .. Character'Last => 897 Append_Paren := 0; 898 Index := 0; 899 Right := Expr; 900 exit; 901 902 when ' ' 903 | ASCII.HT 904 => 905 if not Skipping_Comment and then not Underscore then 906 Underscore := True; 907 Index := Index + 1; 908 Buffer (Index) := ' '; 909 end if; 910 911 -- CR/LF/FF is the end of any comment 912 913 when ASCII.CR 914 | ASCII.FF 915 | ASCII.LF 916 => 917 Skipping_Comment := False; 918 919 when others => 920 Underscore := False; 921 922 if not Skipping_Comment then 923 924 -- Ignore comment 925 926 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then 927 Skipping_Comment := True; 928 929 else 930 Index := Index + 1; 931 Buffer (Index) := Src (Scn); 932 end if; 933 end if; 934 end case; 935 936 -- Give up on too long strings 937 938 if Index >= Threshold then 939 return Buffer (1 .. Index) & "..."; 940 end if; 941 942 Scn := Scn + 1; 943 end loop; 944 end if; 945 946 if Index < 1 then 947 declare 948 S : constant String := Expr_Name (Right); 949 begin 950 if S = "..." then 951 return Default; 952 else 953 return S; 954 end if; 955 end; 956 957 else 958 return 959 Buffer (1 .. Index) 960 & Expr_Name (Right, False) 961 & (1 .. Append_Paren => ')'); 962 end if; 963 end; 964 end; 965 end Expression_Image; 966 967end Pprint; 968