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