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