1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                B U T I L                                 --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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 3,  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 COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Output; use Output;
27
28package body Butil is
29
30   ----------------------
31   -- Is_Internal_Unit --
32   ----------------------
33
34   --  Note: the reason we do not use the Fname package for this function
35   --  is that it would drag too much junk into the binder.
36
37   function Is_Internal_Unit return Boolean is
38   begin
39      return Is_Predefined_Unit
40        or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%"
41                                          or else
42                                        Name_Buffer (1 .. 5) = "gnat."));
43   end Is_Internal_Unit;
44
45   ------------------------
46   -- Is_Predefined_Unit --
47   ------------------------
48
49   --  Note: the reason we do not use the Fname package for this function
50   --  is that it would drag too much junk into the binder.
51
52   function Is_Predefined_Unit return Boolean is
53      L : Natural renames Name_Len;
54      B : String  renames Name_Buffer;
55   begin
56      return    (L >  3 and then B (1 ..  4) = "ada.")
57        or else (L >  6 and then B (1 ..  7) = "system.")
58        or else (L > 10 and then B (1 .. 11) = "interfaces.")
59        or else (L >  3 and then B (1 ..  4) = "ada%")
60        or else (L >  8 and then B (1 ..  9) = "calendar%")
61        or else (L >  9 and then B (1 .. 10) = "direct_io%")
62        or else (L > 10 and then B (1 .. 11) = "interfaces%")
63        or else (L > 13 and then B (1 .. 14) = "io_exceptions%")
64        or else (L > 12 and then B (1 .. 13) = "machine_code%")
65        or else (L > 13 and then B (1 .. 14) = "sequential_io%")
66        or else (L >  6 and then B (1 ..  7) = "system%")
67        or else (L >  7 and then B (1 ..  8) = "text_io%")
68        or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%")
69        or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%")
70        or else (L >  4 and then B (1 ..  5) = "gnat%")
71        or else (L >  4 and then B (1 ..  5) = "gnat.");
72   end Is_Predefined_Unit;
73
74   ----------------
75   -- Uname_Less --
76   ----------------
77
78   function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
79   begin
80      Get_Name_String (U1);
81
82      declare
83         U1_Name : constant String (1 .. Name_Len) :=
84                     Name_Buffer (1 .. Name_Len);
85         Min_Length : Natural;
86
87      begin
88         Get_Name_String (U2);
89
90         if Name_Len < U1_Name'Last then
91            Min_Length := Name_Len;
92         else
93            Min_Length := U1_Name'Last;
94         end if;
95
96         for J in 1 .. Min_Length loop
97            if U1_Name (J) > Name_Buffer (J) then
98               return False;
99            elsif U1_Name (J) < Name_Buffer (J) then
100               return True;
101            end if;
102         end loop;
103
104         return U1_Name'Last < Name_Len;
105      end;
106   end Uname_Less;
107
108   ---------------------
109   -- Write_Unit_Name --
110   ---------------------
111
112   procedure Write_Unit_Name (U : Unit_Name_Type) is
113   begin
114      Get_Name_String (U);
115      Write_Str (Name_Buffer (1 .. Name_Len - 2));
116
117      if Name_Buffer (Name_Len) = 's' then
118         Write_Str (" (spec)");
119      else
120         Write_Str (" (body)");
121      end if;
122
123      Name_Len := Name_Len + 5;
124   end Write_Unit_Name;
125
126end Butil;
127