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