1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
35 (Buffer : in out String;
39 VMS_On_Target : Boolean := False)
42 pragma Assert (Buffer'First = 1);
43 -- This is a documented requirement; the assert turns off index warnings
45 B1 : Character renames Buffer (1);
53 -- Deal with special predefined children cases. Startloc is the first
54 -- location for the krunch, set to 1, except for the predefined children
55 -- case, where it is set to 3, to start after the standard prefix.
63 and then Buffer (1 .. 17) = "ada-wide_text_io-"
66 Buffer (2 .. 5) := "-wt-";
67 Buffer (6 .. Len - 12) := Buffer (18 .. Len);
72 and then Buffer (1 .. 22) = "ada-wide_wide_text_io-"
75 Buffer (2 .. 5) := "-zt-";
76 Buffer (6 .. Len - 17) := Buffer (23 .. Len);
80 elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
82 Buffer (2 .. Len - 2) := Buffer (4 .. Len);
86 elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
88 Buffer (2 .. Len - 3) := Buffer (5 .. Len);
92 elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
94 Buffer (2 .. Len - 5) := Buffer (7 .. Len);
98 elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
100 Buffer (2 .. Len - 9) := Buffer (11 .. Len);
104 -- For the renamings in the obsolescent section, we also force krunching
105 -- to 8 characters, but no other special processing is required here.
106 -- Note that text_io and calendar are already short enough anyway.
108 elsif (Len = 9 and then Buffer (1 .. 9) = "direct_io")
109 or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
110 or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
111 or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
112 or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
113 or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
114 or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
120 -- Special case of a child unit whose parent unit is a single letter that
121 -- is A, G, I, or S. In order to prevent confusion with krunched names
122 -- of predefined units use a tilde rather than a minus as the second
123 -- character of the file name. On VMS a tilde is an illegal character
124 -- in a file name, two consecutive underlines ("__") are used instead.
127 and then Buffer (2) = '-'
128 and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
129 and then Len <= Maxlen
131 -- When VMS is the host, it is always also the target
133 if Hostparm.OpenVMS or else VMS_On_Target then
135 Buffer (4 .. Len) := Buffer (3 .. Len - 1);
142 if Len <= Maxlen then
146 -- Case of VMS when the buffer had exactly the length Maxlen and now
147 -- has the length Maxlen + 1: krunching after "__" is needed.
154 -- Normal case, not a predefined file
162 -- Immediate return if file name is short enough now
164 if Curlen <= Krlen then
169 -- If string contains Wide_Wide, replace by a single z
172 while J <= Curlen - 8 loop
173 if Buffer (J .. J + 8) = "wide_wide"
174 and then (J = Startloc
175 or else Buffer (J - 1) = '-'
176 or else Buffer (J - 1) = '_')
177 and then (J + 8 = Curlen
178 or else Buffer (J + 9) = '-'
179 or else Buffer (J + 9) = '_')
182 Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen);
183 Curlen := Curlen - 8;
189 -- For now, refuse to krunch a name that contains an ESC character (wide
190 -- character sequence) since it's too much trouble to do this right ???
192 for J in 1 .. Curlen loop
193 if Buffer (J) = ASCII.ESC then
198 -- Count number of separators (minus signs and underscores) and for now
199 -- replace them by spaces. We keep them around till the end to control
200 -- the krunching process, and then we eliminate them as the last step
203 for J in Startloc .. Curlen loop
204 if Buffer (J) = '-' or else Buffer (J) = '_' then
206 Num_Seps := Num_Seps + 1;
210 -- Now we do the one character at a time krunch till we are short enough
212 while Curlen - Num_Seps > Krlen loop
214 Long_Length : Natural := 0;
215 Long_Last : Natural := 0;
216 Piece_Start : Natural;
222 -- Loop through pieces to find longest piece
224 while Ptr <= Curlen loop
227 -- Loop through characters in one piece of name
229 while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
233 if Ptr - Piece_Start > Long_Length then
234 Long_Length := Ptr - Piece_Start;
235 Long_Last := Ptr - 1;
241 -- Remove last character of longest piece
243 if Long_Last < Curlen then
244 Buffer (Long_Last .. Curlen - 1) :=
245 Buffer (Long_Last + 1 .. Curlen);
248 Curlen := Curlen - 1;
252 -- Final step, remove the spaces
256 for J in 1 .. Curlen loop
257 if Buffer (J) /= ' ' then
259 Buffer (Len) := Buffer (J);