Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                                B U T I L                                 --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2007, 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 Output;   use Output;

with Targparm; use Targparm;

package body Butil is

   ----------------------

   -- Is_Internal_Unit --

   ----------------------

   --  Note: the reason we do not use the Fname package for this function

   --  is that it would drag too much junk into the binder.

   function Is_Internal_Unit return Boolean is

   begin

      return Is_Predefined_Unit

        or else (Name_Len > 4

                   and then (Name_Buffer (1 .. 5) = "gnat%"

                               or else

                             Name_Buffer (1 .. 5) = "gnat."))

        or else

          (OpenVMS_On_Target

           and then Name_Len > 3

           and then (Name_Buffer (1 .. 4) = "dec%"

                      or else

                     Name_Buffer (1 .. 4) = "dec."));

   end Is_Internal_Unit;

   ------------------------

   -- Is_Predefined_Unit --

   ------------------------

   --  Note: the reason we do not use the Fname package for this function

   --  is that it would drag too much junk into the binder.

   function Is_Predefined_Unit return Boolean is

   begin

      return    (Name_Len >  3

                  and then Name_Buffer (1 ..  4) = "ada.")

        or else (Name_Len >  6

                  and then Name_Buffer (1 ..  7) = "system.")

        or else (Name_Len > 10

                   and then Name_Buffer (1 .. 11) = "interfaces.")

        or else (Name_Len >  3

                   and then Name_Buffer (1 ..  4) = "ada%")

        or else (Name_Len >  8

                   and then Name_Buffer (1 ..  9) = "calendar%")

        or else (Name_Len >  9

                   and then Name_Buffer (1 .. 10) = "direct_io%")

        or else (Name_Len > 10

                   and then Name_Buffer (1 .. 11) = "interfaces%")

        or else (Name_Len > 13

                   and then Name_Buffer (1 .. 14) = "io_exceptions%")

        or else (Name_Len > 12

                   and then Name_Buffer (1 .. 13) = "machine_code%")

        or else (Name_Len > 13

                   and then Name_Buffer (1 .. 14) = "sequential_io%")

        or else (Name_Len >  6

                   and then Name_Buffer (1 ..  7) = "system%")

        or else (Name_Len >  7

                   and then Name_Buffer (1 ..  8) = "text_io%")

        or else (Name_Len > 20

                   and then Name_Buffer (1 .. 21) = "unchecked_conversion%")

        or else (Name_Len > 22

                   and then Name_Buffer (1 .. 23) = "unchecked_deallocation%")

        or else (Name_Len > 4

                   and then Name_Buffer (1 .. 5) = "gnat%")

        or else (Name_Len > 4

                   and then Name_Buffer (1 .. 5) = "gnat.");

   end Is_Predefined_Unit;

   ----------------

   -- Uname_Less --

   ----------------

   function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is

   begin

      Get_Name_String (U1);

      declare

         U1_Name : constant String (1 .. Name_Len) :=

                                           Name_Buffer (1 .. Name_Len);

         Min_Length : Natural;

      begin

         Get_Name_String (U2);

         if Name_Len < U1_Name'Last then

            Min_Length := Name_Len;

         else

            Min_Length := U1_Name'Last;

         end if;

         for I in 1 .. Min_Length loop

            if U1_Name (I) > Name_Buffer (I) then

               return False;

            elsif U1_Name (I) < Name_Buffer (I) then

               return True;

            end if;

         end loop;

         return U1_Name'Last < Name_Len;

      end;

   end Uname_Less;

   ---------------------

   -- Write_Unit_Name --

   ---------------------

   procedure Write_Unit_Name (U : Unit_Name_Type) is

   begin

      Get_Name_String (U);

      Write_Str (Name_Buffer (1 .. Name_Len - 2));

      if Name_Buffer (Name_Len) = 's' then

         Write_Str (" (spec)");

      else

         Write_Str (" (body)");

      end if;

      Name_Len := Name_Len + 5;

   end Write_Unit_Name;

end Butil;