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-2020, 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 Csets;   use Csets;
  28 with Einfo;   use Einfo;
  29 with Namet;   use Namet;
  30 with Nlists;  use Nlists;
  31 with Opt;     use Opt;
  32 with Sinfo;   use Sinfo;
  33 with Sinput;  use Sinput;
  34 with Snames;  use Snames;
  35 with Uintp;   use Uintp;
  36
  37 package body Pprint is
  38
  39    List_Name_Count : Integer := 0;
  40    --  Counter used to prevent infinite recursion while computing name of
  41    --  complex expressions.
  42
  43    ----------------------
  44    -- Expression_Image --
  45    ----------------------
  46
  47    function Expression_Image
  48      (Expr    : Node_Id;
  49       Default : String) return String
  50    is
  51       From_Source  : constant Boolean :=
  52                        Comes_From_Source (Expr)
  53                          and then not Opt.Debug_Generated_Code;
  54       Append_Paren : Natural := 0;
  55       Left         : Node_Id := Original_Node (Expr);
  56       Right        : Node_Id := Original_Node (Expr);
  57
  58       function Expr_Name
  59         (Expr        : Node_Id;
  60          Take_Prefix : Boolean := True;
  61          Expand_Type : Boolean := True) return String;
  62       --  Return string corresponding to Expr. If no string can be extracted,
  63       --  return "...". If Take_Prefix is True, go back to prefix when needed,
  64       --  otherwise only consider the right-hand side of an expression. If
  65       --  Expand_Type is True and Expr is a type, try to expand Expr (an
  66       --  internally generated type) into a user understandable name.
  67
  68       Max_List : constant := 3;
  69       --  Limit number of list elements to dump
  70
  71       Max_Expr_Elements : constant := 24;
  72       --  Limit number of elements in an expression for use by Expr_Name
  73
  74       Num_Elements : Natural := 0;
  75       --  Current number of elements processed by Expr_Name
  76
  77       function List_Name
  78         (List      : Node_Id;
  79          Add_Space : Boolean := True;
  80          Add_Paren : Boolean := True) return String;
  81       --  Return a string corresponding to List
  82
  83       ---------------
  84       -- List_Name --
  85       ---------------
  86
  87       function List_Name
  88         (List      : Node_Id;
  89          Add_Space : Boolean := True;
  90          Add_Paren : Boolean := True) return String
  91       is
  92          function Internal_List_Name
  93            (List      : Node_Id;
  94             First     : Boolean := True;
  95             Add_Space : Boolean := True;
  96             Add_Paren : Boolean := True;
  97             Num       : Natural := 1) return String;
  98          --  ??? what does this do
  99
 100          ------------------------
 101          -- Internal_List_Name --
 102          ------------------------
 103
 104          function Internal_List_Name
 105            (List      : Node_Id;
 106             First     : Boolean := True;
 107             Add_Space : Boolean := True;
 108             Add_Paren : Boolean := True;
 109             Num       : Natural := 1) return String
 110          is
 111             function Prepend (S : String) return String;
 112             --  ??? what does this do
 113
 114             -------------
 115             -- Prepend --
 116             -------------
 117
 118             function Prepend (S : String) return String is
 119             begin
 120                if Add_Space then
 121                   if Add_Paren then
 122                      return " (" & S;
 123                   else
 124                      return ' ' & S;
 125                   end if;
 126                elsif Add_Paren then
 127                   return '(' & S;
 128                else
 129                   return S;
 130                end if;
 131             end Prepend;
 132
 133          --  Start of processing for Internal_List_Name
 134
 135          begin
 136             if not Present (List) then
 137                if First or else not Add_Paren then
 138                   return "";
 139                else
 140                   return ")";
 141                end if;
 142             elsif Num > Max_List then
 143                if Add_Paren then
 144                   return ", ...)";
 145                else
 146                   return ", ...";
 147                end if;
 148             end if;
 149
 150             --  ??? the Internal_List_Name calls can be factored out
 151
 152             if First then
 153                return Prepend (Expr_Name (List)
 154                  & Internal_List_Name
 155                      (List      => Next (List),
 156                       First     => False,
 157                       Add_Paren => Add_Paren,
 158                       Num       => Num + 1));
 159             else
 160                return ", " & Expr_Name (List)
 161                  & Internal_List_Name
 162                      (List      => Next (List),
 163                       First     => False,
 164                       Add_Paren => Add_Paren,
 165                       Num       => Num + 1);
 166             end if;
 167          end Internal_List_Name;
 168
 169       --  Start of processing for List_Name
 170
 171       begin
 172          --  Prevent infinite recursion by limiting depth to 3
 173
 174          if List_Name_Count > 3 then
 175             return "...";
 176          end if;
 177
 178          List_Name_Count := List_Name_Count + 1;
 179
 180          declare
 181             Result : constant String :=
 182                        Internal_List_Name
 183                          (List      => List,
 184                           Add_Space => Add_Space,
 185                           Add_Paren => Add_Paren);
 186          begin
 187             List_Name_Count := List_Name_Count - 1;
 188             return Result;
 189          end;
 190       end List_Name;
 191
 192       ---------------
 193       -- Expr_Name --
 194       ---------------
 195
 196       function Expr_Name
 197         (Expr        : Node_Id;
 198          Take_Prefix : Boolean := True;
 199          Expand_Type : Boolean := True) return String
 200       is
 201       begin
 202          Num_Elements := Num_Elements + 1;
 203
 204          if Num_Elements > Max_Expr_Elements then
 205             return "...";
 206          end if;
 207
 208          case Nkind (Expr) is
 209             when N_Defining_Identifier
 210                | N_Identifier
 211             =>
 212                return Ident_Image (Expr, Expression_Image.Expr, Expand_Type);
 213
 214             when N_Character_Literal =>
 215                declare
 216                   Char : constant Int := UI_To_Int (Char_Literal_Value (Expr));
 217                begin
 218                   if Char in 32 .. 127 then
 219                      return "'" & Character'Val (Char) & "'";
 220                   else
 221                      UI_Image (Char_Literal_Value (Expr));
 222                      return
 223                        "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'";
 224                   end if;
 225                end;
 226
 227             when N_Integer_Literal =>
 228                UI_Image (Intval (Expr));
 229                return UI_Image_Buffer (1 .. UI_Image_Length);
 230
 231             when N_Real_Literal =>
 232                return Real_Image (Realval (Expr));
 233
 234             when N_String_Literal =>
 235                return String_Image (Strval (Expr));
 236
 237             when N_Allocator =>
 238                return "new " & Expr_Name (Expression (Expr));
 239
 240             when N_Aggregate =>
 241                if Present (Sinfo.Expressions (Expr)) then
 242                   return
 243                     List_Name
 244                       (List      => First (Sinfo.Expressions (Expr)),
 245                        Add_Space => False);
 246
 247                --  Do not return empty string for (others => <>) aggregate
 248                --  of a componentless record type. At least one caller (the
 249                --  recursive call below in the N_Qualified_Expression case)
 250                --  is not prepared to deal with a zero-length result.
 251
 252                elsif Null_Record_Present (Expr)
 253                  or else not Present (First (Component_Associations (Expr)))
 254                then
 255                   return ("(null record)");
 256
 257                else
 258                   return
 259                     List_Name
 260                       (List      => First (Component_Associations (Expr)),
 261                        Add_Space => False,
 262                        Add_Paren => False);
 263                end if;
 264
 265             when N_Extension_Aggregate =>
 266                return "(" & Expr_Name (Ancestor_Part (Expr)) & " with "
 267                  & List_Name
 268                      (List      => First (Sinfo.Expressions (Expr)),
 269                       Add_Space => False,
 270                       Add_Paren => False) & ")";
 271
 272             when N_Attribute_Reference =>
 273                if Take_Prefix then
 274                   declare
 275                      function To_Mixed_Case (S : String) return String;
 276                      --  Transform given string into the corresponding one in
 277                      --  mixed case form.
 278
 279                      -------------------
 280                      -- To_Mixed_Case --
 281                      -------------------
 282
 283                      function To_Mixed_Case (S : String) return String is
 284                         Result : String (S'Range);
 285                         Ucase  : Boolean := True;
 286
 287                      begin
 288                         for J in S'Range loop
 289                            if Ucase then
 290                               Result (J) := Fold_Upper (S (J));
 291                            else
 292                               Result (J) := Fold_Lower (S (J));
 293                            end if;
 294
 295                            Ucase := (S (J) = '_');
 296                         end loop;
 297
 298                         return Result;
 299                      end To_Mixed_Case;
 300
 301                      Id : constant Attribute_Id :=
 302                             Get_Attribute_Id (Attribute_Name (Expr));
 303
 304                      --  Always use mixed case for attributes
 305
 306                      Str : constant String :=
 307                              Expr_Name (Prefix (Expr))
 308                                & "'"
 309                                & To_Mixed_Case
 310                                    (Get_Name_String (Attribute_Name (Expr)));
 311
 312                      N      : Node_Id;
 313                      Ranges : List_Id;
 314
 315                   begin
 316                      if (Id = Attribute_First or else Id = Attribute_Last)
 317                        and then Str (Str'First) = '$'
 318                      then
 319                         N := Associated_Node_For_Itype (Etype (Prefix (Expr)));
 320
 321                         if Present (N) then
 322                            if Nkind (N) = N_Full_Type_Declaration then
 323                               N := Type_Definition (N);
 324                            end if;
 325
 326                            if Nkind (N) = N_Subtype_Declaration then
 327                               Ranges :=
 328                                 Constraints
 329                                   (Constraint (Subtype_Indication (N)));
 330
 331                               if List_Length (Ranges) = 1
 332                                 and then Nkind (First (Ranges)) in
 333                                            N_Range                          |
 334                                            N_Real_Range_Specification       |
 335                                            N_Signed_Integer_Type_Definition
 336                               then
 337                                  if Id = Attribute_First then
 338                                     return
 339                                       Expression_Image
 340                                         (Low_Bound (First (Ranges)), Str);
 341                                  else
 342                                     return
 343                                       Expression_Image
 344                                         (High_Bound (First (Ranges)), Str);
 345                                  end if;
 346                               end if;
 347                            end if;
 348                         end if;
 349                      end if;
 350
 351                      return Str;
 352                   end;
 353                else
 354                   return "'" & Get_Name_String (Attribute_Name (Expr));
 355                end if;
 356
 357             when N_Explicit_Dereference =>
 358                Explicit_Dereference : declare
 359                   function Deref_Suffix return String;
 360                   --  Usually returns ".all", but will return "" if
 361                   --  Hide_Temp_Derefs is true and the prefix is a use of a
 362                   --  not-from-source object declared as
 363                   --    X : constant Some_Access_Type := Some_Expr'Reference;
 364                   --  (as is sometimes done in Exp_Util.Remove_Side_Effects).
 365
 366                   ------------------
 367                   -- Deref_Suffix --
 368                   ------------------
 369
 370                   function Deref_Suffix return String is
 371                      Decl : Node_Id;
 372
 373                   begin
 374                      if Hide_Temp_Derefs
 375                        and then Nkind (Prefix (Expr)) = N_Identifier
 376                        and then Nkind (Entity (Prefix (Expr))) =
 377                                   N_Defining_Identifier
 378                      then
 379                         Decl := Parent (Entity (Prefix (Expr)));
 380
 381                         if Present (Decl)
 382                           and then Nkind (Decl) = N_Object_Declaration
 383                           and then not Comes_From_Source (Decl)
 384                           and then Constant_Present (Decl)
 385                           and then Present (Sinfo.Expression (Decl))
 386                           and then Nkind (Sinfo.Expression (Decl)) =
 387                                      N_Reference
 388                         then
 389                            return "";
 390                         end if;
 391                      end if;
 392
 393                      --  The default case
 394
 395                      return ".all";
 396                   end Deref_Suffix;
 397
 398                --  Start of processing for Explicit_Dereference
 399
 400                begin
 401                   if Hide_Parameter_Blocks
 402                     and then Nkind (Prefix (Expr)) = N_Selected_Component
 403                     and then Present (Etype (Prefix (Expr)))
 404                     and then Is_Access_Type (Etype (Prefix (Expr)))
 405                     and then Is_Param_Block_Component_Type
 406                                (Etype (Prefix (Expr)))
 407                   then
 408                      --  Return "Foo" instead of "Parameter_Block.Foo.all"
 409
 410                      return Expr_Name (Selector_Name (Prefix (Expr)));
 411
 412                   elsif Take_Prefix then
 413                      return Expr_Name (Prefix (Expr)) & Deref_Suffix;
 414                   else
 415                      return Deref_Suffix;
 416                   end if;
 417                end Explicit_Dereference;
 418
 419             when N_Expanded_Name
 420                | N_Selected_Component
 421             =>
 422                if Take_Prefix then
 423                   return
 424                     Expr_Name (Prefix (Expr)) & "." &
 425                     Expr_Name (Selector_Name (Expr));
 426                else
 427                   return "." & Expr_Name (Selector_Name (Expr));
 428                end if;
 429
 430             when N_Component_Association =>
 431                return "("
 432                  & List_Name
 433                      (List      => First (Choices (Expr)),
 434                       Add_Space => False,
 435                       Add_Paren => False)
 436                  & " => " & Expr_Name (Expression (Expr)) & ")";
 437
 438             when N_If_Expression =>
 439                declare
 440                   N : constant Node_Id := First (Sinfo.Expressions (Expr));
 441                begin
 442                   return
 443                     "if " & Expr_Name (N) & " then "
 444                       & Expr_Name (Next (N)) & " else "
 445                       & Expr_Name (Next (Next (N)));
 446                end;
 447
 448             when N_Qualified_Expression =>
 449                declare
 450                   Mark : constant String :=
 451                            Expr_Name
 452                              (Subtype_Mark (Expr), Expand_Type => False);
 453                   Str  : constant String := Expr_Name (Expression (Expr));
 454                begin
 455                   if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
 456                      return Mark & "'" & Str;
 457                   else
 458                      return Mark & "'(" & Str & ")";
 459                   end if;
 460                end;
 461
 462             when N_Expression_With_Actions
 463                | N_Unchecked_Expression
 464             =>
 465                return Expr_Name (Expression (Expr));
 466
 467             when N_Raise_Constraint_Error =>
 468                if Present (Condition (Expr)) then
 469                   return
 470                     "[constraint_error when "
 471                       & Expr_Name (Condition (Expr)) & "]";
 472                else
 473                   return "[constraint_error]";
 474                end if;
 475
 476             when N_Raise_Program_Error =>
 477                if Present (Condition (Expr)) then
 478                   return
 479                     "[program_error when "
 480                       & Expr_Name (Condition (Expr)) & "]";
 481                else
 482                   return "[program_error]";
 483                end if;
 484
 485             when N_Range =>
 486                return
 487                  Expr_Name (Low_Bound (Expr)) & ".." &
 488                  Expr_Name (High_Bound (Expr));
 489
 490             when N_Slice =>
 491                return
 492                  Expr_Name (Prefix (Expr)) & " (" &
 493                  Expr_Name (Discrete_Range (Expr)) & ")";
 494
 495             when N_And_Then =>
 496                return
 497                  Expr_Name (Left_Opnd (Expr)) & " and then " &
 498                  Expr_Name (Right_Opnd (Expr));
 499
 500             when N_In =>
 501                return
 502                  Expr_Name (Left_Opnd (Expr)) & " in " &
 503                  Expr_Name (Right_Opnd (Expr));
 504
 505             when N_Not_In =>
 506                return
 507                  Expr_Name (Left_Opnd (Expr)) & " not in " &
 508                  Expr_Name (Right_Opnd (Expr));
 509
 510             when N_Or_Else =>
 511                return
 512                  Expr_Name (Left_Opnd (Expr)) & " or else " &
 513                  Expr_Name (Right_Opnd (Expr));
 514
 515             when N_Op_And =>
 516                return
 517                  Expr_Name (Left_Opnd (Expr)) & " and " &
 518                  Expr_Name (Right_Opnd (Expr));
 519
 520             when N_Op_Or =>
 521                return
 522                  Expr_Name (Left_Opnd (Expr)) & " or " &
 523                  Expr_Name (Right_Opnd (Expr));
 524
 525             when N_Op_Xor =>
 526                return
 527                  Expr_Name (Left_Opnd (Expr)) & " xor " &
 528                  Expr_Name (Right_Opnd (Expr));
 529
 530             when N_Op_Eq =>
 531                return
 532                  Expr_Name (Left_Opnd (Expr)) & " = " &
 533                  Expr_Name (Right_Opnd (Expr));
 534
 535             when N_Op_Ne =>
 536                return
 537                  Expr_Name (Left_Opnd (Expr)) & " /= " &
 538                  Expr_Name (Right_Opnd (Expr));
 539
 540             when N_Op_Lt =>
 541                return
 542                  Expr_Name (Left_Opnd (Expr)) & " < " &
 543                  Expr_Name (Right_Opnd (Expr));
 544
 545             when N_Op_Le =>
 546                return
 547                  Expr_Name (Left_Opnd (Expr)) & " <= " &
 548                  Expr_Name (Right_Opnd (Expr));
 549
 550             when N_Op_Gt =>
 551                return
 552                  Expr_Name (Left_Opnd (Expr)) & " > " &
 553                  Expr_Name (Right_Opnd (Expr));
 554
 555             when N_Op_Ge =>
 556                return
 557                  Expr_Name (Left_Opnd (Expr)) & " >= " &
 558                  Expr_Name (Right_Opnd (Expr));
 559
 560             when N_Op_Add =>
 561                return
 562                  Expr_Name (Left_Opnd (Expr)) & " + " &
 563                  Expr_Name (Right_Opnd (Expr));
 564
 565             when N_Op_Subtract =>
 566                return
 567                  Expr_Name (Left_Opnd (Expr)) & " - " &
 568                  Expr_Name (Right_Opnd (Expr));
 569
 570             when N_Op_Multiply =>
 571                return
 572                  Expr_Name (Left_Opnd (Expr)) & " * " &
 573                  Expr_Name (Right_Opnd (Expr));
 574
 575             when N_Op_Divide =>
 576                return
 577                  Expr_Name (Left_Opnd (Expr)) & " / " &
 578                  Expr_Name (Right_Opnd (Expr));
 579
 580             when N_Op_Mod =>
 581                return
 582                  Expr_Name (Left_Opnd (Expr)) & " mod " &
 583                  Expr_Name (Right_Opnd (Expr));
 584
 585             when N_Op_Rem =>
 586                return
 587                  Expr_Name (Left_Opnd (Expr)) & " rem " &
 588                  Expr_Name (Right_Opnd (Expr));
 589
 590             when N_Op_Expon =>
 591                return
 592                  Expr_Name (Left_Opnd (Expr)) & " ** " &
 593                  Expr_Name (Right_Opnd (Expr));
 594
 595             when N_Op_Shift_Left =>
 596                return
 597                  Expr_Name (Left_Opnd (Expr)) & " << " &
 598                  Expr_Name (Right_Opnd (Expr));
 599
 600             when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
 601                return
 602                  Expr_Name (Left_Opnd (Expr)) & " >> " &
 603                  Expr_Name (Right_Opnd (Expr));
 604
 605             when N_Op_Concat =>
 606                return
 607                  Expr_Name (Left_Opnd (Expr)) & " & " &
 608                  Expr_Name (Right_Opnd (Expr));
 609
 610             when N_Op_Plus =>
 611                return "+" & Expr_Name (Right_Opnd (Expr));
 612
 613             when N_Op_Minus =>
 614                return "-" & Expr_Name (Right_Opnd (Expr));
 615
 616             when N_Op_Abs =>
 617                return "abs " & Expr_Name (Right_Opnd (Expr));
 618
 619             when N_Op_Not =>
 620                return "not (" & Expr_Name (Right_Opnd (Expr)) & ")";
 621
 622             when N_Parameter_Association =>
 623                return Expr_Name (Explicit_Actual_Parameter (Expr));
 624
 625             when N_Type_Conversion =>
 626
 627                --  Most conversions are not very interesting (used inside
 628                --  expanded checks to convert to larger ranges), so skip them.
 629
 630                return Expr_Name (Expression (Expr));
 631
 632             when N_Unchecked_Type_Conversion =>
 633
 634                --  Only keep the type conversion in complex cases
 635
 636                if not Is_Scalar_Type (Etype (Expr))
 637                  or else not Is_Scalar_Type (Etype (Expression (Expr)))
 638                  or else Is_Modular_Integer_Type (Etype (Expr)) /=
 639                            Is_Modular_Integer_Type (Etype (Expression (Expr)))
 640                then
 641                   return Expr_Name (Subtype_Mark (Expr)) &
 642                     "(" & Expr_Name (Expression (Expr)) & ")";
 643                else
 644                   return Expr_Name (Expression (Expr));
 645                end if;
 646
 647             when N_Indexed_Component =>
 648                if Take_Prefix then
 649                   return
 650                     Expr_Name (Prefix (Expr))
 651                       & List_Name (First (Sinfo.Expressions (Expr)));
 652                else
 653                   return List_Name (First (Sinfo.Expressions (Expr)));
 654                end if;
 655
 656             when N_Function_Call =>
 657
 658                --  If Default = "", it means we're expanding the name of
 659                --  a gnat temporary (and not really a function call), so add
 660                --  parentheses around function call to mark it specially.
 661
 662                if Default = "" then
 663                   return '('
 664                     & Expr_Name (Name (Expr))
 665                     & List_Name (First (Sinfo.Parameter_Associations (Expr)))
 666                     & ')';
 667                else
 668                   return
 669                     Expr_Name (Name (Expr))
 670                       & List_Name
 671                           (First (Sinfo.Parameter_Associations (Expr)));
 672                end if;
 673
 674             when N_Null =>
 675                return "null";
 676
 677             when N_Others_Choice =>
 678                return "others";
 679
 680             when others =>
 681                return "...";
 682          end case;
 683       end Expr_Name;
 684
 685    --  Start of processing for Expression_Name
 686
 687    begin
 688       if not From_Source then
 689          declare
 690             S : constant String := Expr_Name (Expr);
 691          begin
 692             if S = "..." then
 693                return Default;
 694             else
 695                return S;
 696             end if;
 697          end;
 698       end if;
 699
 700       --  Compute left (start) and right (end) slocs for the expression
 701       --  Consider using Sinput.Sloc_Range instead, except that it does not
 702       --  work properly currently???
 703
 704       loop
 705          case Nkind (Left) is
 706             when N_And_Then
 707                | N_Binary_Op
 708                | N_Membership_Test
 709                | N_Or_Else
 710             =>
 711                Left := Original_Node (Left_Opnd (Left));
 712
 713             when N_Attribute_Reference
 714                | N_Expanded_Name
 715                | N_Explicit_Dereference
 716                | N_Indexed_Component
 717                | N_Reference
 718                | N_Selected_Component
 719                | N_Slice
 720             =>
 721                Left := Original_Node (Prefix (Left));
 722
 723             when N_Defining_Program_Unit_Name
 724                | N_Designator
 725                | N_Function_Call
 726             =>
 727                Left := Original_Node (Name (Left));
 728
 729             when N_Range =>
 730                Left := Original_Node (Low_Bound (Left));
 731
 732             when N_Qualified_Expression
 733                | N_Type_Conversion
 734             =>
 735                Left := Original_Node (Subtype_Mark (Left));
 736
 737             --  For any other item, quit loop
 738
 739             when others =>
 740                exit;
 741          end case;
 742       end loop;
 743
 744       loop
 745          case Nkind (Right) is
 746             when N_And_Then
 747                | N_Membership_Test
 748                | N_Op
 749                | N_Or_Else
 750             =>
 751                Right := Original_Node (Right_Opnd (Right));
 752
 753             when N_Expanded_Name
 754                | N_Selected_Component
 755             =>
 756                Right := Original_Node (Selector_Name (Right));
 757
 758             when N_Qualified_Expression
 759                | N_Type_Conversion
 760             =>
 761                Right := Original_Node (Expression (Right));
 762
 763                --  If argument does not already account for a closing
 764                --  parenthesis, count one here.
 765
 766                if Nkind (Right) not in N_Aggregate | N_Quantified_Expression
 767                then
 768                   Append_Paren := Append_Paren + 1;
 769                end if;
 770
 771             when N_Designator =>
 772                Right := Original_Node (Identifier (Right));
 773
 774             when N_Defining_Program_Unit_Name =>
 775                Right := Original_Node (Defining_Identifier (Right));
 776
 777             when N_Range =>
 778                Right := Original_Node (High_Bound (Right));
 779
 780             when N_Parameter_Association =>
 781                Right := Original_Node (Explicit_Actual_Parameter (Right));
 782
 783             when N_Component_Association =>
 784                if Present (Expression (Right)) then
 785                   Right := Expression (Right);
 786                else
 787                   Right := Last (Choices (Right));
 788                end if;
 789
 790             when N_Indexed_Component =>
 791                Right := Original_Node (Last (Sinfo.Expressions (Right)));
 792                Append_Paren := Append_Paren + 1;
 793
 794             when N_Function_Call =>
 795                if Present (Sinfo.Parameter_Associations (Right)) then
 796                   declare
 797                      Rover : Node_Id;
 798                      Found : Boolean;
 799
 800                   begin
 801                      --  Avoid source position confusion associated with
 802                      --  parameters for which Comes_From_Source is False.
 803
 804                      Rover := First (Sinfo.Parameter_Associations (Right));
 805                      Found := False;
 806                      while Present (Rover) loop
 807                         if Comes_From_Source (Original_Node (Rover)) then
 808                            Right := Original_Node (Rover);
 809                            Found := True;
 810                         end if;
 811
 812                         Next (Rover);
 813                      end loop;
 814
 815                      if Found then
 816                         Append_Paren := Append_Paren + 1;
 817                      end if;
 818
 819                      --  Quit loop if no Comes_From_Source parameters
 820
 821                      exit when not Found;
 822                   end;
 823
 824                --  Quit loop if no parameters
 825
 826                else
 827                   exit;
 828                end if;
 829
 830             when N_Quantified_Expression =>
 831                Right        := Original_Node (Condition (Right));
 832                Append_Paren := Append_Paren + 1;
 833
 834             when N_Aggregate =>
 835                declare
 836                   Aggr : constant Node_Id := Right;
 837                   Sub  : Node_Id;
 838
 839                begin
 840                   Sub := First (Expressions (Aggr));
 841                   while Present (Sub) loop
 842                      if Sloc (Sub) > Sloc (Right) then
 843                         Right := Sub;
 844                      end if;
 845
 846                      Next (Sub);
 847                   end loop;
 848
 849                   Sub := First (Component_Associations (Aggr));
 850                   while Present (Sub) loop
 851                      if Sloc (Sub) > Sloc (Right) then
 852                         Right := Sub;
 853                      end if;
 854
 855                      Next (Sub);
 856                   end loop;
 857
 858                   exit when Right = Aggr;
 859
 860                   Append_Paren := Append_Paren + 1;
 861                end;
 862
 863             --  For all other items, quit the loop
 864
 865             when others =>
 866                exit;
 867          end case;
 868       end loop;
 869
 870       declare
 871          Scn      : Source_Ptr := Original_Location (Sloc (Left));
 872          End_Sloc : constant Source_Ptr :=
 873                       Original_Location (Sloc (Right));
 874          Src      : constant Source_Buffer_Ptr :=
 875                       Source_Text (Get_Source_File_Index (Scn));
 876
 877       begin
 878          if Scn > End_Sloc then
 879             return Default;
 880          end if;
 881
 882          declare
 883             Threshold        : constant := 256;
 884             Buffer           : String (1 .. Natural (End_Sloc - Scn));
 885             Index            : Natural := 0;
 886             Skipping_Comment : Boolean := False;
 887             Underscore       : Boolean := False;
 888
 889          begin
 890             if Right /= Expr then
 891                while Scn < End_Sloc loop
 892                   case Src (Scn) is
 893
 894                      --  Give up on non ASCII characters
 895
 896                      when Character'Val (128) .. Character'Last =>
 897                         Append_Paren := 0;
 898                         Index := 0;
 899                         Right := Expr;
 900                         exit;
 901
 902                      when ' '
 903                         | ASCII.HT
 904                      =>
 905                         if not Skipping_Comment and then not Underscore then
 906                            Underscore := True;
 907                            Index := Index + 1;
 908                            Buffer (Index) := ' ';
 909                         end if;
 910
 911                      --  CR/LF/FF is the end of any comment
 912
 913                      when ASCII.CR
 914                         | ASCII.FF
 915                         | ASCII.LF
 916                      =>
 917                         Skipping_Comment := False;
 918
 919                      when others =>
 920                         Underscore := False;
 921
 922                         if not Skipping_Comment then
 923
 924                            --  Ignore comment
 925
 926                            if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
 927                               Skipping_Comment := True;
 928
 929                            else
 930                               Index := Index + 1;
 931                               Buffer (Index) := Src (Scn);
 932                            end if;
 933                         end if;
 934                   end case;
 935
 936                   --  Give up on too long strings
 937
 938                   if Index >= Threshold then
 939                      return Buffer (1 .. Index) & "...";
 940                   end if;
 941
 942                   Scn := Scn + 1;
 943                end loop;
 944             end if;
 945
 946             if Index < 1 then
 947                declare
 948                   S : constant String := Expr_Name (Right);
 949                begin
 950                   if S = "..." then
 951                      return Default;
 952                   else
 953                      return S;
 954                   end if;
 955                end;
 956
 957             else
 958                return
 959                  Buffer (1 .. Index)
 960                    & Expr_Name (Right, False)
 961                    & (1 .. Append_Paren => ')');
 962             end if;
 963          end;
 964       end;
 965    end Expression_Image;
 966
 967 end Pprint;