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