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-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Namet; use Namet; 29with Nlists; use Nlists; 30with Opt; use Opt; 31with Sinfo; use Sinfo; 32with Sinput; use Sinput; 33with Snames; use Snames; 34with Uintp; use Uintp; 35 36package body Pprint is 37 38 List_Name_Count : Integer := 0; 39 -- Counter used to prevent infinite recursion while computing name of 40 -- complex expressions. 41 42 ---------------------- 43 -- Expression_Image -- 44 ---------------------- 45 46 function Expression_Image 47 (Expr : Node_Id; 48 Default : String) return String 49 is 50 From_Source : constant Boolean := 51 Comes_From_Source (Expr) 52 and then not Opt.Debug_Generated_Code; 53 Append_Paren : Boolean := False; 54 Left : Node_Id := Original_Node (Expr); 55 Right : Node_Id := Original_Node (Expr); 56 57 function Expr_Name 58 (Expr : Node_Id; 59 Take_Prefix : Boolean := True; 60 Expand_Type : Boolean := True) return String; 61 -- Return string corresponding to Expr. If no string can be extracted, 62 -- return "...". If Take_Prefix is True, go back to prefix when needed, 63 -- otherwise only consider the right-hand side of an expression. If 64 -- Expand_Type is True and Expr is a type, try to expand Expr (an 65 -- internally generated type) into a user understandable name. 66 67 Max_List : constant := 3; 68 -- Limit number of list elements to dump 69 70 Max_Expr_Elements : constant := 24; 71 -- Limit number of elements in an expression for use by Expr_Name 72 73 Num_Elements : Natural := 0; 74 -- Current number of elements processed by Expr_Name 75 76 function List_Name 77 (List : Node_Id; 78 Add_Space : Boolean := True; 79 Add_Paren : Boolean := True) return String; 80 -- Return a string corresponding to List 81 82 --------------- 83 -- List_Name -- 84 --------------- 85 86 function List_Name 87 (List : Node_Id; 88 Add_Space : Boolean := True; 89 Add_Paren : Boolean := True) return String 90 is 91 function Internal_List_Name 92 (List : Node_Id; 93 First : Boolean := True; 94 Add_Space : Boolean := True; 95 Add_Paren : Boolean := True; 96 Num : Natural := 1) return String; 97 -- ??? what does this do 98 99 ------------------------ 100 -- Internal_List_Name -- 101 ------------------------ 102 103 function Internal_List_Name 104 (List : Node_Id; 105 First : Boolean := True; 106 Add_Space : Boolean := True; 107 Add_Paren : Boolean := True; 108 Num : Natural := 1) return String 109 is 110 function Prepend (S : String) return String; 111 -- ??? what does this do 112 113 ------------- 114 -- Prepend -- 115 ------------- 116 117 function Prepend (S : String) return String is 118 begin 119 if Add_Space then 120 if Add_Paren then 121 return " (" & S; 122 else 123 return ' ' & S; 124 end if; 125 elsif Add_Paren then 126 return '(' & S; 127 else 128 return S; 129 end if; 130 end Prepend; 131 132 -- Start of processing for Internal_List_Name 133 134 begin 135 if not Present (List) then 136 if First or else not Add_Paren then 137 return ""; 138 else 139 return ")"; 140 end if; 141 elsif Num > Max_List then 142 if Add_Paren then 143 return ", ...)"; 144 else 145 return ", ..."; 146 end if; 147 end if; 148 149 -- ??? the Internal_List_Name calls can be factored out 150 151 if First then 152 return Prepend (Expr_Name (List) 153 & Internal_List_Name 154 (List => Next (List), 155 First => False, 156 Add_Paren => Add_Paren, 157 Num => Num + 1)); 158 else 159 return ", " & Expr_Name (List) 160 & Internal_List_Name 161 (List => Next (List), 162 First => False, 163 Add_Paren => Add_Paren, 164 Num => Num + 1); 165 end if; 166 end Internal_List_Name; 167 168 -- Start of processing for List_Name 169 170 begin 171 -- Prevent infinite recursion by limiting depth to 3 172 173 if List_Name_Count > 3 then 174 return "..."; 175 end if; 176 177 List_Name_Count := List_Name_Count + 1; 178 179 declare 180 Result : constant String := 181 Internal_List_Name 182 (List => List, 183 Add_Space => Add_Space, 184 Add_Paren => Add_Paren); 185 begin 186 List_Name_Count := List_Name_Count - 1; 187 return Result; 188 end; 189 end List_Name; 190 191 --------------- 192 -- Expr_Name -- 193 --------------- 194 195 function Expr_Name 196 (Expr : Node_Id; 197 Take_Prefix : Boolean := True; 198 Expand_Type : Boolean := True) return String 199 is 200 begin 201 Num_Elements := Num_Elements + 1; 202 203 if Num_Elements > Max_Expr_Elements then 204 return "..."; 205 end if; 206 207 case Nkind (Expr) is 208 when N_Defining_Identifier | N_Identifier => 209 return Ident_Image (Expr, Expression_Image.Expr, Expand_Type); 210 211 when N_Character_Literal => 212 declare 213 Char : constant Int := 214 UI_To_Int (Char_Literal_Value (Expr)); 215 begin 216 if Char in 32 .. 127 then 217 return "'" & Character'Val (Char) & "'"; 218 else 219 UI_Image (Char_Literal_Value (Expr)); 220 return 221 "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'"; 222 end if; 223 end; 224 225 when N_Integer_Literal => 226 UI_Image (Intval (Expr)); 227 return UI_Image_Buffer (1 .. UI_Image_Length); 228 229 when N_Real_Literal => 230 return Real_Image (Realval (Expr)); 231 232 when N_String_Literal => 233 return String_Image (Strval (Expr)); 234 235 when N_Allocator => 236 return "new " & Expr_Name (Expression (Expr)); 237 238 when N_Aggregate => 239 if Present (Sinfo.Expressions (Expr)) then 240 return 241 List_Name 242 (List => First (Sinfo.Expressions (Expr)), 243 Add_Space => False); 244 245 -- Do not return empty string for (others => <>) aggregate 246 -- of a componentless record type. At least one caller (the 247 -- recursive call below in the N_Qualified_Expression case) 248 -- is not prepared to deal with a zero-length result. 249 250 elsif Null_Record_Present (Expr) 251 or else not Present (First (Component_Associations (Expr))) 252 then 253 return ("(null record)"); 254 255 else 256 return 257 List_Name 258 (List => First (Component_Associations (Expr)), 259 Add_Space => False, 260 Add_Paren => False); 261 end if; 262 263 when N_Extension_Aggregate => 264 return "(" & Expr_Name (Ancestor_Part (Expr)) & " with " 265 & List_Name 266 (List => First (Sinfo.Expressions (Expr)), 267 Add_Space => False, 268 Add_Paren => False) & ")"; 269 270 when N_Attribute_Reference => 271 if Take_Prefix then 272 declare 273 Id : constant Attribute_Id := 274 Get_Attribute_Id (Attribute_Name (Expr)); 275 Str : constant String := 276 Expr_Name (Prefix (Expr)) & "'" 277 & Get_Name_String (Attribute_Name (Expr)); 278 N : Node_Id; 279 Ranges : List_Id; 280 281 begin 282 if (Id = Attribute_First or else Id = Attribute_Last) 283 and then Str (Str'First) = '$' 284 then 285 N := Associated_Node_For_Itype (Etype (Prefix (Expr))); 286 287 if Present (N) then 288 if Nkind (N) = N_Full_Type_Declaration then 289 N := Type_Definition (N); 290 end if; 291 292 if Nkind (N) = N_Subtype_Declaration then 293 Ranges := 294 Constraints 295 (Constraint (Subtype_Indication (N))); 296 297 if List_Length (Ranges) = 1 298 and then 299 Nkind_In 300 (First (Ranges), 301 N_Range, 302 N_Real_Range_Specification, 303 N_Signed_Integer_Type_Definition) 304 then 305 if Id = Attribute_First then 306 return 307 Expression_Image 308 (Low_Bound (First (Ranges)), Str); 309 else 310 return 311 Expression_Image 312 (High_Bound (First (Ranges)), Str); 313 end if; 314 end if; 315 end if; 316 end if; 317 end if; 318 319 return Str; 320 end; 321 else 322 return "'" & Get_Name_String (Attribute_Name (Expr)); 323 end if; 324 325 when N_Explicit_Dereference => 326 327 -- Return "Foo" instead of "Parameter_Block.Foo.all" 328 329 if Hide_Parameter_Blocks 330 and then Nkind (Prefix (Expr)) = N_Selected_Component 331 and then Present (Etype (Prefix (Expr))) 332 and then Is_Access_Type (Etype (Prefix (Expr))) 333 and then Is_Param_Block_Component_Type (Etype (Prefix (Expr))) 334 then 335 return Expr_Name (Selector_Name (Prefix (Expr))); 336 337 elsif Take_Prefix then 338 return Expr_Name (Prefix (Expr)) & ".all"; 339 else 340 return ".all"; 341 end if; 342 343 when N_Expanded_Name | N_Selected_Component => 344 if Take_Prefix then 345 return 346 Expr_Name (Prefix (Expr)) & "." & 347 Expr_Name (Selector_Name (Expr)); 348 else 349 return "." & Expr_Name (Selector_Name (Expr)); 350 end if; 351 352 when N_Component_Association => 353 return "(" 354 & List_Name 355 (List => First (Choices (Expr)), 356 Add_Space => False, 357 Add_Paren => False) 358 & " => " & Expr_Name (Expression (Expr)) & ")"; 359 360 when N_If_Expression => 361 declare 362 N : constant Node_Id := First (Sinfo.Expressions (Expr)); 363 begin 364 return 365 "if " & Expr_Name (N) & " then " 366 & Expr_Name (Next (N)) & " else " 367 & Expr_Name (Next (Next (N))); 368 end; 369 370 when N_Qualified_Expression => 371 declare 372 Mark : constant String := 373 Expr_Name 374 (Subtype_Mark (Expr), Expand_Type => False); 375 Str : constant String := Expr_Name (Expression (Expr)); 376 begin 377 if Str (Str'First) = '(' and then Str (Str'Last) = ')' then 378 return Mark & "'" & Str; 379 else 380 return Mark & "'(" & Str & ")"; 381 end if; 382 end; 383 384 when N_Unchecked_Expression | N_Expression_With_Actions => 385 return Expr_Name (Expression (Expr)); 386 387 when N_Raise_Constraint_Error => 388 if Present (Condition (Expr)) then 389 return 390 "[constraint_error when " 391 & Expr_Name (Condition (Expr)) & "]"; 392 else 393 return "[constraint_error]"; 394 end if; 395 396 when N_Raise_Program_Error => 397 if Present (Condition (Expr)) then 398 return 399 "[program_error when " 400 & Expr_Name (Condition (Expr)) & "]"; 401 else 402 return "[program_error]"; 403 end if; 404 405 when N_Range => 406 return 407 Expr_Name (Low_Bound (Expr)) & ".." & 408 Expr_Name (High_Bound (Expr)); 409 410 when N_Slice => 411 return 412 Expr_Name (Prefix (Expr)) & " (" & 413 Expr_Name (Discrete_Range (Expr)) & ")"; 414 415 when N_And_Then => 416 return 417 Expr_Name (Left_Opnd (Expr)) & " and then " & 418 Expr_Name (Right_Opnd (Expr)); 419 420 when N_In => 421 return 422 Expr_Name (Left_Opnd (Expr)) & " in " & 423 Expr_Name (Right_Opnd (Expr)); 424 425 when N_Not_In => 426 return 427 Expr_Name (Left_Opnd (Expr)) & " not in " & 428 Expr_Name (Right_Opnd (Expr)); 429 430 when N_Or_Else => 431 return 432 Expr_Name (Left_Opnd (Expr)) & " or else " & 433 Expr_Name (Right_Opnd (Expr)); 434 435 when N_Op_And => 436 return 437 Expr_Name (Left_Opnd (Expr)) & " and " & 438 Expr_Name (Right_Opnd (Expr)); 439 440 when N_Op_Or => 441 return 442 Expr_Name (Left_Opnd (Expr)) & " or " & 443 Expr_Name (Right_Opnd (Expr)); 444 445 when N_Op_Xor => 446 return 447 Expr_Name (Left_Opnd (Expr)) & " xor " & 448 Expr_Name (Right_Opnd (Expr)); 449 450 when N_Op_Eq => 451 return 452 Expr_Name (Left_Opnd (Expr)) & " = " & 453 Expr_Name (Right_Opnd (Expr)); 454 455 when N_Op_Ne => 456 return 457 Expr_Name (Left_Opnd (Expr)) & " /= " & 458 Expr_Name (Right_Opnd (Expr)); 459 460 when N_Op_Lt => 461 return 462 Expr_Name (Left_Opnd (Expr)) & " < " & 463 Expr_Name (Right_Opnd (Expr)); 464 465 when N_Op_Le => 466 return 467 Expr_Name (Left_Opnd (Expr)) & " <= " & 468 Expr_Name (Right_Opnd (Expr)); 469 470 when N_Op_Gt => 471 return 472 Expr_Name (Left_Opnd (Expr)) & " > " & 473 Expr_Name (Right_Opnd (Expr)); 474 475 when N_Op_Ge => 476 return 477 Expr_Name (Left_Opnd (Expr)) & " >= " & 478 Expr_Name (Right_Opnd (Expr)); 479 480 when N_Op_Add => 481 return 482 Expr_Name (Left_Opnd (Expr)) & " + " & 483 Expr_Name (Right_Opnd (Expr)); 484 485 when N_Op_Subtract => 486 return 487 Expr_Name (Left_Opnd (Expr)) & " - " & 488 Expr_Name (Right_Opnd (Expr)); 489 490 when N_Op_Multiply => 491 return 492 Expr_Name (Left_Opnd (Expr)) & " * " & 493 Expr_Name (Right_Opnd (Expr)); 494 495 when N_Op_Divide => 496 return 497 Expr_Name (Left_Opnd (Expr)) & " / " & 498 Expr_Name (Right_Opnd (Expr)); 499 500 when N_Op_Mod => 501 return 502 Expr_Name (Left_Opnd (Expr)) & " mod " & 503 Expr_Name (Right_Opnd (Expr)); 504 505 when N_Op_Rem => 506 return 507 Expr_Name (Left_Opnd (Expr)) & " rem " & 508 Expr_Name (Right_Opnd (Expr)); 509 510 when N_Op_Expon => 511 return 512 Expr_Name (Left_Opnd (Expr)) & " ** " & 513 Expr_Name (Right_Opnd (Expr)); 514 515 when N_Op_Shift_Left => 516 return 517 Expr_Name (Left_Opnd (Expr)) & " << " & 518 Expr_Name (Right_Opnd (Expr)); 519 520 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic => 521 return 522 Expr_Name (Left_Opnd (Expr)) & " >> " & 523 Expr_Name (Right_Opnd (Expr)); 524 525 when N_Op_Concat => 526 return 527 Expr_Name (Left_Opnd (Expr)) & " & " & 528 Expr_Name (Right_Opnd (Expr)); 529 530 when N_Op_Plus => 531 return "+" & Expr_Name (Right_Opnd (Expr)); 532 533 when N_Op_Minus => 534 return "-" & Expr_Name (Right_Opnd (Expr)); 535 536 when N_Op_Abs => 537 return "abs " & Expr_Name (Right_Opnd (Expr)); 538 539 when N_Op_Not => 540 return "not (" & Expr_Name (Right_Opnd (Expr)) & ")"; 541 542 when N_Parameter_Association => 543 return Expr_Name (Explicit_Actual_Parameter (Expr)); 544 545 when N_Type_Conversion | N_Unchecked_Type_Conversion => 546 547 -- Most conversions are not very interesting (used inside 548 -- expanded checks to convert to larger ranges), so skip them. 549 550 return Expr_Name (Expression (Expr)); 551 552 when N_Indexed_Component => 553 if Take_Prefix then 554 return 555 Expr_Name (Prefix (Expr)) 556 & List_Name (First (Sinfo.Expressions (Expr))); 557 else 558 return List_Name (First (Sinfo.Expressions (Expr))); 559 end if; 560 561 when N_Function_Call => 562 563 -- If Default = "", it means we're expanding the name of 564 -- a gnat temporary (and not really a function call), so add 565 -- parentheses around function call to mark it specially. 566 567 if Default = "" then 568 return '(' 569 & Expr_Name (Name (Expr)) 570 & List_Name (First (Sinfo.Parameter_Associations (Expr))) 571 & ')'; 572 else 573 return 574 Expr_Name (Name (Expr)) 575 & List_Name 576 (First (Sinfo.Parameter_Associations (Expr))); 577 end if; 578 579 when N_Null => 580 return "null"; 581 582 when N_Others_Choice => 583 return "others"; 584 585 when others => 586 return "..."; 587 end case; 588 end Expr_Name; 589 590 -- Start of processing for Expression_Name 591 592 begin 593 if not From_Source then 594 declare 595 S : constant String := Expr_Name (Expr); 596 begin 597 if S = "..." then 598 return Default; 599 else 600 return S; 601 end if; 602 end; 603 end if; 604 605 -- Compute left (start) and right (end) slocs for the expression 606 -- Consider using Sinput.Sloc_Range instead, except that it does not 607 -- work properly currently??? 608 609 loop 610 case Nkind (Left) is 611 when N_And_Then | 612 N_Binary_Op | 613 N_Membership_Test | 614 N_Or_Else => 615 Left := Original_Node (Left_Opnd (Left)); 616 617 when N_Attribute_Reference | 618 N_Expanded_Name | 619 N_Explicit_Dereference | 620 N_Indexed_Component | 621 N_Reference | 622 N_Selected_Component | 623 N_Slice => 624 Left := Original_Node (Prefix (Left)); 625 626 when N_Defining_Program_Unit_Name | 627 N_Designator | 628 N_Function_Call => 629 Left := Original_Node (Name (Left)); 630 631 when N_Range => 632 Left := Original_Node (Low_Bound (Left)); 633 634 when N_Type_Conversion => 635 Left := Original_Node (Subtype_Mark (Left)); 636 637 -- For any other item, quit loop 638 639 when others => 640 exit; 641 end case; 642 end loop; 643 644 loop 645 case Nkind (Right) is 646 when N_And_Then | 647 N_Membership_Test | 648 N_Op | 649 N_Or_Else => 650 Right := Original_Node (Right_Opnd (Right)); 651 652 when N_Expanded_Name | 653 N_Selected_Component => 654 Right := Original_Node (Selector_Name (Right)); 655 656 when N_Designator => 657 Right := Original_Node (Identifier (Right)); 658 659 when N_Defining_Program_Unit_Name => 660 Right := Original_Node (Defining_Identifier (Right)); 661 662 when N_Range => 663 Right := Original_Node (High_Bound (Right)); 664 665 when N_Parameter_Association => 666 Right := Original_Node (Explicit_Actual_Parameter (Right)); 667 668 when N_Indexed_Component => 669 Right := Original_Node (Last (Sinfo.Expressions (Right))); 670 Append_Paren := True; 671 672 when N_Function_Call => 673 if Present (Sinfo.Parameter_Associations (Right)) then 674 declare 675 Rover : Node_Id; 676 Found : Boolean; 677 678 begin 679 -- Avoid source position confusion associated with 680 -- parameters for which Comes_From_Source is False. 681 682 Rover := First (Sinfo.Parameter_Associations (Right)); 683 Found := False; 684 while Present (Rover) loop 685 if Comes_From_Source (Original_Node (Rover)) then 686 Right := Original_Node (Rover); 687 Append_Paren := True; 688 Found := True; 689 end if; 690 691 Next (Rover); 692 end loop; 693 694 -- Quit loop if no Comes_From_Source parameters 695 696 exit when not Found; 697 end; 698 699 -- Quit loop if no parameters 700 701 else 702 exit; 703 end if; 704 705 when N_Quantified_Expression => 706 Right := Original_Node (Condition (Right)); 707 708 -- For all other items, quit the loop 709 710 when others => 711 exit; 712 end case; 713 end loop; 714 715 declare 716 Scn : Source_Ptr := Original_Location (Sloc (Left)); 717 End_Sloc : constant Source_Ptr := 718 Original_Location (Sloc (Right)); 719 Src : constant Source_Buffer_Ptr := 720 Source_Text (Get_Source_File_Index (Scn)); 721 722 begin 723 if Scn > End_Sloc then 724 return Default; 725 end if; 726 727 declare 728 Buffer : String (1 .. Natural (End_Sloc - Scn)); 729 Index : Natural := 0; 730 Skipping_Comment : Boolean := False; 731 Underscore : Boolean := False; 732 733 begin 734 if Right /= Expr then 735 while Scn < End_Sloc loop 736 case Src (Scn) is 737 when ' ' | ASCII.HT => 738 if not Skipping_Comment and then not Underscore then 739 Underscore := True; 740 Index := Index + 1; 741 Buffer (Index) := ' '; 742 end if; 743 744 -- CR/LF/FF is the end of any comment 745 746 when ASCII.LF | ASCII.CR | ASCII.FF => 747 Skipping_Comment := False; 748 749 when others => 750 Underscore := False; 751 752 if not Skipping_Comment then 753 754 -- Ignore comment 755 756 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then 757 Skipping_Comment := True; 758 759 else 760 Index := Index + 1; 761 Buffer (Index) := Src (Scn); 762 end if; 763 end if; 764 end case; 765 766 Scn := Scn + 1; 767 end loop; 768 end if; 769 770 if Index < 1 then 771 declare 772 S : constant String := Expr_Name (Right); 773 begin 774 if S = "..." then 775 return Default; 776 else 777 return S; 778 end if; 779 end; 780 781 elsif Append_Paren then 782 return Buffer (1 .. Index) & Expr_Name (Right, False) & ')'; 783 784 else 785 return Buffer (1 .. Index) & Expr_Name (Right, False); 786 end if; 787 end; 788 end; 789 end Expression_Image; 790 791end Pprint; 792