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 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Hostparm; use Hostparm;
  29 with Namet;    use Namet;
  30 with Output;   use Output;
  31
  32 package body Butil is
  33
  34    --------------------------
  35    -- Get_Unit_Name_String --
  36    --------------------------
  37
  38    procedure Get_Unit_Name_String (U : Unit_Name_Type) is
  39    begin
  40       Get_Name_String (U);
  41
  42       if Name_Buffer (Name_Len) = 's' then
  43          Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
  44       else
  45          Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
  46       end if;
  47
  48       Name_Len := Name_Len + 5;
  49    end Get_Unit_Name_String;
  50
  51    ----------------------
  52    -- Is_Internal_Unit --
  53    ----------------------
  54
  55    --  Note: the reason we do not use the Fname package for this function
  56    --  is that it would drag too much junk into the binder.
  57
  58    function Is_Internal_Unit return Boolean is
  59    begin
  60       return Is_Predefined_Unit
  61         or else (Name_Len > 4
  62                    and then (Name_Buffer (1 .. 5) = "gnat%"
  63                                or else
  64                              Name_Buffer (1 .. 5) = "gnat."))
  65         or else
  66           (OpenVMS
  67              and then Name_Len > 3
  68              and then (Name_Buffer (1 .. 4) = "dec%"
  69                          or else
  70                        Name_Buffer (1 .. 4) = "dec."));
  71
  72    end Is_Internal_Unit;
  73
  74    ------------------------
  75    -- Is_Predefined_Unit --
  76    ------------------------
  77
  78    --  Note: the reason we do not use the Fname package for this function
  79    --  is that it would drag too much junk into the binder.
  80
  81    function Is_Predefined_Unit return Boolean is
  82    begin
  83       return    (Name_Len >  3
  84                   and then Name_Buffer (1 ..  4) = "ada.")
  85
  86         or else (Name_Len >  6
  87                   and then Name_Buffer (1 ..  7) = "system.")
  88
  89         or else (Name_Len > 10
  90                    and then Name_Buffer (1 .. 11) = "interfaces.")
  91
  92         or else (Name_Len >  3
  93                    and then Name_Buffer (1 ..  4) = "ada%")
  94
  95         or else (Name_Len >  8
  96                    and then Name_Buffer (1 ..  9) = "calendar%")
  97
  98         or else (Name_Len >  9
  99                    and then Name_Buffer (1 .. 10) = "direct_io%")
 100
 101         or else (Name_Len > 10
 102                    and then Name_Buffer (1 .. 11) = "interfaces%")
 103
 104         or else (Name_Len > 13
 105                    and then Name_Buffer (1 .. 14) = "io_exceptions%")
 106
 107         or else (Name_Len > 12
 108                    and then Name_Buffer (1 .. 13) = "machine_code%")
 109
 110         or else (Name_Len > 13
 111                    and then Name_Buffer (1 .. 14) = "sequential_io%")
 112
 113         or else (Name_Len >  6
 114                    and then Name_Buffer (1 ..  7) = "system%")
 115
 116         or else (Name_Len >  7
 117                    and then Name_Buffer (1 ..  8) = "text_io%")
 118
 119         or else (Name_Len > 20
 120                    and then Name_Buffer (1 .. 21) = "unchecked_conversion%")
 121
 122         or else (Name_Len > 22
 123                    and then Name_Buffer (1 .. 23) = "unchecked_deallocation%")
 124
 125         or else (Name_Len > 4
 126                    and then Name_Buffer (1 .. 5) = "gnat%")
 127
 128         or else (Name_Len > 4
 129                    and then Name_Buffer (1 .. 5) = "gnat.");
 130    end Is_Predefined_Unit;
 131
 132    ----------------
 133    -- Uname_Less --
 134    ----------------
 135
 136    function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
 137    begin
 138       Get_Name_String (U1);
 139
 140       declare
 141          U1_Name : constant String (1 .. Name_Len) :=
 142                                            Name_Buffer (1 .. Name_Len);
 143          Min_Length : Natural;
 144
 145       begin
 146          Get_Name_String (U2);
 147
 148          if Name_Len < U1_Name'Last then
 149             Min_Length := Name_Len;
 150          else
 151             Min_Length := U1_Name'Last;
 152          end if;
 153
 154          for I in 1 .. Min_Length loop
 155             if U1_Name (I) > Name_Buffer (I) then
 156                return False;
 157             elsif U1_Name (I) < Name_Buffer (I) then
 158                return True;
 159             end if;
 160          end loop;
 161
 162          return U1_Name'Last < Name_Len;
 163       end;
 164    end Uname_Less;
 165
 166    ---------------------
 167    -- Write_Unit_Name --
 168    ---------------------
 169
 170    procedure Write_Unit_Name (U : Unit_Name_Type) is
 171    begin
 172       Get_Name_String (U);
 173       Write_Str (Name_Buffer (1 .. Name_Len - 2));
 174
 175       if Name_Buffer (Name_Len) = 's' then
 176          Write_Str (" (spec)");
 177       else
 178          Write_Str (" (body)");
 179       end if;
 180
 181       Name_Len := Name_Len + 5;
 182    end Write_Unit_Name;
 183
 184 end Butil;