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-2012, 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 (Expr : Node_Id; Default : String) 47 return String is 48 Left : Node_Id := Original_Node (Expr); 49 Right : Node_Id := Original_Node (Expr); 50 From_Source : constant Boolean := 51 Comes_From_Source (Expr) and then not Opt.Debug_Generated_Code; 52 Append_Paren : Boolean := False; 53 54 function Expr_Name 55 (Expr : Node_Id; 56 Take_Prefix : Boolean := True; 57 Expand_Type : Boolean := True) return String; 58 -- Return string corresponding to Expr. If no string can be extracted, 59 -- return "...". If Take_Prefix is True, go back to prefix when needed, 60 -- otherwise only consider the right-hand side of an expression. If 61 -- Expand_Type is True and Expr is a type, try to expand Expr (an 62 -- internally generated type) into a user understandable name. 63 64 Max_List : constant := 3; 65 -- Limit number of list elements to dump 66 67 Max_Expr_Elements : constant := 24; 68 -- Limit number of elements in an expression for use by Expr_Name 69 70 Num_Elements : Natural := 0; 71 -- Current number of elements processed by Expr_Name 72 73 function List_Name 74 (List : Node_Id; 75 Add_Space : Boolean := True; 76 Add_Paren : Boolean := True) return String; 77 -- Return a string corresponding to List 78 79 function List_Name 80 (List : Node_Id; 81 Add_Space : Boolean := True; 82 Add_Paren : Boolean := True) return String 83 is 84 function Internal_List_Name 85 (List : Node_Id; 86 First : Boolean := True; 87 Add_Space : Boolean := True; 88 Add_Paren : Boolean := True; 89 Num : Natural := 1) return String; 90 91 ------------------------ 92 -- Internal_List_Name -- 93 ------------------------ 94 95 function Internal_List_Name 96 (List : Node_Id; 97 First : Boolean := True; 98 Add_Space : Boolean := True; 99 Add_Paren : Boolean := True; 100 Num : Natural := 1) return String 101 is 102 function Prepend (S : String) return String; 103 104 ------------- 105 -- Prepend -- 106 ------------- 107 108 function Prepend (S : String) return String is 109 begin 110 if Add_Space then 111 if Add_Paren then 112 return " (" & S; 113 else 114 return ' ' & S; 115 end if; 116 elsif Add_Paren then 117 return '(' & S; 118 else 119 return S; 120 end if; 121 end Prepend; 122 123 -- Start of processing for Internal_List_Name 124 125 begin 126 if not Present (List) then 127 if First or else not Add_Paren then 128 return ""; 129 else 130 return ")"; 131 end if; 132 elsif Num > Max_List then 133 if Add_Paren then 134 return ", ...)"; 135 else 136 return ", ..."; 137 end if; 138 end if; 139 140 if First then 141 return Prepend 142 (Expr_Name (List) 143 & Internal_List_Name (Next (List), 144 First => False, 145 Add_Paren => Add_Paren, 146 Num => Num + 1)); 147 else 148 return ", " & Expr_Name (List) & 149 Internal_List_Name 150 (Next (List), 151 First => False, 152 Add_Paren => Add_Paren, 153 Num => Num + 1); 154 end if; 155 end Internal_List_Name; 156 157 -- Start of processing for List_Name 158 159 begin 160 -- Prevent infinite recursion by limiting depth to 3 161 162 if List_Name_Count > 3 then 163 return "..."; 164 end if; 165 166 List_Name_Count := List_Name_Count + 1; 167 declare 168 Result : constant String := 169 Internal_List_Name 170 (List, Add_Space => Add_Space, Add_Paren => Add_Paren); 171 begin 172 List_Name_Count := List_Name_Count - 1; 173 return Result; 174 end; 175 end List_Name; 176 177 --------------- 178 -- Expr_Name -- 179 --------------- 180 181 function Expr_Name 182 (Expr : Node_Id; 183 Take_Prefix : Boolean := True; 184 Expand_Type : Boolean := True) return String 185 is 186 begin 187 Num_Elements := Num_Elements + 1; 188 189 if Num_Elements > Max_Expr_Elements then 190 return "..."; 191 end if; 192 193 case Nkind (Expr) is 194 when N_Defining_Identifier | N_Identifier => 195 return Ident_Image (Expr, Expression_Image.Expr, Expand_Type); 196 197 when N_Character_Literal => 198 declare 199 Char : constant Int := 200 UI_To_Int (Char_Literal_Value (Expr)); 201 begin 202 if Char in 32 .. 127 then 203 return "'" & Character'Val (Char) & "'"; 204 else 205 UI_Image (Char_Literal_Value (Expr)); 206 return "'\" & UI_Image_Buffer (1 .. UI_Image_Length) 207 & "'"; 208 end if; 209 end; 210 211 when N_Integer_Literal => 212 UI_Image (Intval (Expr)); 213 return UI_Image_Buffer (1 .. UI_Image_Length); 214 215 when N_Real_Literal => 216 return Real_Image (Realval (Expr)); 217 218 when N_String_Literal => 219 return String_Image (Strval (Expr)); 220 221 when N_Allocator => 222 return "new " & Expr_Name (Expression (Expr)); 223 224 when N_Aggregate => 225 if Present (Sinfo.Expressions (Expr)) then 226 return List_Name 227 (First (Sinfo.Expressions (Expr)), Add_Space => False); 228 229 elsif Null_Record_Present (Expr) then 230 return ("(null record)"); 231 232 else 233 return List_Name 234 (First (Component_Associations (Expr)), 235 Add_Space => False, Add_Paren => False); 236 end if; 237 238 when N_Extension_Aggregate => 239 return "(" & Expr_Name (Ancestor_Part (Expr)) & 240 " with " & 241 List_Name (First (Sinfo.Expressions (Expr)), 242 Add_Space => False, Add_Paren => False) & 243 ")"; 244 245 when N_Attribute_Reference => 246 if Take_Prefix then 247 declare 248 Str : constant String := Expr_Name (Prefix (Expr)) 249 & "'" & Get_Name_String (Attribute_Name (Expr)); 250 Id : constant Attribute_Id := 251 Get_Attribute_Id (Attribute_Name (Expr)); 252 Ranges : List_Id; 253 N : Node_Id; 254 255 begin 256 if (Id = Attribute_First or else Id = Attribute_Last) 257 and then Str (Str'First) = '$' 258 then 259 N := Associated_Node_For_Itype (Etype (Prefix (Expr))); 260 261 if Present (N) then 262 if Nkind (N) = N_Full_Type_Declaration then 263 N := Type_Definition (N); 264 end if; 265 266 if Nkind (N) = N_Subtype_Declaration then 267 Ranges := Constraints (Constraint 268 (Subtype_Indication (N))); 269 270 if List_Length (Ranges) = 1 271 and then Nkind_In 272 (First (Ranges), 273 N_Range, 274 N_Real_Range_Specification, 275 N_Signed_Integer_Type_Definition) 276 then 277 if Id = Attribute_First then 278 return Expression_Image 279 (Low_Bound (First (Ranges)), Str); 280 else 281 return Expression_Image 282 (High_Bound (First (Ranges)), Str); 283 end if; 284 end if; 285 end if; 286 end if; 287 end if; 288 289 return Str; 290 end; 291 else 292 return "'" & Get_Name_String (Attribute_Name (Expr)); 293 end if; 294 295 when N_Explicit_Dereference => 296 if Take_Prefix then 297 return Expr_Name (Prefix (Expr)) & ".all"; 298 else 299 return ".all"; 300 end if; 301 302 when N_Expanded_Name | N_Selected_Component => 303 if Take_Prefix then 304 return Expr_Name (Prefix (Expr)) 305 & "." & Expr_Name (Selector_Name (Expr)); 306 else 307 return "." & Expr_Name (Selector_Name (Expr)); 308 end if; 309 310 when N_Component_Association => 311 return "(" 312 & List_Name (First (Choices (Expr)), 313 Add_Space => False, Add_Paren => False) 314 & " => " & Expr_Name (Expression (Expr)) & ")"; 315 316 when N_If_Expression => 317 declare 318 N : constant Node_Id := First (Sinfo.Expressions (Expr)); 319 begin 320 return "if " & Expr_Name (N) & " then " & 321 Expr_Name (Next (N)) & " else " & 322 Expr_Name (Next (Next (N))); 323 end; 324 325 when N_Qualified_Expression => 326 declare 327 Mark : constant String := 328 Expr_Name (Subtype_Mark (Expr), Expand_Type => False); 329 Str : constant String := Expr_Name (Expression (Expr)); 330 begin 331 if Str (Str'First) = '(' and then Str (Str'Last) = ')' then 332 return Mark & "'" & Str; 333 else 334 return Mark & "'(" & Str & ")"; 335 end if; 336 end; 337 338 when N_Unchecked_Expression | N_Expression_With_Actions => 339 return Expr_Name (Expression (Expr)); 340 341 when N_Raise_Constraint_Error => 342 if Present (Condition (Expr)) then 343 return "[constraint_error when " & 344 Expr_Name (Condition (Expr)) & "]"; 345 else 346 return "[constraint_error]"; 347 end if; 348 349 when N_Raise_Program_Error => 350 if Present (Condition (Expr)) then 351 return "[program_error when " & 352 Expr_Name (Condition (Expr)) & "]"; 353 else 354 return "[program_error]"; 355 end if; 356 357 when N_Range => 358 return Expr_Name (Low_Bound (Expr)) & ".." & 359 Expr_Name (High_Bound (Expr)); 360 361 when N_Slice => 362 return Expr_Name (Prefix (Expr)) & " (" & 363 Expr_Name (Discrete_Range (Expr)) & ")"; 364 365 when N_And_Then => 366 return Expr_Name (Left_Opnd (Expr)) & " and then " & 367 Expr_Name (Right_Opnd (Expr)); 368 369 when N_In => 370 return Expr_Name (Left_Opnd (Expr)) & " in " & 371 Expr_Name (Right_Opnd (Expr)); 372 373 when N_Not_In => 374 return Expr_Name (Left_Opnd (Expr)) & " not in " & 375 Expr_Name (Right_Opnd (Expr)); 376 377 when N_Or_Else => 378 return Expr_Name (Left_Opnd (Expr)) & " or else " & 379 Expr_Name (Right_Opnd (Expr)); 380 381 when N_Op_And => 382 return Expr_Name (Left_Opnd (Expr)) & " and " & 383 Expr_Name (Right_Opnd (Expr)); 384 385 when N_Op_Or => 386 return Expr_Name (Left_Opnd (Expr)) & " or " & 387 Expr_Name (Right_Opnd (Expr)); 388 389 when N_Op_Xor => 390 return Expr_Name (Left_Opnd (Expr)) & " xor " & 391 Expr_Name (Right_Opnd (Expr)); 392 393 when N_Op_Eq => 394 return Expr_Name (Left_Opnd (Expr)) & " = " & 395 Expr_Name (Right_Opnd (Expr)); 396 397 when N_Op_Ne => 398 return Expr_Name (Left_Opnd (Expr)) & " /= " & 399 Expr_Name (Right_Opnd (Expr)); 400 401 when N_Op_Lt => 402 return Expr_Name (Left_Opnd (Expr)) & " < " & 403 Expr_Name (Right_Opnd (Expr)); 404 405 when N_Op_Le => 406 return Expr_Name (Left_Opnd (Expr)) & " <= " & 407 Expr_Name (Right_Opnd (Expr)); 408 409 when N_Op_Gt => 410 return Expr_Name (Left_Opnd (Expr)) & " > " & 411 Expr_Name (Right_Opnd (Expr)); 412 413 when N_Op_Ge => 414 return Expr_Name (Left_Opnd (Expr)) & " >= " & 415 Expr_Name (Right_Opnd (Expr)); 416 417 when N_Op_Add => 418 return Expr_Name (Left_Opnd (Expr)) & " + " & 419 Expr_Name (Right_Opnd (Expr)); 420 421 when N_Op_Subtract => 422 return Expr_Name (Left_Opnd (Expr)) & " - " & 423 Expr_Name (Right_Opnd (Expr)); 424 425 when N_Op_Multiply => 426 return Expr_Name (Left_Opnd (Expr)) & " * " & 427 Expr_Name (Right_Opnd (Expr)); 428 429 when N_Op_Divide => 430 return Expr_Name (Left_Opnd (Expr)) & " / " & 431 Expr_Name (Right_Opnd (Expr)); 432 433 when N_Op_Mod => 434 return Expr_Name (Left_Opnd (Expr)) & " mod " & 435 Expr_Name (Right_Opnd (Expr)); 436 437 when N_Op_Rem => 438 return Expr_Name (Left_Opnd (Expr)) & " rem " & 439 Expr_Name (Right_Opnd (Expr)); 440 441 when N_Op_Expon => 442 return Expr_Name (Left_Opnd (Expr)) & " ** " & 443 Expr_Name (Right_Opnd (Expr)); 444 445 when N_Op_Shift_Left => 446 return Expr_Name (Left_Opnd (Expr)) & " << " & 447 Expr_Name (Right_Opnd (Expr)); 448 449 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic => 450 return Expr_Name (Left_Opnd (Expr)) & " >> " & 451 Expr_Name (Right_Opnd (Expr)); 452 453 when N_Op_Concat => 454 return Expr_Name (Left_Opnd (Expr)) & " & " & 455 Expr_Name (Right_Opnd (Expr)); 456 457 when N_Op_Plus => 458 return "+" & Expr_Name (Right_Opnd (Expr)); 459 460 when N_Op_Minus => 461 return "-" & Expr_Name (Right_Opnd (Expr)); 462 463 when N_Op_Abs => 464 return "abs " & Expr_Name (Right_Opnd (Expr)); 465 466 when N_Op_Not => 467 return "not (" & Expr_Name (Right_Opnd (Expr)) & ")"; 468 469 when N_Parameter_Association => 470 return Expr_Name (Explicit_Actual_Parameter (Expr)); 471 472 when N_Type_Conversion | N_Unchecked_Type_Conversion => 473 474 -- Most conversions are not very interesting (used inside 475 -- expanded checks to convert to larger ranges), so skip them. 476 477 return Expr_Name (Expression (Expr)); 478 479 when N_Indexed_Component => 480 if Take_Prefix then 481 return Expr_Name (Prefix (Expr)) & 482 List_Name (First (Sinfo.Expressions (Expr))); 483 else 484 return List_Name (First (Sinfo.Expressions (Expr))); 485 end if; 486 487 when N_Function_Call => 488 489 -- If Default = "", it means we're expanding the name of 490 -- a gnat temporary (and not really a function call), so add 491 -- parentheses around function call to mark it specially. 492 493 if Default = "" then 494 return '(' & Expr_Name (Name (Expr)) & 495 List_Name (First (Sinfo.Parameter_Associations (Expr))) & 496 ')'; 497 else 498 return Expr_Name (Name (Expr)) & 499 List_Name (First (Sinfo.Parameter_Associations (Expr))); 500 end if; 501 502 when N_Null => 503 return "null"; 504 505 when N_Others_Choice => 506 return "others"; 507 508 when others => 509 return "..."; 510 end case; 511 end Expr_Name; 512 513 -- Start of processing for Expression_Name 514 515 begin 516 if not From_Source then 517 declare 518 S : constant String := Expr_Name (Expr); 519 begin 520 if S = "..." then 521 return Default; 522 else 523 return S; 524 end if; 525 end; 526 end if; 527 528 -- Compute left (start) and right (end) slocs for the expression 529 -- Consider using Sinput.Sloc_Range instead, except that it does not 530 -- work properly currently??? 531 532 loop 533 case Nkind (Left) is 534 when N_Binary_Op | N_Membership_Test | 535 N_And_Then | N_Or_Else => 536 Left := Original_Node (Left_Opnd (Left)); 537 538 when N_Attribute_Reference | N_Expanded_Name | 539 N_Explicit_Dereference | N_Indexed_Component | 540 N_Reference | N_Selected_Component | 541 N_Slice => 542 Left := Original_Node (Prefix (Left)); 543 544 when N_Designator | N_Defining_Program_Unit_Name | 545 N_Function_Call => 546 Left := Original_Node (Name (Left)); 547 548 when N_Range => 549 Left := Original_Node (Low_Bound (Left)); 550 551 when N_Type_Conversion => 552 Left := Original_Node (Subtype_Mark (Left)); 553 554 -- For any other item, quit loop 555 556 when others => 557 exit; 558 end case; 559 end loop; 560 561 loop 562 case Nkind (Right) is 563 when N_Op | N_Membership_Test | 564 N_And_Then | N_Or_Else => 565 Right := Original_Node (Right_Opnd (Right)); 566 567 when N_Selected_Component | N_Expanded_Name => 568 Right := Original_Node (Selector_Name (Right)); 569 570 when N_Designator => 571 Right := Original_Node (Identifier (Right)); 572 573 when N_Defining_Program_Unit_Name => 574 Right := Original_Node (Defining_Identifier (Right)); 575 576 when N_Range => 577 Right := Original_Node (High_Bound (Right)); 578 579 when N_Parameter_Association => 580 Right := Original_Node (Explicit_Actual_Parameter (Right)); 581 582 when N_Indexed_Component => 583 Right := Original_Node (Last (Sinfo.Expressions (Right))); 584 Append_Paren := True; 585 586 when N_Function_Call => 587 if Present (Sinfo.Parameter_Associations (Right)) then 588 Right := 589 Original_Node 590 (Last (Sinfo.Parameter_Associations (Right))); 591 Append_Paren := True; 592 593 -- Quit loop if no named associations 594 595 else 596 exit; 597 end if; 598 599 -- For all other items, quit the loop 600 601 when others => 602 exit; 603 end case; 604 end loop; 605 606 declare 607 Scn : Source_Ptr := Original_Location (Sloc (Left)); 608 Src : constant Source_Buffer_Ptr := 609 Source_Text (Get_Source_File_Index (Scn)); 610 End_Sloc : constant Source_Ptr := 611 Original_Location (Sloc (Right)); 612 613 begin 614 if Scn > End_Sloc then 615 return Default; 616 end if; 617 618 declare 619 Buffer : String (1 .. Natural (End_Sloc - Scn)); 620 Skipping_Comment : Boolean := False; 621 Underscore : Boolean := False; 622 Index : Natural := 0; 623 624 begin 625 if Right /= Expr then 626 while Scn < End_Sloc loop 627 case Src (Scn) is 628 when ' ' | ASCII.HT => 629 if not Skipping_Comment and then not Underscore then 630 Underscore := True; 631 Index := Index + 1; 632 Buffer (Index) := ' '; 633 end if; 634 635 -- CR/LF/FF is the end of any comment 636 637 when ASCII.LF | ASCII.CR | ASCII.FF => 638 Skipping_Comment := False; 639 640 when others => 641 Underscore := False; 642 643 if not Skipping_Comment then 644 645 -- Ignore comment 646 647 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then 648 Skipping_Comment := True; 649 650 else 651 Index := Index + 1; 652 Buffer (Index) := Src (Scn); 653 end if; 654 end if; 655 end case; 656 657 Scn := Scn + 1; 658 end loop; 659 end if; 660 661 if Index < 1 then 662 declare 663 S : constant String := Expr_Name (Right); 664 begin 665 if S = "..." then 666 return Default; 667 else 668 return S; 669 end if; 670 end; 671 672 elsif Append_Paren then 673 return Buffer (1 .. Index) & Expr_Name (Right, False) & ')'; 674 675 else 676 return Buffer (1 .. Index) & Expr_Name (Right, False); 677 end if; 678 end; 679 end; 680 end Expression_Image; 681 682end Pprint; 683