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-2001 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Hostparm; use Hostparm;
  28 with Namet;    use Namet;
  29 with Output;   use Output;
  30
  31 package body Butil is
  32
  33    --------------------------
  34    -- Get_Unit_Name_String --
  35    --------------------------
  36
  37    procedure Get_Unit_Name_String (U : Unit_Name_Type) is
  38    begin
  39       Get_Name_String (U);
  40
  41       if Name_Buffer (Name_Len) = 's' then
  42          Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
  43       else
  44          Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
  45       end if;
  46
  47       Name_Len := Name_Len + 5;
  48    end Get_Unit_Name_String;
  49
  50    ----------------------
  51    -- Is_Internal_Unit --
  52    ----------------------
  53
  54    --  Note: the reason we do not use the Fname package for this function
  55    --  is that it would drag too much junk into the binder.
  56
  57    function Is_Internal_Unit return Boolean is
  58    begin
  59       return Is_Predefined_Unit
  60         or else (Name_Len > 4
  61                    and then (Name_Buffer (1 .. 5) = "gnat%"
  62                                or else
  63                              Name_Buffer (1 .. 5) = "gnat."))
  64         or else
  65           (OpenVMS
  66              and then Name_Len > 3
  67              and then (Name_Buffer (1 .. 4) = "dec%"
  68                          or else
  69                        Name_Buffer (1 .. 4) = "dec."));
  70
  71    end Is_Internal_Unit;
  72
  73    ------------------------
  74    -- Is_Predefined_Unit --
  75    ------------------------
  76
  77    --  Note: the reason we do not use the Fname package for this function
  78    --  is that it would drag too much junk into the binder.
  79
  80    function Is_Predefined_Unit return Boolean is
  81    begin
  82       return    (Name_Len >  3
  83                   and then Name_Buffer (1 ..  4) = "ada.")
  84
  85         or else (Name_Len >  6
  86                   and then Name_Buffer (1 ..  7) = "system.")
  87
  88         or else (Name_Len > 10
  89                    and then Name_Buffer (1 .. 11) = "interfaces.")
  90
  91         or else (Name_Len >  3
  92                    and then Name_Buffer (1 ..  4) = "ada%")
  93
  94         or else (Name_Len >  8
  95                    and then Name_Buffer (1 ..  9) = "calendar%")
  96
  97         or else (Name_Len >  9
  98                    and then Name_Buffer (1 .. 10) = "direct_io%")
  99
 100         or else (Name_Len > 10
 101                    and then Name_Buffer (1 .. 11) = "interfaces%")
 102
 103         or else (Name_Len > 13
 104                    and then Name_Buffer (1 .. 14) = "io_exceptions%")
 105
 106         or else (Name_Len > 12
 107                    and then Name_Buffer (1 .. 13) = "machine_code%")
 108
 109         or else (Name_Len > 13
 110                    and then Name_Buffer (1 .. 14) = "sequential_io%")
 111
 112         or else (Name_Len >  6
 113                    and then Name_Buffer (1 ..  7) = "system%")
 114
 115         or else (Name_Len >  7
 116                    and then Name_Buffer (1 ..  8) = "text_io%")
 117
 118         or else (Name_Len > 20
 119                    and then Name_Buffer (1 .. 21) = "unchecked_conversion%")
 120
 121         or else (Name_Len > 22
 122                    and then Name_Buffer (1 .. 23) = "unchecked_deallocation%")
 123
 124         or else (Name_Len > 4
 125                    and then Name_Buffer (1 .. 5) = "gnat%")
 126
 127         or else (Name_Len > 4
 128                    and then Name_Buffer (1 .. 5) = "gnat.");
 129    end Is_Predefined_Unit;
 130
 131    ----------------
 132    -- Uname_Less --
 133    ----------------
 134
 135    function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
 136    begin
 137       Get_Name_String (U1);
 138
 139       declare
 140          U1_Name : constant String (1 .. Name_Len) :=
 141                                            Name_Buffer (1 .. Name_Len);
 142          Min_Length : Natural;
 143
 144       begin
 145          Get_Name_String (U2);
 146
 147          if Name_Len < U1_Name'Last then
 148             Min_Length := Name_Len;
 149          else
 150             Min_Length := U1_Name'Last;
 151          end if;
 152
 153          for I in 1 .. Min_Length loop
 154             if U1_Name (I) > Name_Buffer (I) then
 155                return False;
 156             elsif U1_Name (I) < Name_Buffer (I) then
 157                return True;
 158             end if;
 159          end loop;
 160
 161          return U1_Name'Last < Name_Len;
 162       end;
 163    end Uname_Less;
 164
 165    ---------------------
 166    -- Write_Unit_Name --
 167    ---------------------
 168
 169    procedure Write_Unit_Name (U : Unit_Name_Type) is
 170    begin
 171       Get_Name_String (U);
 172       Write_Str (Name_Buffer (1 .. Name_Len - 2));
 173
 174       if Name_Buffer (Name_Len) = 's' then
 175          Write_Str (" (spec)");
 176       else
 177          Write_Str (" (body)");
 178       end if;
 179
 180       Name_Len := Name_Len + 5;
 181    end Write_Unit_Name;
 182
 183 end Butil;