1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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. 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 (Buffer
: in out String;
32 pragma Assert
(Buffer
'First = 1);
33 -- This is a documented requirement; the assert turns off index warnings
35 B1
: Character renames Buffer
(1);
43 -- Deal with special predefined children cases. Startloc is the first
44 -- location for the krunch, set to 1, except for the predefined children
45 -- case, where it is set to 3, to start after the standard prefix.
53 and then Buffer
(1 .. 17) = "ada-wide_text_io-"
56 Buffer
(2 .. 5) := "-wt-";
57 Buffer
(6 .. Len
- 12) := Buffer
(18 .. Len
);
62 and then Buffer
(1 .. 22) = "ada-wide_wide_text_io-"
65 Buffer
(2 .. 5) := "-zt-";
66 Buffer
(6 .. Len
- 17) := Buffer
(23 .. Len
);
71 and then Buffer
(1 .. 27) = "ada-long_long_long_integer_"
74 Buffer
(2 .. Len
- 2) := Buffer
(4 .. Len
);
75 Buffer
(18 .. Len
- 10) := Buffer
(26 .. Len
- 2);
79 elsif Len
>= 4 and then Buffer
(1 .. 4) = "ada-" then
81 Buffer
(2 .. Len
- 2) := Buffer
(4 .. Len
);
85 elsif Len
>= 5 and then Buffer
(1 .. 5) = "gnat-" then
87 Buffer
(2 .. Len
- 3) := Buffer
(5 .. Len
);
91 elsif Len
>= 7 and then Buffer
(1 .. 7) = "system-" then
93 Buffer
(2 .. Len
- 5) := Buffer
(7 .. Len
);
95 if (Curlen
>= 3 and then Buffer
(Curlen
- 2 .. Curlen
) = "128")
96 or else (Len
>= 9 and then
97 (Buffer
(3 .. 9) = "exn_lll"
98 or else Buffer
(3 .. 9) = "exp_lll"
99 or else Buffer
(3 .. 9) = "img_lll"
100 or else Buffer
(3 .. 9) = "val_lll"
101 or else Buffer
(3 .. 9) = "wid_lll"))
102 or else (Curlen
= 10 and then Buffer
(3 .. 6) = "pack")
104 if Len
>= 15 and then Buffer
(3 .. 15) = "compare_array" then
105 Buffer
(3 .. 4) := "ca";
106 Buffer
(5 .. Curlen
- 11) := Buffer
(16 .. Curlen
);
107 Curlen
:= Curlen
- 11;
114 elsif Len
>= 11 and then Buffer
(1 .. 11) = "interfaces-" then
116 Buffer
(2 .. Len
- 9) := Buffer
(11 .. Len
);
119 -- Only fully krunch historical units. For new units, simply use
120 -- the 'i-' prefix instead of 'interfaces-'. Packages Interfaces.C
121 -- and Interfaces.Cobol are already in the right form. Package
122 -- Interfaces.Definitions is krunched for backward compatibility.
124 if (Curlen
> 3 and then Buffer
(3 .. 4) = "c-")
125 or else (Curlen
> 3 and then Buffer
(3 .. 4) = "c_")
126 or else (Curlen
= 13 and then Buffer
(3 .. 13) = "definitions")
127 or else (Curlen
= 9 and then Buffer
(3 .. 9) = "fortran")
128 or else (Curlen
= 16 and then Buffer
(3 .. 16) = "packed_decimal")
129 or else (Curlen
> 8 and then Buffer
(3 .. 9) = "vxworks")
130 or else (Curlen
> 5 and then Buffer
(3 .. 6) = "java")
137 -- For the renamings in the obsolescent section, we also force krunching
138 -- to 8 characters, but no other special processing is required here.
139 -- Note that text_io and calendar are already short enough anyway.
141 elsif (Len
= 9 and then Buffer
(1 .. 9) = "direct_io")
142 or else (Len
= 10 and then Buffer
(1 .. 10) = "interfaces")
143 or else (Len
= 13 and then Buffer
(1 .. 13) = "io_exceptions")
144 or else (Len
= 12 and then Buffer
(1 .. 12) = "machine_code")
145 or else (Len
= 13 and then Buffer
(1 .. 13) = "sequential_io")
146 or else (Len
= 20 and then Buffer
(1 .. 20) = "unchecked_conversion")
147 or else (Len
= 22 and then Buffer
(1 .. 22) = "unchecked_deallocation")
153 -- Special case of a child unit whose parent unit is a single letter that
154 -- is A, G, I, or S. In order to prevent confusion with krunched names
155 -- of predefined units use a tilde rather than a minus as the second
156 -- character of the file name.
159 and then Buffer
(2) = '-'
160 and then (B1
= 'a' or else B1
= 'g' or else B1
= 'i' or else B1
= 's')
161 and then Len
<= Maxlen
166 -- Normal case, not a predefined file
174 -- Immediate return if file name is short enough now
176 if Curlen
<= Krlen
then
181 -- If string contains Wide_Wide, replace by a single z
184 while J
<= Curlen
- 8 loop
185 if Buffer
(J
.. J
+ 8) = "wide_wide"
186 and then (J
= Startloc
187 or else Buffer
(J
- 1) = '-'
188 or else Buffer
(J
- 1) = '_')
189 and then (J
+ 8 = Curlen
190 or else Buffer
(J
+ 9) = '-'
191 or else Buffer
(J
+ 9) = '_')
194 Buffer
(J
+ 1 .. Curlen
- 8) := Buffer
(J
+ 9 .. Curlen
);
195 Curlen
:= Curlen
- 8;
201 -- For now, refuse to krunch a name that contains an ESC character (wide
202 -- character sequence) since it's too much trouble to do this right ???
204 for J
in 1 .. Curlen
loop
205 if Buffer
(J
) = ASCII
.ESC
then
210 -- Count number of separators (minus signs and underscores) and for now
211 -- replace them by spaces. We keep them around till the end to control
212 -- the krunching process, and then we eliminate them as the last step
215 for J
in Startloc
.. Curlen
loop
216 if Buffer
(J
) = '-' or else Buffer
(J
) = '_' then
218 Num_Seps
:= Num_Seps
+ 1;
222 -- Now we do the one character at a time krunch till we are short enough
224 while Curlen
- Num_Seps
> Krlen
loop
226 Long_Length
: Natural := 0;
227 Long_Last
: Natural := 0;
228 Piece_Start
: Natural;
234 -- Loop through pieces to find longest piece
236 while Ptr
<= Curlen
loop
239 -- Loop through characters in one piece of name
241 while Ptr
<= Curlen
and then Buffer
(Ptr
) /= ' ' loop
245 if Ptr
- Piece_Start
> Long_Length
then
246 Long_Length
:= Ptr
- Piece_Start
;
247 Long_Last
:= Ptr
- 1;
253 -- Remove last character of longest piece
255 if Long_Last
< Curlen
then
256 Buffer
(Long_Last
.. Curlen
- 1) :=
257 Buffer
(Long_Last
+ 1 .. Curlen
);
260 Curlen
:= Curlen
- 1;
264 -- Final step, remove the spaces
268 for J
in 1 .. Curlen
loop
269 if Buffer
(J
) /= ' ' then
271 Buffer
(Len
) := Buffer
(J
);