path: root/gcc-4.9/gcc/ada/pprint.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               P P R I N T                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2008-2012, 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 Namet;   use Namet;
with Nlists;  use Nlists;
with Opt;     use Opt;
with Sinfo;   use Sinfo;
with Sinput;  use Sinput;
with Snames;  use Snames;
with Uintp;   use Uintp;

package body Pprint is

   List_Name_Count : Integer := 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
      Left         : Node_Id := Original_Node (Expr);
      Right        : Node_Id := Original_Node (Expr);
      From_Source  : constant Boolean :=
        Comes_From_Source (Expr) and then not Opt.Debug_Generated_Code;
      Append_Paren : Boolean := False;

      function Expr_Name
        (Expr        : Node_Id;
         Take_Prefix : Boolean := True;
         Expand_Type : Boolean := True) 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.

      Max_List : constant := 3;
      --  Limit number of list elements to dump

      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      : Node_Id;
         Add_Space : Boolean := True;
         Add_Paren : Boolean := True) return String;
      --  Return a string corresponding to List

      function List_Name
        (List      : Node_Id;
         Add_Space : Boolean := True;
         Add_Paren : Boolean := True) return String
      is
         function Internal_List_Name
           (List      : Node_Id;
            First     : Boolean := True;
            Add_Space : Boolean := True;
            Add_Paren : Boolean := True;
            Num       : Natural := 1) return String;

         ------------------------
         -- Internal_List_Name --
         ------------------------

         function Internal_List_Name
           (List      : Node_Id;
            First     : Boolean := True;
            Add_Space : Boolean := True;
            Add_Paren : Boolean := True;
            Num       : Natural := 1) return String
         is
            function Prepend (S : String) return String;

            -------------
            -- Prepend --
            -------------

            function Prepend (S : String) return String is
            begin
               if Add_Space then
                  if Add_Paren then
                     return " (" & S;
                  else
                     return ' ' & S;
                  end if;
               elsif Add_Paren then
                  return '(' & S;
               else
                  return S;
               end if;
            end Prepend;

         --  Start of processing for Internal_List_Name

         begin
            if not Present (List) then
               if First or else not Add_Paren then
                  return "";
               else
                  return ")";
               end if;
            elsif Num > Max_List then
               if Add_Paren then
                  return ", ...)";
               else
                  return ", ...";
               end if;
            end if;

            if First then
               return Prepend
                 (Expr_Name (List)
                  & Internal_List_Name (Next (List),
                    First     => False,
                    Add_Paren => Add_Paren,
                    Num       => Num + 1));
            else
               return ", " & Expr_Name (List) &
                 Internal_List_Name
                 (Next (List),
                  First     => False,
                  Add_Paren => Add_Paren,
                  Num       => Num + 1);
            end if;
         end Internal_List_Name;

      --  Start of processing for List_Name

      begin
         --  Prevent infinite recursion by limiting depth to 3

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

         List_Name_Count := List_Name_Count + 1;
         declare
            Result : constant String :=
              Internal_List_Name
                (List, Add_Space => Add_Space, Add_Paren => Add_Paren);
         begin
            List_Name_Count := List_Name_Count - 1;
            return Result;
         end;
      end List_Name;

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

      function Expr_Name
        (Expr        : Node_Id;
         Take_Prefix : Boolean := True;
         Expand_Type : Boolean := True) return String
      is
      begin
         Num_Elements := Num_Elements + 1;

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

         case Nkind (Expr) is
            when N_Defining_Identifier | 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 .. 127 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 =>
               UI_Image (Intval (Expr));
               return UI_Image_Buffer (1 .. UI_Image_Length);

            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 (Sinfo.Expressions (Expr)) then
                  return List_Name
                    (First (Sinfo.Expressions (Expr)), Add_Space => False);

               elsif Null_Record_Present (Expr) then
                  return ("(null record)");

               else
                  return List_Name
                    (First (Component_Associations (Expr)),
                     Add_Space => False, Add_Paren => False);
               end if;

            when N_Extension_Aggregate =>
               return "(" & Expr_Name (Ancestor_Part (Expr)) &
                 " with " &
                 List_Name (First (Sinfo.Expressions (Expr)),
                            Add_Space => False, Add_Paren => False) &
                 ")";

            when N_Attribute_Reference =>
               if Take_Prefix then
                  declare
                     Str    : constant String := Expr_Name (Prefix (Expr))
                       & "'" & Get_Name_String (Attribute_Name (Expr));
                     Id     : constant Attribute_Id :=
                       Get_Attribute_Id (Attribute_Name (Expr));
                     Ranges : List_Id;
                     N      : Node_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_In
                                  (First (Ranges),
                                   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 =>
               if Take_Prefix then
                  return Expr_Name (Prefix (Expr)) & ".all";
               else
                  return ".all";
               end if;

            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_Component_Association =>
               return "("
                 & List_Name (First (Choices (Expr)),
                              Add_Space => False, Add_Paren => False)
                 & " => " & Expr_Name (Expression (Expr)) & ")";

            when N_If_Expression =>
               declare
                  N : constant Node_Id := First (Sinfo.Expressions (Expr));
               begin
                  return "if " & Expr_Name (N) & " then " &
                    Expr_Name (Next (N)) & " else " &
                    Expr_Name (Next (Next (N)));
               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_Unchecked_Expression | 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_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)) & ")";

            when N_Parameter_Association =>
               return Expr_Name (Explicit_Actual_Parameter (Expr));

            when N_Type_Conversion | N_Unchecked_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_Indexed_Component =>
               if Take_Prefix then
                  return Expr_Name (Prefix (Expr)) &
                    List_Name (First (Sinfo.Expressions (Expr)));
               else
                  return List_Name (First (Sinfo.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
                  return '(' & Expr_Name (Name (Expr)) &
                    List_Name (First (Sinfo.Parameter_Associations (Expr))) &
                      ')';
               else
                  return Expr_Name (Name (Expr)) &
                    List_Name (First (Sinfo.Parameter_Associations (Expr)));
               end if;

            when N_Null =>
               return "null";

            when N_Others_Choice =>
               return "others";

            when others =>
               return "...";
         end case;
      end Expr_Name;

   --  Start of processing for Expression_Name

   begin
      if not From_Source then
         declare
            S : constant String := Expr_Name (Expr);
         begin
            if S = "..." then
               return Default;
            else
               return S;
            end if;
         end;
      end if;

      --  Compute left (start) and right (end) slocs for the expression
      --  Consider using Sinput.Sloc_Range instead, except that it does not
      --  work properly currently???

      loop
         case Nkind (Left) is
            when N_Binary_Op | N_Membership_Test |
                 N_And_Then  | N_Or_Else         =>
               Left := Original_Node (Left_Opnd (Left));

            when N_Attribute_Reference  | N_Expanded_Name      |
                 N_Explicit_Dereference | N_Indexed_Component  |
                 N_Reference            | N_Selected_Component |
                 N_Slice                                       =>
               Left := Original_Node (Prefix (Left));

            when N_Designator | N_Defining_Program_Unit_Name |
                 N_Function_Call                             =>
               Left := Original_Node (Name (Left));

            when N_Range =>
               Left := Original_Node (Low_Bound (Left));

            when N_Type_Conversion =>
               Left := Original_Node (Subtype_Mark (Left));

            --  For any other item, quit loop

            when others =>
               exit;
         end case;
      end loop;

      loop
         case Nkind (Right) is
            when N_Op       | N_Membership_Test |
                 N_And_Then | N_Or_Else         =>
               Right := Original_Node (Right_Opnd (Right));

            when N_Selected_Component | N_Expanded_Name =>
               Right := Original_Node (Selector_Name (Right));

            when N_Designator =>
               Right := Original_Node (Identifier (Right));

            when N_Defining_Program_Unit_Name =>
               Right := Original_Node (Defining_Identifier (Right));

            when N_Range =>
               Right := Original_Node (High_Bound (Right));

            when N_Parameter_Association =>
               Right := Original_Node (Explicit_Actual_Parameter (Right));

            when N_Indexed_Component =>
               Right := Original_Node (Last (Sinfo.Expressions (Right)));
               Append_Paren := True;

            when N_Function_Call =>
               if Present (Sinfo.Parameter_Associations (Right)) then
                  Right :=
                    Original_Node
                      (Last (Sinfo.Parameter_Associations (Right)));
                  Append_Paren := True;

               --  Quit loop if no named associations

               else
                  exit;
               end if;

            --  For all other items, quit the loop

            when others =>
               exit;
         end case;
      end loop;

      declare
         Scn      : Source_Ptr := Original_Location (Sloc (Left));
         Src      : constant Source_Buffer_Ptr :=
           Source_Text (Get_Source_File_Index (Scn));
         End_Sloc : constant Source_Ptr :=
           Original_Location (Sloc (Right));

      begin
         if Scn > End_Sloc then
            return Default;
         end if;

         declare
            Buffer           : String (1 .. Natural (End_Sloc - Scn));
            Skipping_Comment : Boolean := False;
            Underscore       : Boolean := False;
            Index            : Natural := 0;

         begin
            if Right /= Expr then
               while Scn < End_Sloc loop
                  case Src (Scn) is
                  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.LF | ASCII.CR | ASCII.FF =>
                     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;

                  Scn := Scn + 1;
               end loop;
            end if;

            if Index < 1 then
               declare
                  S : constant String := Expr_Name (Right);
               begin
                  if S = "..." then
                     return Default;
                  else
                     return S;
                  end if;
               end;

            elsif Append_Paren then
               return Buffer (1 .. Index) & Expr_Name (Right, False) & ')';

            else
               return Buffer (1 .. Index) & Expr_Name (Right, False);
            end if;
         end;
      end;
   end Expression_Image;

end Pprint;