------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               P P R I N T                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2008-2025, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;          use Atree;
with Einfo;          use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils;    use Einfo.Utils;
with Errout;         use Errout;
with Namet;          use Namet;
with Nlists;         use Nlists;
with Opt;            use Opt;
with Sinfo;          use Sinfo;
with Sinfo.Nodes;    use Sinfo.Nodes;
with Sinfo.Utils;    use Sinfo.Utils;
with Sinput;         use Sinput;
with Snames;         use Snames;
with Uintp;          use Uintp;

with System.Case_Util;

package body Pprint is

   List_Name_Count : Natural := 0;
   --  Counter used to prevent infinite recursion while computing name of
   --  complex expressions.

   ----------------------
   -- Expression_Image --
   ----------------------

   function Expression_Image
     (Expr    : Node_Id;
      Default : String) return String
   is
      function Expr_Name
        (Expr        : Node_Id;
         Take_Prefix : Boolean := True;
         Expand_Type : Boolean := True;
         No_Parens   : Boolean := False) return String;
      --  Return string corresponding to Expr. If no string can be extracted,
      --  return "...". If Take_Prefix is True, go back to prefix when needed,
      --  otherwise only consider the right-hand side of an expression. If
      --  Expand_Type is True and Expr is a type, try to expand Expr (an
      --  internally generated type) into a user understandable name.
      --  If No_Parens is True, then suppress creating parentheses around
      --  expression. If False, check to see whether expression should be
      --  parenthesized.

      function Count_Parentheses (S : String; C : Character) return Natural
        with Pre => C in '(' | ')';
      --  Returns the number of times parenthesis character C should be added
      --  to string S for getting a correctly parenthesized result. For C = '('
      --  this means prepending the character, for C = ')' this means appending
      --  the character.
      --  In other words, count the number of missing instances of C,
      --  but never return less than zero.

      function Fix_Parentheses (S : String) return String;
      --  Counts the number of required opening and closing parentheses in S to
      --  respectively prepend and append for getting correct parentheses. Then
      --  returns S with opening parentheses prepended and closing parentheses
      --  appended so that the result is correctly parenthesized.

      Max_List_Depth : constant := 3;
      --  Limit number of nested lists to print

      Max_List_Length : constant := 3;
      --  Limit number of list elements to print

      Max_Expr_Elements : constant := 24;
      --  Limit number of elements in an expression for use by Expr_Name

      Num_Elements : Natural := 0;
      --  Current number of elements processed by Expr_Name

      function List_Name (List : List_Id) return String;
      --  Return a string corresponding to List

      ---------------
      -- List_Name --
      ---------------

      function List_Name (List : List_Id) return String is
         Buf  : Bounded_String;
         Elmt : Node_Id;

         Printed_Elmts : Natural := 0;
         List_Len : constant Natural := Natural (List_Length (List));

      begin
         --  Give up if the printed list is too deep

         if List_Name_Count > Max_List_Depth then
            return "...";
         end if;

         List_Name_Count := List_Name_Count + 1;

         Elmt := First (List);
         while Present (Elmt) loop

            --  Print component_association as "x | y | z => 12345"

            if Nkind (Elmt) = N_Component_Association then
               declare
                  Choice : Node_Id := First (Choices (Elmt));
               begin
                  while Present (Choice) loop
                     Append (Buf, Expr_Name (Choice));
                     Next (Choice);

                     if Present (Choice) then
                        Append (Buf, " | ");
                     end if;
                  end loop;
               end;
               Append (Buf, " => ");
               if Box_Present (Elmt) then
                  Append (Buf, "<>");
               else
                  Append (Buf, Expr_Name (Expression (Elmt)));
               end if;

            --  Print parameter_association as "x => 12345"

            elsif Nkind (Elmt) = N_Parameter_Association then
               Append (Buf, Expr_Name (Selector_Name (Elmt)));
               Append (Buf, " => ");
               Append (Buf, Expr_Name (Explicit_Actual_Parameter (Elmt)));

            --  Print expression itself as "12345"

            else
               --  Suppress parens if is the only parameter
               Append (Buf, Expr_Name (Elmt, No_Parens => List_Len = 1));
            end if;

            Next (Elmt);
            Printed_Elmts := Printed_Elmts + 1;

            --  Separate next element with a comma, if necessary

            if Present (Elmt) then
               Append (Buf, ", ");

               --  Abbreviate remaining elements as "...", if limit exceeded

               if Printed_Elmts = Max_List_Length then
                  Append (Buf, "...");
                  exit;
               end if;
            end if;
         end loop;

         List_Name_Count := List_Name_Count - 1;

         return To_String (Buf);
      end List_Name;

      ---------------
      -- Expr_Name --
      ---------------

      function Expr_Name
        (Expr        : Node_Id;
         Take_Prefix : Boolean := True;
         Expand_Type : Boolean := True;
         No_Parens   : Boolean := False) return String
      is
         --  Define a subtype matching logical operations
         --  and [then], or [else], and xor.
         --  In Ada, these operations are non associative -- they
         --  all have the same precedence, so parentheses
         --  are needed to indicate the association of
         --  operands in a sequence of distinct operations.
         subtype Non_Associative is N_Subexpr
           with Static_Predicate =>
             Non_Associative in
               N_Short_Circuit | N_Op_And | N_Op_Or | N_Op_Xor;
      begin
         if not No_Parens
          and then
            (Paren_Count (Expr) > 0
              or else
             (Nkind (Expr) in Non_Associative
               and then
              Nkind (Parent (Expr)) in Non_Associative
               and then
              Nkind (Parent (Expr)) /= Nkind (Expr)))
         then
            --  Parentheses are needed, either because
            --  Paren_Count is greater than zero, or because
            --  this operation and its parent are non associative,
            --  and are not the same operation.
            return '(' &
              Expr_Name (Expr, Take_Prefix, Expand_Type, No_Parens => True) &
              ')';
         end if;

         Num_Elements := Num_Elements + 1;

         if Num_Elements > Max_Expr_Elements then
            return "...";
         end if;

         --  Just print pieces of aggregate nodes, even though they are not
         --  expressions. It is too much trouble to handle them any better.

         if Nkind (Expr) = N_Component_Association then

            pragma Assert (Box_Present (Expr));

            declare
               Buf    : Bounded_String;
               Choice : Node_Id := First (Choices (Expr));
            begin
               while Present (Choice) loop
                  Append (Buf, Expr_Name (Choice));
                  Next (Choice);

                  if Present (Choice) then
                     Append (Buf, " | ");
                  end if;
               end loop;

               Append (Buf, " => <>");

               return To_String (Buf);
            end;

         elsif Nkind (Expr) = N_Others_Choice then
            return "others";
         end if;

         case N_Subexpr'(Nkind (Expr)) is
            when N_Identifier =>
               return Ident_Image (Expr, Expression_Image.Expr, Expand_Type);

            when N_Character_Literal =>
               declare
                  Char : constant Int := UI_To_Int (Char_Literal_Value (Expr));
               begin
                  if Char in 32 .. 126 then
                     return "'" & Character'Val (Char) & "'";
                  else
                     UI_Image (Char_Literal_Value (Expr));
                     return
                       "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'";
                  end if;
               end;

            when N_Integer_Literal =>
               return UI_Image (Intval (Expr));

            when N_Real_Literal =>
               return Real_Image (Realval (Expr));

            when N_String_Literal =>
               return String_Image (Strval (Expr));

            when N_Allocator =>
               return "new " & Expr_Name (Expression (Expr));

            when N_Aggregate =>
               if Present (Expressions (Expr)) then
                  return '(' & List_Name (Expressions (Expr)) & ')';

               --  Do not return empty string for (others => <>) aggregate
               --  of a componentless record type. At least one caller (the
               --  recursive call below in the N_Qualified_Expression case)
               --  is not prepared to deal with a zero-length result.

               elsif Null_Record_Present (Expr)
                 or else No (First (Component_Associations (Expr)))
               then
                  return ("(null record)");

               else
                  return '(' & List_Name (Component_Associations (Expr)) & ')';
               end if;

            when N_Extension_Aggregate =>
               return '(' & Expr_Name (Ancestor_Part (Expr))
                 & " with (" & List_Name (Expressions (Expr)) & ')';

            when N_Attribute_Reference =>
               if Take_Prefix then
                  declare
                     Id : constant Attribute_Id :=
                            Get_Attribute_Id (Attribute_Name (Expr));

                     --  Always use mixed case for attributes

                     Str : constant String :=
                             Expr_Name (Prefix (Expr))
                               & "'"
                               & System.Case_Util.To_Mixed
                                   (Get_Name_String (Attribute_Name (Expr)));

                     N      : Node_Id;
                     Ranges : List_Id;

                  begin
                     if (Id = Attribute_First or else Id = Attribute_Last)
                       and then Str (Str'First) = '$'
                     then
                        N := Associated_Node_For_Itype (Etype (Prefix (Expr)));

                        if Present (N) then
                           if Nkind (N) = N_Full_Type_Declaration then
                              N := Type_Definition (N);
                           end if;

                           if Nkind (N) = N_Subtype_Declaration then
                              Ranges :=
                                Constraints
                                  (Constraint (Subtype_Indication (N)));

                              if List_Length (Ranges) = 1
                                and then Nkind (First (Ranges)) in
                                           N_Range                          |
                                           N_Real_Range_Specification       |
                                           N_Signed_Integer_Type_Definition
                              then
                                 if Id = Attribute_First then
                                    return
                                      Expression_Image
                                        (Low_Bound (First (Ranges)), Str);
                                 else
                                    return
                                      Expression_Image
                                        (High_Bound (First (Ranges)), Str);
                                 end if;
                              end if;
                           end if;
                        end if;
                     end if;

                     return Str;
                  end;
               else
                  return ''' & Get_Name_String (Attribute_Name (Expr));
               end if;

            when N_Explicit_Dereference =>
               Explicit_Dereference : declare
                  function Deref_Suffix return String;
                  --  Usually returns ".all", but will return "" if
                  --  Hide_Temp_Derefs is true and the prefix is a use of a
                  --  not-from-source object declared as
                  --    X : constant Some_Access_Type := Some_Expr'Reference;
                  --  (as is sometimes done in Exp_Util.Remove_Side_Effects).

                  ------------------
                  -- Deref_Suffix --
                  ------------------

                  function Deref_Suffix return String is
                     Decl : Node_Id;

                  begin
                     if Hide_Temp_Derefs
                       and then Nkind (Prefix (Expr)) = N_Identifier
                       and then Nkind (Entity (Prefix (Expr))) =
                                  N_Defining_Identifier
                     then
                        Decl := Parent (Entity (Prefix (Expr)));

                        if Present (Decl)
                          and then Nkind (Decl) = N_Object_Declaration
                          and then not Comes_From_Source (Decl)
                          and then Constant_Present (Decl)
                          and then Present (Expression (Decl))
                          and then Nkind (Expression (Decl)) = N_Reference
                        then
                           return "";
                        end if;
                     end if;

                     --  The default case

                     return ".all";
                  end Deref_Suffix;

               --  Start of processing for Explicit_Dereference

               begin
                  if Hide_Parameter_Blocks
                    and then Nkind (Prefix (Expr)) = N_Selected_Component
                    and then Present (Etype (Prefix (Expr)))
                    and then Is_Access_Type (Etype (Prefix (Expr)))
                    and then Is_Param_Block_Component_Type
                               (Etype (Prefix (Expr)))
                  then
                     --  Return "Foo" instead of "Parameter_Block.Foo.all"

                     return Expr_Name (Selector_Name (Prefix (Expr)));

                  elsif Take_Prefix then
                     return Expr_Name (Prefix (Expr)) & Deref_Suffix;
                  else
                     return Deref_Suffix;
                  end if;
               end Explicit_Dereference;

            when N_Expanded_Name
               | N_Selected_Component
            =>
               if Take_Prefix then
                  return
                    Expr_Name (Prefix (Expr)) & "." &
                    Expr_Name (Selector_Name (Expr));
               else
                  return "." & Expr_Name (Selector_Name (Expr));
               end if;

            when N_If_Expression =>
               declare
                  Cond_Expr : constant Node_Id := First (Expressions (Expr));
                  Then_Expr : constant Node_Id := Next (Cond_Expr);
                  Else_Expr : constant Node_Id := Next (Then_Expr);
               begin
                  return
                    "if " & Expr_Name (Cond_Expr) & " then "
                      & Expr_Name (Then_Expr) & " else "
                      & Expr_Name (Else_Expr);
               end;

            when N_Qualified_Expression =>
               declare
                  Mark : constant String :=
                           Expr_Name
                             (Subtype_Mark (Expr), Expand_Type => False);
                  Str  : constant String := Expr_Name (Expression (Expr));
               begin
                  if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
                     return Mark & "'" & Str;
                  else
                     return Mark & "'(" & Str & ")";
                  end if;
               end;

            when N_Expression_With_Actions =>
               return Expr_Name (Expression (Expr));

            when N_Raise_Constraint_Error =>
               if Present (Condition (Expr)) then
                  return
                    "[constraint_error when "
                      & Expr_Name (Condition (Expr)) & "]";
               else
                  return "[constraint_error]";
               end if;

            when N_Raise_Program_Error =>
               if Present (Condition (Expr)) then
                  return
                    "[program_error when "
                      & Expr_Name (Condition (Expr)) & "]";
               else
                  return "[program_error]";
               end if;

            when N_Raise_Storage_Error =>
               if Present (Condition (Expr)) then
                  return
                    "[storage_error when "
                      & Expr_Name (Condition (Expr)) & "]";
               else
                  return "[storage_error]";
               end if;

            when N_Range =>
               return
                 Expr_Name (Low_Bound (Expr)) & ".." &
                 Expr_Name (High_Bound (Expr));

            when N_Slice =>
               return
                 Expr_Name (Prefix (Expr)) & " (" &
                 Expr_Name (Discrete_Range (Expr)) & ")";

            when N_And_Then =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " and then " &
                 Expr_Name (Right_Opnd (Expr));

            when N_In =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " in " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Not_In =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " not in " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Or_Else =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " or else " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_And =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " and " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Or =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " or " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Xor =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " xor " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Eq =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " = " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Ne =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " /= " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Lt =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " < " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Le =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " <= " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Gt =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " > " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Ge =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " >= " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Add =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " + " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Subtract =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " - " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Multiply =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " * " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Divide =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " / " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Mod =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " mod " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Rem =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " rem " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Expon =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " ** " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Shift_Left =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " << " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " >> " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Concat =>
               return
                 Expr_Name (Left_Opnd (Expr)) & " & " &
                 Expr_Name (Right_Opnd (Expr));

            when N_Op_Plus =>
               return "+" & Expr_Name (Right_Opnd (Expr));

            when N_Op_Minus =>
               return "-" & Expr_Name (Right_Opnd (Expr));

            when N_Op_Abs =>
               return "abs " & Expr_Name (Right_Opnd (Expr));

            when N_Op_Not =>
               return "not (" &
                      Expr_Name (Right_Opnd (Expr), No_Parens => True) &
                      ")";

            when N_Type_Conversion =>

               --  Most conversions are not very interesting (used inside
               --  expanded checks to convert to larger ranges), so skip them.

               return Expr_Name (Expression (Expr));

            when N_Unchecked_Type_Conversion =>

               --  Only keep the type conversion in complex cases

               if not Is_Scalar_Type (Etype (Expr))
                 or else not Is_Scalar_Type (Etype (Expression (Expr)))
                 or else Is_Modular_Integer_Type (Etype (Expr)) /=
                           Is_Modular_Integer_Type (Etype (Expression (Expr)))
               then
                  return Expr_Name (Subtype_Mark (Expr)) &
                    "(" &
                    Expr_Name (Expression (Expr), No_Parens => True) &
                    ")";
               else
                  return Expr_Name (Expression (Expr));
               end if;

            when N_Indexed_Component =>
               if Take_Prefix then
                  return
                    Expr_Name (Prefix (Expr))
                      & " (" & List_Name (Expressions (Expr)) & ')';
               else
                  return List_Name (Expressions (Expr));
               end if;

            when N_Function_Call =>

               --  If Default = "", it means we're expanding the name of
               --  a gnat temporary (and not really a function call), so add
               --  parentheses around function call to mark it specially.

               if Default = "" then
                  if Present (Parameter_Associations (Expr)) then
                     return '('
                       & Expr_Name (Name (Expr))
                       & " ("
                       & List_Name (Parameter_Associations (Expr))
                       & "))";
                  else
                     return '(' &
                             Expr_Name (Name (Expr), No_Parens => True) &
                             ')';
                  end if;
               elsif Present (Parameter_Associations (Expr)) then
                  return
                    Expr_Name (Name (Expr))
                      & " (" & List_Name (Parameter_Associations (Expr)) & ')';
               else
                  return Expr_Name (Name (Expr));
               end if;

            when N_Null =>
               return "null";

            when N_Case_Expression
               | N_Delta_Aggregate
               | N_External_Initializer
               | N_Interpolated_String_Literal
               | N_Op_Rotate_Left
               | N_Op_Rotate_Right
               | N_Operator_Symbol
               | N_Procedure_Call_Statement
               | N_Quantified_Expression
               | N_Raise_Expression
               | N_Reference
               | N_Target_Name
            =>
               return "...";
         end case;
      end Expr_Name;

      -----------------------
      -- Count_Parentheses --
      -----------------------

      function Count_Parentheses (S : String; C : Character) return Natural is

         procedure Next_Char (Count : in out Natural; C, D, Ch : Character);
         --  Process next character Ch and update the number Count of C
         --  characters to add for correct parenthesizing, where D is the
         --  opposite parenthesis.
         --  In other words, count the number of missing instances of C,
         --  or equivalently, the number of unmatched instances of D.

         ---------------
         -- Next_Char --
         ---------------

         procedure Next_Char (Count : in out Natural; C, D, Ch : Character) is
         begin
            if Ch = D then
               Count := Count + 1;
            elsif Ch = C and then Count > 0 then
               Count := Count - 1;
            end if;
         end Next_Char;

         --  Local variables

         Count : Natural := 0;

      --  Start of processing for Count_Parentheses

      begin
         if C = '(' then
            for Ch of reverse S loop
               Next_Char (Count, C, ')', Ch);
            end loop;
         else
            for Ch of S loop
               Next_Char (Count, C, '(', Ch);
            end loop;
         end if;

         return Count;
      end Count_Parentheses;

      ---------------------
      -- Fix_Parentheses --
      ---------------------

      function Fix_Parentheses (S : String) return String is
         Count_Open  : constant Natural := Count_Parentheses (S, '(');
         Count_Close : constant Natural := Count_Parentheses (S, ')');
      begin
         return (1 .. Count_Open => '(') & S & (1 .. Count_Close => ')');
      end Fix_Parentheses;

      --  Local variables

      Left, Right : Source_Ptr;

   --  Start of processing for Expression_Image

   begin
      --  Since this is an expression pretty-printer, it should not be called
      --  for anything but an expression. However, currently CodePeer calls
      --  it for defining identifiers. This should be fixed in the CodePeer
      --  itself, but for now simply return the default (if present) or print
      --  name of the defining identifier.

      if Nkind (Expr) = N_Defining_Identifier then
         pragma Assert (CodePeer_Mode);
         if Comes_From_Source (Expr)
           or else Opt.Debug_Generated_Code
         then
            if Default = "" then
               declare
                  Nam : constant Name_Id := Chars (Expr);
                  Buf : Bounded_String
                    (Max_Length => Natural (Length_Of_Name (Nam)));
               begin
                  Adjust_Name_Case (Buf, Sloc (Expr));
                  Append (Buf, Nam);
                  return To_String (Buf);
               end;
            else
               return Default;
            end if;
         else
            declare
               S : constant String :=
                 Ident_Image
                   (Expr => Expr, Orig_Expr => Expr, Expand_Type => True);
            begin
               if S = "..." then
                  return Default;
               else
                  return S;
               end if;
            end;
         end if;
      else
         pragma Assert (Nkind (Expr) in N_Subexpr);
      end if;

      --  ??? The following should be primarily needed for CodePeer

      if not Comes_From_Source (Expr)
        or else Opt.Debug_Generated_Code
      then
         declare
            S : constant String := Expr_Name (Expr, No_Parens => True);
         begin
            if S = "..." then
               return Default;
            else
               return S;
            end if;
         end;
      end if;

      --  Reach to the underlying expression for an expression-with-actions

      if Nkind (Expr) = N_Expression_With_Actions then
         return Expression_Image (Expression (Expr), Default);
      end if;

      --  Compute left (start) and right (end) slocs for the expression

      Left  := First_Sloc (Expr);
      Right := Last_Sloc (Expr);

      if Left > Right then
         return Default;
      end if;

      declare
         Scn : Source_Ptr := Left;
         Src : constant not null Source_Buffer_Ptr :=
           Source_Text (Get_Source_File_Index (Scn));

         Threshold        : constant := 256;
         Buffer           : String (1 .. Natural (Right - Left + 1));
         Index            : Natural := 0;
         Skipping_Comment : Boolean := False;
         Underscore       : Boolean := False;
      begin
         while Scn <= Right loop
            case Src (Scn) is

               --  Give up on non ASCII characters

               when Character'Val (128) .. Character'Last =>
                  Index := 0;
                  exit;

               when ' '
                  | ASCII.HT
               =>
                  if not Skipping_Comment and then not Underscore then
                     Underscore := True;
                     Index := Index + 1;
                     Buffer (Index) := ' ';
                  end if;

               --  CR/LF/FF is the end of any comment

               when ASCII.CR
                  | ASCII.FF
                  | ASCII.LF
               =>
                  Skipping_Comment := False;

               when others =>
                  Underscore := False;

                  if not Skipping_Comment then

                     --  Ignore comment

                     if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
                        Skipping_Comment := True;
                     else
                        Index := Index + 1;
                        Buffer (Index) := Src (Scn);
                     end if;
                  end if;
            end case;

            --  Give up on too long strings

            if Index >= Threshold then
               return Buffer (1 .. Index) & "...";
            end if;

            Scn := Scn + 1;
         end loop;

         return Fix_Parentheses (Buffer (1 .. Index));
      end;
   end Expression_Image;

end Pprint;