File : krunch.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- K R U N C H --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 procedure Krunch
33 (Buffer : in out String;
34 Len : in out Natural;
35 Maxlen : Natural;
36 No_Predef : Boolean)
37 is
38 pragma Assert (Buffer'First = 1);
39 -- This is a documented requirement; the assert turns off index warnings
40
41 B1 : Character renames Buffer (1);
42 Curlen : Natural;
43 Krlen : Natural;
44 Num_Seps : Natural;
45 Startloc : Natural;
46 J : Natural;
47
48 begin
49 -- Deal with special predefined children cases. Startloc is the first
50 -- location for the krunch, set to 1, except for the predefined children
51 -- case, where it is set to 3, to start after the standard prefix.
52
53 if No_Predef then
54 Startloc := 1;
55 Curlen := Len;
56 Krlen := Maxlen;
57
58 elsif Len >= 18
59 and then Buffer (1 .. 17) = "ada-wide_text_io-"
60 then
61 Startloc := 3;
62 Buffer (2 .. 5) := "-wt-";
63 Buffer (6 .. Len - 12) := Buffer (18 .. Len);
64 Curlen := Len - 12;
65 Krlen := 8;
66
67 elsif Len >= 23
68 and then Buffer (1 .. 22) = "ada-wide_wide_text_io-"
69 then
70 Startloc := 3;
71 Buffer (2 .. 5) := "-zt-";
72 Buffer (6 .. Len - 17) := Buffer (23 .. Len);
73 Curlen := Len - 17;
74 Krlen := 8;
75
76 elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
77 Startloc := 3;
78 Buffer (2 .. Len - 2) := Buffer (4 .. Len);
79 Curlen := Len - 2;
80 Krlen := 8;
81
82 elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
83 Startloc := 3;
84 Buffer (2 .. Len - 3) := Buffer (5 .. Len);
85 Curlen := Len - 3;
86 Krlen := 8;
87
88 elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
89 Startloc := 3;
90 Buffer (2 .. Len - 5) := Buffer (7 .. Len);
91 Curlen := Len - 5;
92 Krlen := 8;
93
94 elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
95 Startloc := 3;
96 Buffer (2 .. Len - 9) := Buffer (11 .. Len);
97 Curlen := Len - 9;
98
99 -- Only fully krunch historical units. For new units, simply use
100 -- the 'i-' prefix instead of 'interfaces-'. Packages Interfaces.C
101 -- and Interfaces.Cobol are already in the right form. Package
102 -- Interfaces.Definitions is krunched for backward compatibility.
103
104 if (Curlen > 3 and then Buffer (3 .. 4) = "c-")
105 or else (Curlen > 3 and then Buffer (3 .. 4) = "c_")
106 or else (Curlen = 13 and then Buffer (3 .. 13) = "definitions")
107 or else (Curlen = 9 and then Buffer (3 .. 9) = "fortran")
108 or else (Curlen = 16 and then Buffer (3 .. 16) = "packed_decimal")
109 or else (Curlen > 8 and then Buffer (3 .. 9) = "vxworks")
110 or else (Curlen > 5 and then Buffer (3 .. 6) = "java")
111 then
112 Krlen := 8;
113 else
114 Krlen := Maxlen;
115 end if;
116
117 -- For the renamings in the obsolescent section, we also force krunching
118 -- to 8 characters, but no other special processing is required here.
119 -- Note that text_io and calendar are already short enough anyway.
120
121 elsif (Len = 9 and then Buffer (1 .. 9) = "direct_io")
122 or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
123 or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
124 or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
125 or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
126 or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
127 or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
128 then
129 Startloc := 1;
130 Krlen := 8;
131 Curlen := Len;
132
133 -- Special case of a child unit whose parent unit is a single letter that
134 -- is A, G, I, or S. In order to prevent confusion with krunched names
135 -- of predefined units use a tilde rather than a minus as the second
136 -- character of the file name.
137
138 elsif Len > 1
139 and then Buffer (2) = '-'
140 and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
141 and then Len <= Maxlen
142 then
143 Buffer (2) := '~';
144 return;
145
146 -- Normal case, not a predefined file
147
148 else
149 Startloc := 1;
150 Curlen := Len;
151 Krlen := Maxlen;
152 end if;
153
154 -- Immediate return if file name is short enough now
155
156 if Curlen <= Krlen then
157 Len := Curlen;
158 return;
159 end if;
160
161 -- If string contains Wide_Wide, replace by a single z
162
163 J := Startloc;
164 while J <= Curlen - 8 loop
165 if Buffer (J .. J + 8) = "wide_wide"
166 and then (J = Startloc
167 or else Buffer (J - 1) = '-'
168 or else Buffer (J - 1) = '_')
169 and then (J + 8 = Curlen
170 or else Buffer (J + 9) = '-'
171 or else Buffer (J + 9) = '_')
172 then
173 Buffer (J) := 'z';
174 Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen);
175 Curlen := Curlen - 8;
176 end if;
177
178 J := J + 1;
179 end loop;
180
181 -- For now, refuse to krunch a name that contains an ESC character (wide
182 -- character sequence) since it's too much trouble to do this right ???
183
184 for J in 1 .. Curlen loop
185 if Buffer (J) = ASCII.ESC then
186 return;
187 end if;
188 end loop;
189
190 -- Count number of separators (minus signs and underscores) and for now
191 -- replace them by spaces. We keep them around till the end to control
192 -- the krunching process, and then we eliminate them as the last step
193
194 Num_Seps := 0;
195 for J in Startloc .. Curlen loop
196 if Buffer (J) = '-' or else Buffer (J) = '_' then
197 Buffer (J) := ' ';
198 Num_Seps := Num_Seps + 1;
199 end if;
200 end loop;
201
202 -- Now we do the one character at a time krunch till we are short enough
203
204 while Curlen - Num_Seps > Krlen loop
205 declare
206 Long_Length : Natural := 0;
207 Long_Last : Natural := 0;
208 Piece_Start : Natural;
209 Ptr : Natural;
210
211 begin
212 Ptr := Startloc;
213
214 -- Loop through pieces to find longest piece
215
216 while Ptr <= Curlen loop
217 Piece_Start := Ptr;
218
219 -- Loop through characters in one piece of name
220
221 while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
222 Ptr := Ptr + 1;
223 end loop;
224
225 if Ptr - Piece_Start > Long_Length then
226 Long_Length := Ptr - Piece_Start;
227 Long_Last := Ptr - 1;
228 end if;
229
230 Ptr := Ptr + 1;
231 end loop;
232
233 -- Remove last character of longest piece
234
235 if Long_Last < Curlen then
236 Buffer (Long_Last .. Curlen - 1) :=
237 Buffer (Long_Last + 1 .. Curlen);
238 end if;
239
240 Curlen := Curlen - 1;
241 end;
242 end loop;
243
244 -- Final step, remove the spaces
245
246 Len := 0;
247
248 for J in 1 .. Curlen loop
249 if Buffer (J) /= ' ' then
250 Len := Len + 1;
251 Buffer (Len) := Buffer (J);
252 end if;
253 end loop;
254
255 return;
256 end Krunch;