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-2018, 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
 333                                   Nkind_In
 334                                     (First (Ranges),
 335                                      N_Range,
 336                                      N_Real_Range_Specification,
 337                                      N_Signed_Integer_Type_Definition)
 338                               then
 339                                  if Id = Attribute_First then
 340                                     return
 341                                       Expression_Image
 342                                         (Low_Bound (First (Ranges)), Str);
 343                                  else
 344                                     return
 345                                       Expression_Image
 346                                         (High_Bound (First (Ranges)), Str);
 347                                  end if;
 348                               end if;
 349                            end if;
 350                         end if;
 351                      end if;
 352
 353                      return Str;
 354                   end;
 355                else
 356                   return "'" & Get_Name_String (Attribute_Name (Expr));
 357                end if;
 358
 359             when N_Explicit_Dereference =>
 360                Explicit_Dereference : declare
 361                   function Deref_Suffix return String;
 362                   --  Usually returns ".all", but will return "" if
 363                   --  Hide_Temp_Derefs is true and the prefix is a use of a
 364                   --  not-from-source object declared as
 365                   --    X : constant Some_Access_Type := Some_Expr'Reference;
 366                   --  (as is sometimes done in Exp_Util.Remove_Side_Effects).
 367
 368                   ------------------
 369                   -- Deref_Suffix --
 370                   ------------------
 371
 372                   function Deref_Suffix return String is
 373                      Decl : Node_Id;
 374
 375                   begin
 376                      if Hide_Temp_Derefs
 377                        and then Nkind (Prefix (Expr)) = N_Identifier
 378                        and then Nkind (Entity (Prefix (Expr))) =
 379                                   N_Defining_Identifier
 380                      then
 381                         Decl := Parent (Entity (Prefix (Expr)));
 382
 383                         if Present (Decl)
 384                           and then Nkind (Decl) = N_Object_Declaration
 385                           and then not Comes_From_Source (Decl)
 386                           and then Constant_Present (Decl)
 387                           and then Present (Sinfo.Expression (Decl))
 388                           and then Nkind (Sinfo.Expression (Decl)) =
 389                                      N_Reference
 390                         then
 391                            return "";
 392                         end if;
 393                      end if;
 394
 395                      --  The default case
 396
 397                      return ".all";
 398                   end Deref_Suffix;
 399
 400                --  Start of processing for Explicit_Dereference
 401
 402                begin
 403                   if Hide_Parameter_Blocks
 404                     and then Nkind (Prefix (Expr)) = N_Selected_Component
 405                     and then Present (Etype (Prefix (Expr)))
 406                     and then Is_Access_Type (Etype (Prefix (Expr)))
 407                     and then Is_Param_Block_Component_Type
 408                                (Etype (Prefix (Expr)))
 409                   then
 410                      --  Return "Foo" instead of "Parameter_Block.Foo.all"
 411
 412                      return Expr_Name (Selector_Name (Prefix (Expr)));
 413
 414                   elsif Take_Prefix then
 415                      return Expr_Name (Prefix (Expr)) & Deref_Suffix;
 416                   else
 417                      return Deref_Suffix;
 418                   end if;
 419                end Explicit_Dereference;
 420
 421             when N_Expanded_Name
 422                | N_Selected_Component
 423             =>
 424                if Take_Prefix then
 425                   return
 426                     Expr_Name (Prefix (Expr)) & "." &
 427                     Expr_Name (Selector_Name (Expr));
 428                else
 429                   return "." & Expr_Name (Selector_Name (Expr));
 430                end if;
 431
 432             when N_Component_Association =>
 433                return "("
 434                  & List_Name
 435                      (List      => First (Choices (Expr)),
 436                       Add_Space => False,
 437                       Add_Paren => False)
 438                  & " => " & Expr_Name (Expression (Expr)) & ")";
 439
 440             when N_If_Expression =>
 441                declare
 442                   N : constant Node_Id := First (Sinfo.Expressions (Expr));
 443                begin
 444                   return
 445                     "if " & Expr_Name (N) & " then "
 446                       & Expr_Name (Next (N)) & " else "
 447                       & Expr_Name (Next (Next (N)));
 448                end;
 449
 450             when N_Qualified_Expression =>
 451                declare
 452                   Mark : constant String :=
 453                            Expr_Name
 454                              (Subtype_Mark (Expr), Expand_Type => False);
 455                   Str  : constant String := Expr_Name (Expression (Expr));
 456                begin
 457                   if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
 458                      return Mark & "'" & Str;
 459                   else
 460                      return Mark & "'(" & Str & ")";
 461                   end if;
 462                end;
 463
 464             when N_Expression_With_Actions
 465                | N_Unchecked_Expression
 466             =>
 467                return Expr_Name (Expression (Expr));
 468
 469             when N_Raise_Constraint_Error =>
 470                if Present (Condition (Expr)) then
 471                   return
 472                     "[constraint_error when "
 473                       & Expr_Name (Condition (Expr)) & "]";
 474                else
 475                   return "[constraint_error]";
 476                end if;
 477
 478             when N_Raise_Program_Error =>
 479                if Present (Condition (Expr)) then
 480                   return
 481                     "[program_error when "
 482                       & Expr_Name (Condition (Expr)) & "]";
 483                else
 484                   return "[program_error]";
 485                end if;
 486
 487             when N_Range =>
 488                return
 489                  Expr_Name (Low_Bound (Expr)) & ".." &
 490                  Expr_Name (High_Bound (Expr));
 491
 492             when N_Slice =>
 493                return
 494                  Expr_Name (Prefix (Expr)) & " (" &
 495                  Expr_Name (Discrete_Range (Expr)) & ")";
 496
 497             when N_And_Then =>
 498                return
 499                  Expr_Name (Left_Opnd (Expr)) & " and then " &
 500                  Expr_Name (Right_Opnd (Expr));
 501
 502             when N_In =>
 503                return
 504                  Expr_Name (Left_Opnd (Expr)) & " in " &
 505                  Expr_Name (Right_Opnd (Expr));
 506
 507             when N_Not_In =>
 508                return
 509                  Expr_Name (Left_Opnd (Expr)) & " not in " &
 510                  Expr_Name (Right_Opnd (Expr));
 511
 512             when N_Or_Else =>
 513                return
 514                  Expr_Name (Left_Opnd (Expr)) & " or else " &
 515                  Expr_Name (Right_Opnd (Expr));
 516
 517             when N_Op_And =>
 518                return
 519                  Expr_Name (Left_Opnd (Expr)) & " and " &
 520                  Expr_Name (Right_Opnd (Expr));
 521
 522             when N_Op_Or =>
 523                return
 524                  Expr_Name (Left_Opnd (Expr)) & " or " &
 525                  Expr_Name (Right_Opnd (Expr));
 526
 527             when N_Op_Xor =>
 528                return
 529                  Expr_Name (Left_Opnd (Expr)) & " xor " &
 530                  Expr_Name (Right_Opnd (Expr));
 531
 532             when N_Op_Eq =>
 533                return
 534                  Expr_Name (Left_Opnd (Expr)) & " = " &
 535                  Expr_Name (Right_Opnd (Expr));
 536
 537             when N_Op_Ne =>
 538                return
 539                  Expr_Name (Left_Opnd (Expr)) & " /= " &
 540                  Expr_Name (Right_Opnd (Expr));
 541
 542             when N_Op_Lt =>
 543                return
 544                  Expr_Name (Left_Opnd (Expr)) & " < " &
 545                  Expr_Name (Right_Opnd (Expr));
 546
 547             when N_Op_Le =>
 548                return
 549                  Expr_Name (Left_Opnd (Expr)) & " <= " &
 550                  Expr_Name (Right_Opnd (Expr));
 551
 552             when N_Op_Gt =>
 553                return
 554                  Expr_Name (Left_Opnd (Expr)) & " > " &
 555                  Expr_Name (Right_Opnd (Expr));
 556
 557             when N_Op_Ge =>
 558                return
 559                  Expr_Name (Left_Opnd (Expr)) & " >= " &
 560                  Expr_Name (Right_Opnd (Expr));
 561
 562             when N_Op_Add =>
 563                return
 564                  Expr_Name (Left_Opnd (Expr)) & " + " &
 565                  Expr_Name (Right_Opnd (Expr));
 566
 567             when N_Op_Subtract =>
 568                return
 569                  Expr_Name (Left_Opnd (Expr)) & " - " &
 570                  Expr_Name (Right_Opnd (Expr));
 571
 572             when N_Op_Multiply =>
 573                return
 574                  Expr_Name (Left_Opnd (Expr)) & " * " &
 575                  Expr_Name (Right_Opnd (Expr));
 576
 577             when N_Op_Divide =>
 578                return
 579                  Expr_Name (Left_Opnd (Expr)) & " / " &
 580                  Expr_Name (Right_Opnd (Expr));
 581
 582             when N_Op_Mod =>
 583                return
 584                  Expr_Name (Left_Opnd (Expr)) & " mod " &
 585                  Expr_Name (Right_Opnd (Expr));
 586
 587             when N_Op_Rem =>
 588                return
 589                  Expr_Name (Left_Opnd (Expr)) & " rem " &
 590                  Expr_Name (Right_Opnd (Expr));
 591
 592             when N_Op_Expon =>
 593                return
 594                  Expr_Name (Left_Opnd (Expr)) & " ** " &
 595                  Expr_Name (Right_Opnd (Expr));
 596
 597             when N_Op_Shift_Left =>
 598                return
 599                  Expr_Name (Left_Opnd (Expr)) & " << " &
 600                  Expr_Name (Right_Opnd (Expr));
 601
 602             when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
 603                return
 604                  Expr_Name (Left_Opnd (Expr)) & " >> " &
 605                  Expr_Name (Right_Opnd (Expr));
 606
 607             when N_Op_Concat =>
 608                return
 609                  Expr_Name (Left_Opnd (Expr)) & " & " &
 610                  Expr_Name (Right_Opnd (Expr));
 611
 612             when N_Op_Plus =>
 613                return "+" & Expr_Name (Right_Opnd (Expr));
 614
 615             when N_Op_Minus =>
 616                return "-" & Expr_Name (Right_Opnd (Expr));
 617
 618             when N_Op_Abs =>
 619                return "abs " & Expr_Name (Right_Opnd (Expr));
 620
 621             when N_Op_Not =>
 622                return "not (" & Expr_Name (Right_Opnd (Expr)) & ")";
 623
 624             when N_Parameter_Association =>
 625                return Expr_Name (Explicit_Actual_Parameter (Expr));
 626
 627             when N_Type_Conversion =>
 628
 629                --  Most conversions are not very interesting (used inside
 630                --  expanded checks to convert to larger ranges), so skip them.
 631
 632                return Expr_Name (Expression (Expr));
 633
 634             when N_Unchecked_Type_Conversion =>
 635
 636                --  Only keep the type conversion in complex cases
 637
 638                if not Is_Scalar_Type (Etype (Expr))
 639                  or else not Is_Scalar_Type (Etype (Expression (Expr)))
 640                  or else Is_Modular_Integer_Type (Etype (Expr)) /=
 641                            Is_Modular_Integer_Type (Etype (Expression (Expr)))
 642                then
 643                   return Expr_Name (Subtype_Mark (Expr)) &
 644                     "(" & Expr_Name (Expression (Expr)) & ")";
 645                else
 646                   return Expr_Name (Expression (Expr));
 647                end if;
 648
 649             when N_Indexed_Component =>
 650                if Take_Prefix then
 651                   return
 652                     Expr_Name (Prefix (Expr))
 653                       & List_Name (First (Sinfo.Expressions (Expr)));
 654                else
 655                   return List_Name (First (Sinfo.Expressions (Expr)));
 656                end if;
 657
 658             when N_Function_Call =>
 659
 660                --  If Default = "", it means we're expanding the name of
 661                --  a gnat temporary (and not really a function call), so add
 662                --  parentheses around function call to mark it specially.
 663
 664                if Default = "" then
 665                   return '('
 666                     & Expr_Name (Name (Expr))
 667                     & List_Name (First (Sinfo.Parameter_Associations (Expr)))
 668                     & ')';
 669                else
 670                   return
 671                     Expr_Name (Name (Expr))
 672                       & List_Name
 673                           (First (Sinfo.Parameter_Associations (Expr)));
 674                end if;
 675
 676             when N_Null =>
 677                return "null";
 678
 679             when N_Others_Choice =>
 680                return "others";
 681
 682             when others =>
 683                return "...";
 684          end case;
 685       end Expr_Name;
 686
 687    --  Start of processing for Expression_Name
 688
 689    begin
 690       if not From_Source then
 691          declare
 692             S : constant String := Expr_Name (Expr);
 693          begin
 694             if S = "..." then
 695                return Default;
 696             else
 697                return S;
 698             end if;
 699          end;
 700       end if;
 701
 702       --  Compute left (start) and right (end) slocs for the expression
 703       --  Consider using Sinput.Sloc_Range instead, except that it does not
 704       --  work properly currently???
 705
 706       loop
 707          case Nkind (Left) is
 708             when N_And_Then
 709                | N_Binary_Op
 710                | N_Membership_Test
 711                | N_Or_Else
 712             =>
 713                Left := Original_Node (Left_Opnd (Left));
 714
 715             when N_Attribute_Reference
 716                | N_Expanded_Name
 717                | N_Explicit_Dereference
 718                | N_Indexed_Component
 719                | N_Reference
 720                | N_Selected_Component
 721                | N_Slice
 722             =>
 723                Left := Original_Node (Prefix (Left));
 724
 725             when N_Defining_Program_Unit_Name
 726                | N_Designator
 727                | N_Function_Call
 728             =>
 729                Left := Original_Node (Name (Left));
 730
 731             when N_Range =>
 732                Left := Original_Node (Low_Bound (Left));
 733
 734             when N_Qualified_Expression
 735                | N_Type_Conversion
 736             =>
 737                Left := Original_Node (Subtype_Mark (Left));
 738
 739             --  For any other item, quit loop
 740
 741             when others =>
 742                exit;
 743          end case;
 744       end loop;
 745
 746       loop
 747          case Nkind (Right) is
 748             when N_And_Then
 749                | N_Membership_Test
 750                | N_Op
 751                | N_Or_Else
 752             =>
 753                Right := Original_Node (Right_Opnd (Right));
 754
 755             when N_Expanded_Name
 756                | N_Selected_Component
 757             =>
 758                Right := Original_Node (Selector_Name (Right));
 759
 760             when N_Qualified_Expression
 761                | N_Type_Conversion
 762             =>
 763                Right := Original_Node (Expression (Right));
 764
 765                --  If argument does not already account for a closing
 766                --  parenthesis, count one here.
 767
 768                if not Nkind_In (Right, N_Aggregate,
 769                                        N_Quantified_Expression)
 770                then
 771                   Append_Paren := Append_Paren + 1;
 772                end if;
 773
 774             when N_Designator =>
 775                Right := Original_Node (Identifier (Right));
 776
 777             when N_Defining_Program_Unit_Name =>
 778                Right := Original_Node (Defining_Identifier (Right));
 779
 780             when N_Range =>
 781                Right := Original_Node (High_Bound (Right));
 782
 783             when N_Parameter_Association =>
 784                Right := Original_Node (Explicit_Actual_Parameter (Right));
 785
 786             when N_Component_Association =>
 787                if Present (Expression (Right)) then
 788                   Right := Expression (Right);
 789                else
 790                   Right := Last (Choices (Right));
 791                end if;
 792
 793             when N_Indexed_Component =>
 794                Right := Original_Node (Last (Sinfo.Expressions (Right)));
 795                Append_Paren := Append_Paren + 1;
 796
 797             when N_Function_Call =>
 798                if Present (Sinfo.Parameter_Associations (Right)) then
 799                   declare
 800                      Rover : Node_Id;
 801                      Found : Boolean;
 802
 803                   begin
 804                      --  Avoid source position confusion associated with
 805                      --  parameters for which Comes_From_Source is False.
 806
 807                      Rover := First (Sinfo.Parameter_Associations (Right));
 808                      Found := False;
 809                      while Present (Rover) loop
 810                         if Comes_From_Source (Original_Node (Rover)) then
 811                            Right := Original_Node (Rover);
 812                            Found := True;
 813                         end if;
 814
 815                         Next (Rover);
 816                      end loop;
 817
 818                      if Found then
 819                         Append_Paren := Append_Paren + 1;
 820                      end if;
 821
 822                      --  Quit loop if no Comes_From_Source parameters
 823
 824                      exit when not Found;
 825                   end;
 826
 827                --  Quit loop if no parameters
 828
 829                else
 830                   exit;
 831                end if;
 832
 833             when N_Quantified_Expression =>
 834                Right        := Original_Node (Condition (Right));
 835                Append_Paren := Append_Paren + 1;
 836
 837             when N_Aggregate =>
 838                declare
 839                   Aggr : constant Node_Id := Right;
 840                   Sub  : Node_Id;
 841
 842                begin
 843                   Sub := First (Expressions (Aggr));
 844                   while Present (Sub) loop
 845                      if Sloc (Sub) > Sloc (Right) then
 846                         Right := Sub;
 847                      end if;
 848
 849                      Next (Sub);
 850                   end loop;
 851
 852                   Sub := First (Component_Associations (Aggr));
 853                   while Present (Sub) loop
 854                      if Sloc (Sub) > Sloc (Right) then
 855                         Right := Sub;
 856                      end if;
 857
 858                      Next (Sub);
 859                   end loop;
 860
 861                   exit when Right = Aggr;
 862
 863                   Append_Paren := Append_Paren + 1;
 864                end;
 865
 866             --  For all other items, quit the loop
 867
 868             when others =>
 869                exit;
 870          end case;
 871       end loop;
 872
 873       declare
 874          Scn      : Source_Ptr := Original_Location (Sloc (Left));
 875          End_Sloc : constant Source_Ptr :=
 876                       Original_Location (Sloc (Right));
 877          Src      : constant Source_Buffer_Ptr :=
 878                       Source_Text (Get_Source_File_Index (Scn));
 879
 880       begin
 881          if Scn > End_Sloc then
 882             return Default;
 883          end if;
 884
 885          declare
 886             Threshold        : constant := 256;
 887             Buffer           : String (1 .. Natural (End_Sloc - Scn));
 888             Index            : Natural := 0;
 889             Skipping_Comment : Boolean := False;
 890             Underscore       : Boolean := False;
 891
 892          begin
 893             if Right /= Expr then
 894                while Scn < End_Sloc loop
 895                   case Src (Scn) is
 896
 897                      --  Give up on non ASCII characters
 898
 899                      when Character'Val (128) .. Character'Last =>
 900                         Append_Paren := 0;
 901                         Index := 0;
 902                         Right := Expr;
 903                         exit;
 904
 905                      when ' '
 906                         | ASCII.HT
 907                      =>
 908                         if not Skipping_Comment and then not Underscore then
 909                            Underscore := True;
 910                            Index := Index + 1;
 911                            Buffer (Index) := ' ';
 912                         end if;
 913
 914                      --  CR/LF/FF is the end of any comment
 915
 916                      when ASCII.CR
 917                         | ASCII.FF
 918                         | ASCII.LF
 919                      =>
 920                         Skipping_Comment := False;
 921
 922                      when others =>
 923                         Underscore := False;
 924
 925                         if not Skipping_Comment then
 926
 927                            --  Ignore comment
 928
 929                            if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
 930                               Skipping_Comment := True;
 931
 932                            else
 933                               Index := Index + 1;
 934                               Buffer (Index) := Src (Scn);
 935                            end if;
 936                         end if;
 937                   end case;
 938
 939                   --  Give up on too long strings
 940
 941                   if Index >= Threshold then
 942                      return Buffer (1 .. Index) & "...";
 943                   end if;
 944
 945                   Scn := Scn + 1;
 946                end loop;
 947             end if;
 948
 949             if Index < 1 then
 950                declare
 951                   S : constant String := Expr_Name (Right);
 952                begin
 953                   if S = "..." then
 954                      return Default;
 955                   else
 956                      return S;
 957                   end if;
 958                end;
 959
 960             else
 961                return
 962                  Buffer (1 .. Index)
 963                    & Expr_Name (Right, False)
 964                    & (1 .. Append_Paren => ')');
 965             end if;
 966          end;
 967       end;
 968    end Expression_Image;
 969
 970 end Pprint;