1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
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. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
37 (Buffer : in out String;
41 VMS_On_Target : Boolean := False)
44 pragma Assert (Buffer'First = 1);
45 -- This is a documented requirement; the assert turns off index warnings
47 B1 : Character renames Buffer (1);
55 -- Deal with special predefined children cases. Startloc is the first
56 -- location for the krunch, set to 1, except for the predefined children
57 -- case, where it is set to 3, to start after the standard prefix.
65 and then Buffer (1 .. 17) = "ada-wide_text_io-"
68 Buffer (2 .. 5) := "-wt-";
69 Buffer (6 .. Len - 12) := Buffer (18 .. Len);
74 and then Buffer (1 .. 22) = "ada-wide_wide_text_io-"
77 Buffer (2 .. 5) := "-zt-";
78 Buffer (6 .. Len - 17) := Buffer (23 .. Len);
82 elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
84 Buffer (2 .. Len - 2) := Buffer (4 .. Len);
88 elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
90 Buffer (2 .. Len - 3) := Buffer (5 .. Len);
94 elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
96 Buffer (2 .. Len - 5) := Buffer (7 .. Len);
100 elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
102 Buffer (2 .. Len - 9) := Buffer (11 .. Len);
106 -- For the renamings in the obsolescent section, we also force krunching
107 -- to 8 characters, but no other special processing is required here.
108 -- Note that text_io and calendar are already short enough anyway.
110 elsif (Len = 9 and then Buffer (1 .. 9) = "direct_io")
111 or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
112 or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
113 or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
114 or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
115 or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
116 or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
122 -- Special case of a child unit whose parent unit is a single letter that
123 -- is A, G, I, or S. In order to prevent confusion with krunched names
124 -- of predefined units use a tilde rather than a minus as the second
125 -- character of the file name. On VMS a tilde is an illegal character
126 -- in a file name, two consecutive underlines ("__") are used instead.
129 and then Buffer (2) = '-'
130 and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
131 and then Len <= Maxlen
133 -- When VMS is the host, it is always also the target
135 if Hostparm.OpenVMS or else VMS_On_Target then
137 Buffer (4 .. Len) := Buffer (3 .. Len - 1);
144 if Len <= Maxlen then
148 -- Case of VMS when the buffer had exactly the length Maxlen and now
149 -- has the length Maxlen + 1: krunching after "__" is needed.
156 -- Normal case, not a predefined file
164 -- Immediate return if file name is short enough now
166 if Curlen <= Krlen then
171 -- If string contains Wide_Wide, replace by a single z
174 while J <= Curlen - 8 loop
175 if Buffer (J .. J + 8) = "wide_wide"
176 and then (J = Startloc
177 or else Buffer (J - 1) = '-'
178 or else Buffer (J - 1) = '_')
179 and then (J + 8 = Curlen
180 or else Buffer (J + 9) = '-'
181 or else Buffer (J + 9) = '_')
184 Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen);
185 Curlen := Curlen - 8;
191 -- For now, refuse to krunch a name that contains an ESC character (wide
192 -- character sequence) since it's too much trouble to do this right ???
194 for J in 1 .. Curlen loop
195 if Buffer (J) = ASCII.ESC then
200 -- Count number of separators (minus signs and underscores) and for now
201 -- replace them by spaces. We keep them around till the end to control
202 -- the krunching process, and then we eliminate them as the last step
205 for J in Startloc .. Curlen loop
206 if Buffer (J) = '-' or else Buffer (J) = '_' then
208 Num_Seps := Num_Seps + 1;
212 -- Now we do the one character at a time krunch till we are short enough
214 while Curlen - Num_Seps > Krlen loop
216 Long_Length : Natural := 0;
217 Long_Last : Natural := 0;
218 Piece_Start : Natural;
224 -- Loop through pieces to find longest piece
226 while Ptr <= Curlen loop
229 -- Loop through characters in one piece of name
231 while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
235 if Ptr - Piece_Start > Long_Length then
236 Long_Length := Ptr - Piece_Start;
237 Long_Last := Ptr - 1;
243 -- Remove last character of longest piece
245 if Long_Last < Curlen then
246 Buffer (Long_Last .. Curlen - 1) :=
247 Buffer (Long_Last + 1 .. Curlen);
250 Curlen := Curlen - 1;
254 -- Final step, remove the spaces
258 for J in 1 .. Curlen loop
259 if Buffer (J) /= ' ' then
261 Buffer (Len) := Buffer (J);