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-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with 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 333 Nkind_In 334 (First (Ranges), 335 N_Range, 336 N_Real_Range_Specification, 337 N_Signed_Integer_Type_Definition) 338 then 339 if Id = Attribute_First then 340 return 341 Expression_Image 342 (Low_Bound (First (Ranges)), Str); 343 else 344 return 345 Expression_Image 346 (High_Bound (First (Ranges)), Str); 347 end if; 348 end if; 349 end if; 350 end if; 351 end if; 352 353 return Str; 354 end; 355 else 356 return "'" & Get_Name_String (Attribute_Name (Expr)); 357 end if; 358 359 when N_Explicit_Dereference => 360 Explicit_Dereference : declare 361 function Deref_Suffix return String; 362 -- Usually returns ".all", but will return "" if 363 -- Hide_Temp_Derefs is true and the prefix is a use of a 364 -- not-from-source object declared as 365 -- X : constant Some_Access_Type := Some_Expr'Reference; 366 -- (as is sometimes done in Exp_Util.Remove_Side_Effects). 367 368 ------------------ 369 -- Deref_Suffix -- 370 ------------------ 371 372 function Deref_Suffix return String is 373 Decl : Node_Id; 374 375 begin 376 if Hide_Temp_Derefs 377 and then Nkind (Prefix (Expr)) = N_Identifier 378 and then Nkind (Entity (Prefix (Expr))) = 379 N_Defining_Identifier 380 then 381 Decl := Parent (Entity (Prefix (Expr))); 382 383 if Present (Decl) 384 and then Nkind (Decl) = N_Object_Declaration 385 and then not Comes_From_Source (Decl) 386 and then Constant_Present (Decl) 387 and then Present (Sinfo.Expression (Decl)) 388 and then Nkind (Sinfo.Expression (Decl)) = 389 N_Reference 390 then 391 return ""; 392 end if; 393 end if; 394 395 -- The default case 396 397 return ".all"; 398 end Deref_Suffix; 399 400 -- Start of processing for Explicit_Dereference 401 402 begin 403 if Hide_Parameter_Blocks 404 and then Nkind (Prefix (Expr)) = N_Selected_Component 405 and then Present (Etype (Prefix (Expr))) 406 and then Is_Access_Type (Etype (Prefix (Expr))) 407 and then Is_Param_Block_Component_Type 408 (Etype (Prefix (Expr))) 409 then 410 -- Return "Foo" instead of "Parameter_Block.Foo.all" 411 412 return Expr_Name (Selector_Name (Prefix (Expr))); 413 414 elsif Take_Prefix then 415 return Expr_Name (Prefix (Expr)) & Deref_Suffix; 416 else 417 return Deref_Suffix; 418 end if; 419 end Explicit_Dereference; 420 421 when N_Expanded_Name 422 | N_Selected_Component 423 => 424 if Take_Prefix then 425 return 426 Expr_Name (Prefix (Expr)) & "." & 427 Expr_Name (Selector_Name (Expr)); 428 else 429 return "." & Expr_Name (Selector_Name (Expr)); 430 end if; 431 432 when N_Component_Association => 433 return "(" 434 & List_Name 435 (List => First (Choices (Expr)), 436 Add_Space => False, 437 Add_Paren => False) 438 & " => " & Expr_Name (Expression (Expr)) & ")"; 439 440 when N_If_Expression => 441 declare 442 N : constant Node_Id := First (Sinfo.Expressions (Expr)); 443 begin 444 return 445 "if " & Expr_Name (N) & " then " 446 & Expr_Name (Next (N)) & " else " 447 & Expr_Name (Next (Next (N))); 448 end; 449 450 when N_Qualified_Expression => 451 declare 452 Mark : constant String := 453 Expr_Name 454 (Subtype_Mark (Expr), Expand_Type => False); 455 Str : constant String := Expr_Name (Expression (Expr)); 456 begin 457 if Str (Str'First) = '(' and then Str (Str'Last) = ')' then 458 return Mark & "'" & Str; 459 else 460 return Mark & "'(" & Str & ")"; 461 end if; 462 end; 463 464 when N_Expression_With_Actions 465 | N_Unchecked_Expression 466 => 467 return Expr_Name (Expression (Expr)); 468 469 when N_Raise_Constraint_Error => 470 if Present (Condition (Expr)) then 471 return 472 "[constraint_error when " 473 & Expr_Name (Condition (Expr)) & "]"; 474 else 475 return "[constraint_error]"; 476 end if; 477 478 when N_Raise_Program_Error => 479 if Present (Condition (Expr)) then 480 return 481 "[program_error when " 482 & Expr_Name (Condition (Expr)) & "]"; 483 else 484 return "[program_error]"; 485 end if; 486 487 when N_Range => 488 return 489 Expr_Name (Low_Bound (Expr)) & ".." & 490 Expr_Name (High_Bound (Expr)); 491 492 when N_Slice => 493 return 494 Expr_Name (Prefix (Expr)) & " (" & 495 Expr_Name (Discrete_Range (Expr)) & ")"; 496 497 when N_And_Then => 498 return 499 Expr_Name (Left_Opnd (Expr)) & " and then " & 500 Expr_Name (Right_Opnd (Expr)); 501 502 when N_In => 503 return 504 Expr_Name (Left_Opnd (Expr)) & " in " & 505 Expr_Name (Right_Opnd (Expr)); 506 507 when N_Not_In => 508 return 509 Expr_Name (Left_Opnd (Expr)) & " not in " & 510 Expr_Name (Right_Opnd (Expr)); 511 512 when N_Or_Else => 513 return 514 Expr_Name (Left_Opnd (Expr)) & " or else " & 515 Expr_Name (Right_Opnd (Expr)); 516 517 when N_Op_And => 518 return 519 Expr_Name (Left_Opnd (Expr)) & " and " & 520 Expr_Name (Right_Opnd (Expr)); 521 522 when N_Op_Or => 523 return 524 Expr_Name (Left_Opnd (Expr)) & " or " & 525 Expr_Name (Right_Opnd (Expr)); 526 527 when N_Op_Xor => 528 return 529 Expr_Name (Left_Opnd (Expr)) & " xor " & 530 Expr_Name (Right_Opnd (Expr)); 531 532 when N_Op_Eq => 533 return 534 Expr_Name (Left_Opnd (Expr)) & " = " & 535 Expr_Name (Right_Opnd (Expr)); 536 537 when N_Op_Ne => 538 return 539 Expr_Name (Left_Opnd (Expr)) & " /= " & 540 Expr_Name (Right_Opnd (Expr)); 541 542 when N_Op_Lt => 543 return 544 Expr_Name (Left_Opnd (Expr)) & " < " & 545 Expr_Name (Right_Opnd (Expr)); 546 547 when N_Op_Le => 548 return 549 Expr_Name (Left_Opnd (Expr)) & " <= " & 550 Expr_Name (Right_Opnd (Expr)); 551 552 when N_Op_Gt => 553 return 554 Expr_Name (Left_Opnd (Expr)) & " > " & 555 Expr_Name (Right_Opnd (Expr)); 556 557 when N_Op_Ge => 558 return 559 Expr_Name (Left_Opnd (Expr)) & " >= " & 560 Expr_Name (Right_Opnd (Expr)); 561 562 when N_Op_Add => 563 return 564 Expr_Name (Left_Opnd (Expr)) & " + " & 565 Expr_Name (Right_Opnd (Expr)); 566 567 when N_Op_Subtract => 568 return 569 Expr_Name (Left_Opnd (Expr)) & " - " & 570 Expr_Name (Right_Opnd (Expr)); 571 572 when N_Op_Multiply => 573 return 574 Expr_Name (Left_Opnd (Expr)) & " * " & 575 Expr_Name (Right_Opnd (Expr)); 576 577 when N_Op_Divide => 578 return 579 Expr_Name (Left_Opnd (Expr)) & " / " & 580 Expr_Name (Right_Opnd (Expr)); 581 582 when N_Op_Mod => 583 return 584 Expr_Name (Left_Opnd (Expr)) & " mod " & 585 Expr_Name (Right_Opnd (Expr)); 586 587 when N_Op_Rem => 588 return 589 Expr_Name (Left_Opnd (Expr)) & " rem " & 590 Expr_Name (Right_Opnd (Expr)); 591 592 when N_Op_Expon => 593 return 594 Expr_Name (Left_Opnd (Expr)) & " ** " & 595 Expr_Name (Right_Opnd (Expr)); 596 597 when N_Op_Shift_Left => 598 return 599 Expr_Name (Left_Opnd (Expr)) & " << " & 600 Expr_Name (Right_Opnd (Expr)); 601 602 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic => 603 return 604 Expr_Name (Left_Opnd (Expr)) & " >> " & 605 Expr_Name (Right_Opnd (Expr)); 606 607 when N_Op_Concat => 608 return 609 Expr_Name (Left_Opnd (Expr)) & " & " & 610 Expr_Name (Right_Opnd (Expr)); 611 612 when N_Op_Plus => 613 return "+" & Expr_Name (Right_Opnd (Expr)); 614 615 when N_Op_Minus => 616 return "-" & Expr_Name (Right_Opnd (Expr)); 617 618 when N_Op_Abs => 619 return "abs " & Expr_Name (Right_Opnd (Expr)); 620 621 when N_Op_Not => 622 return "not (" & Expr_Name (Right_Opnd (Expr)) & ")"; 623 624 when N_Parameter_Association => 625 return Expr_Name (Explicit_Actual_Parameter (Expr)); 626 627 when N_Type_Conversion => 628 629 -- Most conversions are not very interesting (used inside 630 -- expanded checks to convert to larger ranges), so skip them. 631 632 return Expr_Name (Expression (Expr)); 633 634 when N_Unchecked_Type_Conversion => 635 636 -- Only keep the type conversion in complex cases 637 638 if not Is_Scalar_Type (Etype (Expr)) 639 or else not Is_Scalar_Type (Etype (Expression (Expr))) 640 or else Is_Modular_Integer_Type (Etype (Expr)) /= 641 Is_Modular_Integer_Type (Etype (Expression (Expr))) 642 then 643 return Expr_Name (Subtype_Mark (Expr)) & 644 "(" & Expr_Name (Expression (Expr)) & ")"; 645 else 646 return Expr_Name (Expression (Expr)); 647 end if; 648 649 when N_Indexed_Component => 650 if Take_Prefix then 651 return 652 Expr_Name (Prefix (Expr)) 653 & List_Name (First (Sinfo.Expressions (Expr))); 654 else 655 return List_Name (First (Sinfo.Expressions (Expr))); 656 end if; 657 658 when N_Function_Call => 659 660 -- If Default = "", it means we're expanding the name of 661 -- a gnat temporary (and not really a function call), so add 662 -- parentheses around function call to mark it specially. 663 664 if Default = "" then 665 return '(' 666 & Expr_Name (Name (Expr)) 667 & List_Name (First (Sinfo.Parameter_Associations (Expr))) 668 & ')'; 669 else 670 return 671 Expr_Name (Name (Expr)) 672 & List_Name 673 (First (Sinfo.Parameter_Associations (Expr))); 674 end if; 675 676 when N_Null => 677 return "null"; 678 679 when N_Others_Choice => 680 return "others"; 681 682 when others => 683 return "..."; 684 end case; 685 end Expr_Name; 686 687 -- Start of processing for Expression_Name 688 689 begin 690 if not From_Source then 691 declare 692 S : constant String := Expr_Name (Expr); 693 begin 694 if S = "..." then 695 return Default; 696 else 697 return S; 698 end if; 699 end; 700 end if; 701 702 -- Compute left (start) and right (end) slocs for the expression 703 -- Consider using Sinput.Sloc_Range instead, except that it does not 704 -- work properly currently??? 705 706 loop 707 case Nkind (Left) is 708 when N_And_Then 709 | N_Binary_Op 710 | N_Membership_Test 711 | N_Or_Else 712 => 713 Left := Original_Node (Left_Opnd (Left)); 714 715 when N_Attribute_Reference 716 | N_Expanded_Name 717 | N_Explicit_Dereference 718 | N_Indexed_Component 719 | N_Reference 720 | N_Selected_Component 721 | N_Slice 722 => 723 Left := Original_Node (Prefix (Left)); 724 725 when N_Defining_Program_Unit_Name 726 | N_Designator 727 | N_Function_Call 728 => 729 Left := Original_Node (Name (Left)); 730 731 when N_Range => 732 Left := Original_Node (Low_Bound (Left)); 733 734 when N_Qualified_Expression 735 | N_Type_Conversion 736 => 737 Left := Original_Node (Subtype_Mark (Left)); 738 739 -- For any other item, quit loop 740 741 when others => 742 exit; 743 end case; 744 end loop; 745 746 loop 747 case Nkind (Right) is 748 when N_And_Then 749 | N_Membership_Test 750 | N_Op 751 | N_Or_Else 752 => 753 Right := Original_Node (Right_Opnd (Right)); 754 755 when N_Expanded_Name 756 | N_Selected_Component 757 => 758 Right := Original_Node (Selector_Name (Right)); 759 760 when N_Qualified_Expression 761 | N_Type_Conversion 762 => 763 Right := Original_Node (Expression (Right)); 764 765 -- If argument does not already account for a closing 766 -- parenthesis, count one here. 767 768 if not Nkind_In (Right, N_Aggregate, 769 N_Quantified_Expression) 770 then 771 Append_Paren := Append_Paren + 1; 772 end if; 773 774 when N_Designator => 775 Right := Original_Node (Identifier (Right)); 776 777 when N_Defining_Program_Unit_Name => 778 Right := Original_Node (Defining_Identifier (Right)); 779 780 when N_Range => 781 Right := Original_Node (High_Bound (Right)); 782 783 when N_Parameter_Association => 784 Right := Original_Node (Explicit_Actual_Parameter (Right)); 785 786 when N_Component_Association => 787 if Present (Expression (Right)) then 788 Right := Expression (Right); 789 else 790 Right := Last (Choices (Right)); 791 end if; 792 793 when N_Indexed_Component => 794 Right := Original_Node (Last (Sinfo.Expressions (Right))); 795 Append_Paren := Append_Paren + 1; 796 797 when N_Function_Call => 798 if Present (Sinfo.Parameter_Associations (Right)) then 799 declare 800 Rover : Node_Id; 801 Found : Boolean; 802 803 begin 804 -- Avoid source position confusion associated with 805 -- parameters for which Comes_From_Source is False. 806 807 Rover := First (Sinfo.Parameter_Associations (Right)); 808 Found := False; 809 while Present (Rover) loop 810 if Comes_From_Source (Original_Node (Rover)) then 811 Right := Original_Node (Rover); 812 Found := True; 813 end if; 814 815 Next (Rover); 816 end loop; 817 818 if Found then 819 Append_Paren := Append_Paren + 1; 820 end if; 821 822 -- Quit loop if no Comes_From_Source parameters 823 824 exit when not Found; 825 end; 826 827 -- Quit loop if no parameters 828 829 else 830 exit; 831 end if; 832 833 when N_Quantified_Expression => 834 Right := Original_Node (Condition (Right)); 835 Append_Paren := Append_Paren + 1; 836 837 when N_Aggregate => 838 declare 839 Aggr : constant Node_Id := Right; 840 Sub : Node_Id; 841 842 begin 843 Sub := First (Expressions (Aggr)); 844 while Present (Sub) loop 845 if Sloc (Sub) > Sloc (Right) then 846 Right := Sub; 847 end if; 848 849 Next (Sub); 850 end loop; 851 852 Sub := First (Component_Associations (Aggr)); 853 while Present (Sub) loop 854 if Sloc (Sub) > Sloc (Right) then 855 Right := Sub; 856 end if; 857 858 Next (Sub); 859 end loop; 860 861 exit when Right = Aggr; 862 863 Append_Paren := Append_Paren + 1; 864 end; 865 866 -- For all other items, quit the loop 867 868 when others => 869 exit; 870 end case; 871 end loop; 872 873 declare 874 Scn : Source_Ptr := Original_Location (Sloc (Left)); 875 End_Sloc : constant Source_Ptr := 876 Original_Location (Sloc (Right)); 877 Src : constant Source_Buffer_Ptr := 878 Source_Text (Get_Source_File_Index (Scn)); 879 880 begin 881 if Scn > End_Sloc then 882 return Default; 883 end if; 884 885 declare 886 Threshold : constant := 256; 887 Buffer : String (1 .. Natural (End_Sloc - Scn)); 888 Index : Natural := 0; 889 Skipping_Comment : Boolean := False; 890 Underscore : Boolean := False; 891 892 begin 893 if Right /= Expr then 894 while Scn < End_Sloc loop 895 case Src (Scn) is 896 897 -- Give up on non ASCII characters 898 899 when Character'Val (128) .. Character'Last => 900 Append_Paren := 0; 901 Index := 0; 902 Right := Expr; 903 exit; 904 905 when ' ' 906 | ASCII.HT 907 => 908 if not Skipping_Comment and then not Underscore then 909 Underscore := True; 910 Index := Index + 1; 911 Buffer (Index) := ' '; 912 end if; 913 914 -- CR/LF/FF is the end of any comment 915 916 when ASCII.CR 917 | ASCII.FF 918 | ASCII.LF 919 => 920 Skipping_Comment := False; 921 922 when others => 923 Underscore := False; 924 925 if not Skipping_Comment then 926 927 -- Ignore comment 928 929 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then 930 Skipping_Comment := True; 931 932 else 933 Index := Index + 1; 934 Buffer (Index) := Src (Scn); 935 end if; 936 end if; 937 end case; 938 939 -- Give up on too long strings 940 941 if Index >= Threshold then 942 return Buffer (1 .. Index) & "..."; 943 end if; 944 945 Scn := Scn + 1; 946 end loop; 947 end if; 948 949 if Index < 1 then 950 declare 951 S : constant String := Expr_Name (Right); 952 begin 953 if S = "..." then 954 return Default; 955 else 956 return S; 957 end if; 958 end; 959 960 else 961 return 962 Buffer (1 .. Index) 963 & Expr_Name (Right, False) 964 & (1 .. Append_Paren => ')'); 965 end if; 966 end; 967 end; 968 end Expression_Image; 969 970end Pprint; 971