gcc/ada/butil.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                B U T I L                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Output;   use Output;
  28 with Targparm; use Targparm;
  29
  30 package body Butil is
  31
  32    ----------------------
  33    -- Is_Internal_Unit --
  34    ----------------------
  35
  36    --  Note: the reason we do not use the Fname package for this function
  37    --  is that it would drag too much junk into the binder.
  38
  39    function Is_Internal_Unit return Boolean is
  40    begin
  41       return Is_Predefined_Unit
  42         or else (Name_Len > 4
  43                    and then (Name_Buffer (1 .. 5) = "gnat%"
  44                                or else
  45                              Name_Buffer (1 .. 5) = "gnat."))
  46         or else
  47           (OpenVMS_On_Target
  48            and then Name_Len > 3
  49            and then (Name_Buffer (1 .. 4) = "dec%"
  50                       or else
  51                      Name_Buffer (1 .. 4) = "dec."));
  52
  53    end Is_Internal_Unit;
  54
  55    ------------------------
  56    -- Is_Predefined_Unit --
  57    ------------------------
  58
  59    --  Note: the reason we do not use the Fname package for this function
  60    --  is that it would drag too much junk into the binder.
  61
  62    function Is_Predefined_Unit return Boolean is
  63    begin
  64       return    (Name_Len >  3
  65                   and then Name_Buffer (1 ..  4) = "ada.")
  66
  67         or else (Name_Len >  6
  68                   and then Name_Buffer (1 ..  7) = "system.")
  69
  70         or else (Name_Len > 10
  71                    and then Name_Buffer (1 .. 11) = "interfaces.")
  72
  73         or else (Name_Len >  3
  74                    and then Name_Buffer (1 ..  4) = "ada%")
  75
  76         or else (Name_Len >  8
  77                    and then Name_Buffer (1 ..  9) = "calendar%")
  78
  79         or else (Name_Len >  9
  80                    and then Name_Buffer (1 .. 10) = "direct_io%")
  81
  82         or else (Name_Len > 10
  83                    and then Name_Buffer (1 .. 11) = "interfaces%")
  84
  85         or else (Name_Len > 13
  86                    and then Name_Buffer (1 .. 14) = "io_exceptions%")
  87
  88         or else (Name_Len > 12
  89                    and then Name_Buffer (1 .. 13) = "machine_code%")
  90
  91         or else (Name_Len > 13
  92                    and then Name_Buffer (1 .. 14) = "sequential_io%")
  93
  94         or else (Name_Len >  6
  95                    and then Name_Buffer (1 ..  7) = "system%")
  96
  97         or else (Name_Len >  7
  98                    and then Name_Buffer (1 ..  8) = "text_io%")
  99
 100         or else (Name_Len > 20
 101                    and then Name_Buffer (1 .. 21) = "unchecked_conversion%")
 102
 103         or else (Name_Len > 22
 104                    and then Name_Buffer (1 .. 23) = "unchecked_deallocation%")
 105
 106         or else (Name_Len > 4
 107                    and then Name_Buffer (1 .. 5) = "gnat%")
 108
 109         or else (Name_Len > 4
 110                    and then Name_Buffer (1 .. 5) = "gnat.");
 111    end Is_Predefined_Unit;
 112
 113    ----------------
 114    -- Uname_Less --
 115    ----------------
 116
 117    function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
 118    begin
 119       Get_Name_String (U1);
 120
 121       declare
 122          U1_Name : constant String (1 .. Name_Len) :=
 123                                            Name_Buffer (1 .. Name_Len);
 124          Min_Length : Natural;
 125
 126       begin
 127          Get_Name_String (U2);
 128
 129          if Name_Len < U1_Name'Last then
 130             Min_Length := Name_Len;
 131          else
 132             Min_Length := U1_Name'Last;
 133          end if;
 134
 135          for I in 1 .. Min_Length loop
 136             if U1_Name (I) > Name_Buffer (I) then
 137                return False;
 138             elsif U1_Name (I) < Name_Buffer (I) then
 139                return True;
 140             end if;
 141          end loop;
 142
 143          return U1_Name'Last < Name_Len;
 144       end;
 145    end Uname_Less;
 146
 147    ---------------------
 148    -- Write_Unit_Name --
 149    ---------------------
 150
 151    procedure Write_Unit_Name (U : Unit_Name_Type) is
 152    begin
 153       Get_Name_String (U);
 154       Write_Str (Name_Buffer (1 .. Name_Len - 2));
 155
 156       if Name_Buffer (Name_Len) = 's' then
 157          Write_Str (" (spec)");
 158       else
 159          Write_Str (" (body)");
 160       end if;
 161
 162       Name_Len := Name_Len + 5;
 163    end Write_Unit_Name;
 164
 165 end Butil;