gcc/ada/pprint.adb

   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-2014, 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
  26 with Atree;   use Atree;
  27 with Einfo;   use Einfo;
  28 with Namet;   use Namet;
  29 with Nlists;  use Nlists;
  30 with Opt;     use Opt;
  31 with Sinfo;   use Sinfo;
  32 with Sinput;  use Sinput;
  33 with Snames;  use Snames;
  34 with Uintp;   use Uintp;
  35
  36 package 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                --  Do not return empty string for (others => <>) aggregate
 230                --  of a componentless record type. At least one caller (the
 231                --  recursive call below in the N_Qualified_Expression case)
 232                --  is not prepared to deal with a zero-length result.
 233
 234                elsif Null_Record_Present (Expr)
 235                  or else not Present (First (Component_Associations (Expr)))
 236                then
 237                   return ("(null record)");
 238
 239                else
 240                   return List_Name
 241                     (First (Component_Associations (Expr)),
 242                      Add_Space => False, Add_Paren => False);
 243                end if;
 244
 245             when N_Extension_Aggregate =>
 246                return "(" & Expr_Name (Ancestor_Part (Expr)) &
 247                  " with " &
 248                  List_Name (First (Sinfo.Expressions (Expr)),
 249                             Add_Space => False, Add_Paren => False) &
 250                  ")";
 251
 252             when N_Attribute_Reference =>
 253                if Take_Prefix then
 254                   declare
 255                      Str    : constant String := Expr_Name (Prefix (Expr))
 256                        & "'" & Get_Name_String (Attribute_Name (Expr));
 257                      Id     : constant Attribute_Id :=
 258                        Get_Attribute_Id (Attribute_Name (Expr));
 259                      Ranges : List_Id;
 260                      N      : Node_Id;
 261
 262                   begin
 263                      if (Id = Attribute_First or else Id = Attribute_Last)
 264                        and then Str (Str'First) = '$'
 265                      then
 266                         N := Associated_Node_For_Itype (Etype (Prefix (Expr)));
 267
 268                         if Present (N) then
 269                            if Nkind (N) = N_Full_Type_Declaration then
 270                               N := Type_Definition (N);
 271                            end if;
 272
 273                            if Nkind (N) = N_Subtype_Declaration then
 274                               Ranges := Constraints (Constraint
 275                                                      (Subtype_Indication (N)));
 276
 277                               if List_Length (Ranges) = 1
 278                                 and then Nkind_In
 279                                   (First (Ranges),
 280                                    N_Range,
 281                                    N_Real_Range_Specification,
 282                                    N_Signed_Integer_Type_Definition)
 283                               then
 284                                  if Id = Attribute_First then
 285                                     return Expression_Image
 286                                       (Low_Bound (First (Ranges)), Str);
 287                                  else
 288                                     return Expression_Image
 289                                       (High_Bound (First (Ranges)), Str);
 290                                  end if;
 291                               end if;
 292                            end if;
 293                         end if;
 294                      end if;
 295
 296                      return Str;
 297                   end;
 298                else
 299                   return "'" & Get_Name_String (Attribute_Name (Expr));
 300                end if;
 301
 302             when N_Explicit_Dereference =>
 303                if Take_Prefix then
 304                   return Expr_Name (Prefix (Expr)) & ".all";
 305                else
 306                   return ".all";
 307                end if;
 308
 309             when N_Expanded_Name | N_Selected_Component =>
 310                if Take_Prefix then
 311                   return Expr_Name (Prefix (Expr))
 312                     & "." & Expr_Name (Selector_Name (Expr));
 313                else
 314                   return "." & Expr_Name (Selector_Name (Expr));
 315                end if;
 316
 317             when N_Component_Association =>
 318                return "("
 319                  & List_Name (First (Choices (Expr)),
 320                               Add_Space => False, Add_Paren => False)
 321                  & " => " & Expr_Name (Expression (Expr)) & ")";
 322
 323             when N_If_Expression =>
 324                declare
 325                   N : constant Node_Id := First (Sinfo.Expressions (Expr));
 326                begin
 327                   return "if " & Expr_Name (N) & " then " &
 328                     Expr_Name (Next (N)) & " else " &
 329                     Expr_Name (Next (Next (N)));
 330                end;
 331
 332             when N_Qualified_Expression =>
 333                declare
 334                   Mark : constant String :=
 335                     Expr_Name (Subtype_Mark (Expr), Expand_Type => False);
 336                   Str  : constant String := Expr_Name (Expression (Expr));
 337                begin
 338                   if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
 339                      return Mark & "'" & Str;
 340                   else
 341                      return Mark & "'(" & Str & ")";
 342                   end if;
 343                end;
 344
 345             when N_Unchecked_Expression | N_Expression_With_Actions =>
 346                return Expr_Name (Expression (Expr));
 347
 348             when N_Raise_Constraint_Error =>
 349                if Present (Condition (Expr)) then
 350                   return "[constraint_error when " &
 351                     Expr_Name (Condition (Expr)) & "]";
 352                else
 353                   return "[constraint_error]";
 354                end if;
 355
 356             when N_Raise_Program_Error =>
 357                if Present (Condition (Expr)) then
 358                   return "[program_error when " &
 359                     Expr_Name (Condition (Expr)) & "]";
 360                else
 361                   return "[program_error]";
 362                end if;
 363
 364             when N_Range =>
 365                return Expr_Name (Low_Bound (Expr)) & ".." &
 366                  Expr_Name (High_Bound (Expr));
 367
 368             when N_Slice =>
 369                return Expr_Name (Prefix (Expr)) & " (" &
 370                  Expr_Name (Discrete_Range (Expr)) & ")";
 371
 372             when N_And_Then =>
 373                return Expr_Name (Left_Opnd (Expr)) & " and then " &
 374                  Expr_Name (Right_Opnd (Expr));
 375
 376             when N_In =>
 377                return Expr_Name (Left_Opnd (Expr)) & " in " &
 378                  Expr_Name (Right_Opnd (Expr));
 379
 380             when N_Not_In =>
 381                return Expr_Name (Left_Opnd (Expr)) & " not in " &
 382                  Expr_Name (Right_Opnd (Expr));
 383
 384             when N_Or_Else =>
 385                return Expr_Name (Left_Opnd (Expr)) & " or else " &
 386                  Expr_Name (Right_Opnd (Expr));
 387
 388             when N_Op_And =>
 389                return Expr_Name (Left_Opnd (Expr)) & " and " &
 390                  Expr_Name (Right_Opnd (Expr));
 391
 392             when N_Op_Or =>
 393                return Expr_Name (Left_Opnd (Expr)) & " or " &
 394                  Expr_Name (Right_Opnd (Expr));
 395
 396             when N_Op_Xor =>
 397                return Expr_Name (Left_Opnd (Expr)) & " xor " &
 398                  Expr_Name (Right_Opnd (Expr));
 399
 400             when N_Op_Eq =>
 401                return Expr_Name (Left_Opnd (Expr)) & " = " &
 402                  Expr_Name (Right_Opnd (Expr));
 403
 404             when N_Op_Ne =>
 405                return Expr_Name (Left_Opnd (Expr)) & " /= " &
 406                  Expr_Name (Right_Opnd (Expr));
 407
 408             when N_Op_Lt =>
 409                return Expr_Name (Left_Opnd (Expr)) & " < " &
 410                  Expr_Name (Right_Opnd (Expr));
 411
 412             when N_Op_Le =>
 413                return Expr_Name (Left_Opnd (Expr)) & " <= " &
 414                  Expr_Name (Right_Opnd (Expr));
 415
 416             when N_Op_Gt =>
 417                return Expr_Name (Left_Opnd (Expr)) & " > " &
 418                  Expr_Name (Right_Opnd (Expr));
 419
 420             when N_Op_Ge =>
 421                return Expr_Name (Left_Opnd (Expr)) & " >= " &
 422                  Expr_Name (Right_Opnd (Expr));
 423
 424             when N_Op_Add =>
 425                return Expr_Name (Left_Opnd (Expr)) & " + " &
 426                  Expr_Name (Right_Opnd (Expr));
 427
 428             when N_Op_Subtract =>
 429                return Expr_Name (Left_Opnd (Expr)) & " - " &
 430                  Expr_Name (Right_Opnd (Expr));
 431
 432             when N_Op_Multiply =>
 433                return Expr_Name (Left_Opnd (Expr)) & " * " &
 434                  Expr_Name (Right_Opnd (Expr));
 435
 436             when N_Op_Divide =>
 437                return Expr_Name (Left_Opnd (Expr)) & " / " &
 438                  Expr_Name (Right_Opnd (Expr));
 439
 440             when N_Op_Mod =>
 441                return Expr_Name (Left_Opnd (Expr)) & " mod " &
 442                  Expr_Name (Right_Opnd (Expr));
 443
 444             when N_Op_Rem =>
 445                return Expr_Name (Left_Opnd (Expr)) & " rem " &
 446                  Expr_Name (Right_Opnd (Expr));
 447
 448             when N_Op_Expon =>
 449                return Expr_Name (Left_Opnd (Expr)) & " ** " &
 450                  Expr_Name (Right_Opnd (Expr));
 451
 452             when N_Op_Shift_Left =>
 453                return Expr_Name (Left_Opnd (Expr)) & " << " &
 454                  Expr_Name (Right_Opnd (Expr));
 455
 456             when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
 457                return Expr_Name (Left_Opnd (Expr)) & " >> " &
 458                  Expr_Name (Right_Opnd (Expr));
 459
 460             when N_Op_Concat =>
 461                return Expr_Name (Left_Opnd (Expr)) & " & " &
 462                  Expr_Name (Right_Opnd (Expr));
 463
 464             when N_Op_Plus =>
 465                return "+" & Expr_Name (Right_Opnd (Expr));
 466
 467             when N_Op_Minus =>
 468                return "-" & Expr_Name (Right_Opnd (Expr));
 469
 470             when N_Op_Abs =>
 471                return "abs " & Expr_Name (Right_Opnd (Expr));
 472
 473             when N_Op_Not =>
 474                return "not (" & Expr_Name (Right_Opnd (Expr)) & ")";
 475
 476             when N_Parameter_Association =>
 477                return Expr_Name (Explicit_Actual_Parameter (Expr));
 478
 479             when N_Type_Conversion | N_Unchecked_Type_Conversion =>
 480
 481                --  Most conversions are not very interesting (used inside
 482                --  expanded checks to convert to larger ranges), so skip them.
 483
 484                return Expr_Name (Expression (Expr));
 485
 486             when N_Indexed_Component =>
 487                if Take_Prefix then
 488                   return Expr_Name (Prefix (Expr)) &
 489                     List_Name (First (Sinfo.Expressions (Expr)));
 490                else
 491                   return List_Name (First (Sinfo.Expressions (Expr)));
 492                end if;
 493
 494             when N_Function_Call =>
 495
 496                --  If Default = "", it means we're expanding the name of
 497                --  a gnat temporary (and not really a function call), so add
 498                --  parentheses around function call to mark it specially.
 499
 500                if Default = "" then
 501                   return '(' & Expr_Name (Name (Expr)) &
 502                     List_Name (First (Sinfo.Parameter_Associations (Expr))) &
 503                       ')';
 504                else
 505                   return Expr_Name (Name (Expr)) &
 506                     List_Name (First (Sinfo.Parameter_Associations (Expr)));
 507                end if;
 508
 509             when N_Null =>
 510                return "null";
 511
 512             when N_Others_Choice =>
 513                return "others";
 514
 515             when others =>
 516                return "...";
 517          end case;
 518       end Expr_Name;
 519
 520    --  Start of processing for Expression_Name
 521
 522    begin
 523       if not From_Source then
 524          declare
 525             S : constant String := Expr_Name (Expr);
 526          begin
 527             if S = "..." then
 528                return Default;
 529             else
 530                return S;
 531             end if;
 532          end;
 533       end if;
 534
 535       --  Compute left (start) and right (end) slocs for the expression
 536       --  Consider using Sinput.Sloc_Range instead, except that it does not
 537       --  work properly currently???
 538
 539       loop
 540          case Nkind (Left) is
 541             when N_Binary_Op | N_Membership_Test |
 542                  N_And_Then  | N_Or_Else         =>
 543                Left := Original_Node (Left_Opnd (Left));
 544
 545             when N_Attribute_Reference  | N_Expanded_Name      |
 546                  N_Explicit_Dereference | N_Indexed_Component  |
 547                  N_Reference            | N_Selected_Component |
 548                  N_Slice                                       =>
 549                Left := Original_Node (Prefix (Left));
 550
 551             when N_Designator | N_Defining_Program_Unit_Name |
 552                  N_Function_Call                             =>
 553                Left := Original_Node (Name (Left));
 554
 555             when N_Range =>
 556                Left := Original_Node (Low_Bound (Left));
 557
 558             when N_Type_Conversion =>
 559                Left := Original_Node (Subtype_Mark (Left));
 560
 561             --  For any other item, quit loop
 562
 563             when others =>
 564                exit;
 565          end case;
 566       end loop;
 567
 568       loop
 569          case Nkind (Right) is
 570             when N_Op       | N_Membership_Test |
 571                  N_And_Then | N_Or_Else         =>
 572                Right := Original_Node (Right_Opnd (Right));
 573
 574             when N_Selected_Component | N_Expanded_Name =>
 575                Right := Original_Node (Selector_Name (Right));
 576
 577             when N_Designator =>
 578                Right := Original_Node (Identifier (Right));
 579
 580             when N_Defining_Program_Unit_Name =>
 581                Right := Original_Node (Defining_Identifier (Right));
 582
 583             when N_Range =>
 584                Right := Original_Node (High_Bound (Right));
 585
 586             when N_Parameter_Association =>
 587                Right := Original_Node (Explicit_Actual_Parameter (Right));
 588
 589             when N_Indexed_Component =>
 590                Right := Original_Node (Last (Sinfo.Expressions (Right)));
 591                Append_Paren := True;
 592
 593             when N_Function_Call =>
 594                if Present (Sinfo.Parameter_Associations (Right)) then
 595                   declare
 596                      Rover : Node_Id;
 597                      Found : Boolean;
 598
 599                   begin
 600                      --  Avoid source position confusion associated with
 601                      --  parameters for which Comes_From_Source is False.
 602
 603                      Rover := First (Sinfo.Parameter_Associations (Right));
 604                      Found := False;
 605                      while Present (Rover) loop
 606                         if Comes_From_Source (Original_Node (Rover)) then
 607                            Right := Original_Node (Rover);
 608                            Append_Paren := True;
 609                            Found := True;
 610                         end if;
 611
 612                         Next (Rover);
 613                      end loop;
 614
 615                      --  Quit loop if no Comes_From_Source parameters
 616
 617                      exit when not Found;
 618                   end;
 619
 620                --  Quit loop if no parameters
 621
 622                else
 623                   exit;
 624                end if;
 625
 626             when N_Quantified_Expression =>
 627                Right := Original_Node (Condition (Right));
 628
 629             --  For all other items, quit the loop
 630
 631             when others =>
 632                exit;
 633          end case;
 634       end loop;
 635
 636       declare
 637          Scn      : Source_Ptr := Original_Location (Sloc (Left));
 638          Src      : constant Source_Buffer_Ptr :=
 639            Source_Text (Get_Source_File_Index (Scn));
 640          End_Sloc : constant Source_Ptr :=
 641            Original_Location (Sloc (Right));
 642
 643       begin
 644          if Scn > End_Sloc then
 645             return Default;
 646          end if;
 647
 648          declare
 649             Buffer           : String (1 .. Natural (End_Sloc - Scn));
 650             Skipping_Comment : Boolean := False;
 651             Underscore       : Boolean := False;
 652             Index            : Natural := 0;
 653
 654          begin
 655             if Right /= Expr then
 656                while Scn < End_Sloc loop
 657                   case Src (Scn) is
 658                   when ' ' | ASCII.HT =>
 659                      if not Skipping_Comment and then not Underscore then
 660                         Underscore := True;
 661                         Index := Index + 1;
 662                         Buffer (Index) := ' ';
 663                      end if;
 664
 665                   --  CR/LF/FF is the end of any comment
 666
 667                   when ASCII.LF | ASCII.CR | ASCII.FF =>
 668                      Skipping_Comment := False;
 669
 670                   when others =>
 671                      Underscore := False;
 672
 673                      if not Skipping_Comment then
 674
 675                         --  Ignore comment
 676
 677                         if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
 678                            Skipping_Comment := True;
 679
 680                         else
 681                            Index := Index + 1;
 682                            Buffer (Index) := Src (Scn);
 683                         end if;
 684                      end if;
 685                   end case;
 686
 687                   Scn := Scn + 1;
 688                end loop;
 689             end if;
 690
 691             if Index < 1 then
 692                declare
 693                   S : constant String := Expr_Name (Right);
 694                begin
 695                   if S = "..." then
 696                      return Default;
 697                   else
 698                      return S;
 699                   end if;
 700                end;
 701
 702             elsif Append_Paren then
 703                return Buffer (1 .. Index) & Expr_Name (Right, False) & ')';
 704
 705             else
 706                return Buffer (1 .. Index) & Expr_Name (Right, False);
 707             end if;
 708          end;
 709       end;
 710    end Expression_Image;
 711
 712 end Pprint;