gcc/ada/pprint.adb

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