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-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
  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                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
 682 end Pprint;