]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- K R U N C H -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
748086b7 | 9 | -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- |
38cbfe40 RK |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
38cbfe40 RK |
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 -- | |
748086b7 | 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
38cbfe40 | 17 | -- -- |
748086b7 JJ |
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. -- | |
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/>. -- | |
38cbfe40 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | with Hostparm; | |
d26dc4b5 | 33 | |
38cbfe40 | 34 | procedure Krunch |
ac3b962e VC |
35 | (Buffer : in out String; |
36 | Len : in out Natural; | |
37 | Maxlen : Natural; | |
38 | No_Predef : Boolean; | |
39 | VMS_On_Target : Boolean := False) | |
38cbfe40 RK |
40 | |
41 | is | |
ac3b962e VC |
42 | pragma Assert (Buffer'First = 1); |
43 | -- This is a documented requirement; the assert turns off index warnings | |
44 | ||
38cbfe40 RK |
45 | B1 : Character renames Buffer (1); |
46 | Curlen : Natural; | |
47 | Krlen : Natural; | |
48 | Num_Seps : Natural; | |
49 | Startloc : Natural; | |
82c80734 | 50 | J : Natural; |
38cbfe40 RK |
51 | |
52 | begin | |
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. | |
56 | ||
57 | if No_Predef then | |
58 | Startloc := 1; | |
59 | Curlen := Len; | |
60 | Krlen := Maxlen; | |
61 | ||
62 | elsif Len >= 18 | |
63 | and then Buffer (1 .. 17) = "ada-wide_text_io-" | |
64 | then | |
65 | Startloc := 3; | |
66 | Buffer (2 .. 5) := "-wt-"; | |
67 | Buffer (6 .. Len - 12) := Buffer (18 .. Len); | |
68 | Curlen := Len - 12; | |
69 | Krlen := 8; | |
70 | ||
82c80734 RD |
71 | elsif Len >= 23 |
72 | and then Buffer (1 .. 22) = "ada-wide_wide_text_io-" | |
73 | then | |
74 | Startloc := 3; | |
75 | Buffer (2 .. 5) := "-zt-"; | |
76 | Buffer (6 .. Len - 17) := Buffer (23 .. Len); | |
77 | Curlen := Len - 17; | |
78 | Krlen := 8; | |
79 | ||
38cbfe40 RK |
80 | elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then |
81 | Startloc := 3; | |
82 | Buffer (2 .. Len - 2) := Buffer (4 .. Len); | |
83 | Curlen := Len - 2; | |
84 | Krlen := 8; | |
85 | ||
86 | elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then | |
87 | Startloc := 3; | |
88 | Buffer (2 .. Len - 3) := Buffer (5 .. Len); | |
89 | Curlen := Len - 3; | |
90 | Krlen := 8; | |
91 | ||
92 | elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then | |
93 | Startloc := 3; | |
94 | Buffer (2 .. Len - 5) := Buffer (7 .. Len); | |
95 | Curlen := Len - 5; | |
96 | Krlen := 8; | |
97 | ||
98 | elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then | |
99 | Startloc := 3; | |
100 | Buffer (2 .. Len - 9) := Buffer (11 .. Len); | |
101 | Curlen := Len - 9; | |
102 | Krlen := 8; | |
103 | ||
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. | |
107 | ||
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") | |
115 | then | |
116 | Startloc := 1; | |
117 | Krlen := 8; | |
118 | Curlen := Len; | |
119 | ||
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 | |
ac3b962e | 124 | -- in a file name, two consecutive underlines ("__") are used instead. |
38cbfe40 RK |
125 | |
126 | elsif Len > 1 | |
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 | |
130 | then | |
a99ada67 | 131 | -- When VMS is the host, it is always also the target |
ac3b962e VC |
132 | |
133 | if Hostparm.OpenVMS or else VMS_On_Target then | |
134 | Len := Len + 1; | |
135 | Buffer (4 .. Len) := Buffer (3 .. Len - 1); | |
136 | Buffer (2) := '_'; | |
137 | Buffer (3) := '_'; | |
38cbfe40 RK |
138 | else |
139 | Buffer (2) := '~'; | |
140 | end if; | |
141 | ||
ac3b962e VC |
142 | if Len <= Maxlen then |
143 | return; | |
144 | ||
145 | else | |
146 | -- Case of VMS when the buffer had exactly the length Maxlen and now | |
147 | -- has the length Maxlen + 1: krunching after "__" is needed. | |
148 | ||
149 | Startloc := 4; | |
150 | Curlen := Len; | |
151 | Krlen := Maxlen; | |
152 | end if; | |
38cbfe40 RK |
153 | |
154 | -- Normal case, not a predefined file | |
155 | ||
156 | else | |
157 | Startloc := 1; | |
158 | Curlen := Len; | |
159 | Krlen := Maxlen; | |
160 | end if; | |
161 | ||
162 | -- Immediate return if file name is short enough now | |
163 | ||
164 | if Curlen <= Krlen then | |
165 | Len := Curlen; | |
166 | return; | |
167 | end if; | |
168 | ||
82c80734 RD |
169 | -- If string contains Wide_Wide, replace by a single z |
170 | ||
171 | J := Startloc; | |
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) = '_') | |
180 | then | |
181 | Buffer (J) := 'z'; | |
182 | Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen); | |
183 | Curlen := Curlen - 8; | |
184 | end if; | |
185 | ||
186 | J := J + 1; | |
187 | end loop; | |
188 | ||
38cbfe40 RK |
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 ??? | |
191 | ||
192 | for J in 1 .. Curlen loop | |
193 | if Buffer (J) = ASCII.ESC then | |
194 | return; | |
195 | end if; | |
196 | end loop; | |
197 | ||
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 | |
201 | ||
202 | Num_Seps := 0; | |
38cbfe40 RK |
203 | for J in Startloc .. Curlen loop |
204 | if Buffer (J) = '-' or else Buffer (J) = '_' then | |
205 | Buffer (J) := ' '; | |
206 | Num_Seps := Num_Seps + 1; | |
207 | end if; | |
208 | end loop; | |
209 | ||
210 | -- Now we do the one character at a time krunch till we are short enough | |
211 | ||
212 | while Curlen - Num_Seps > Krlen loop | |
213 | declare | |
214 | Long_Length : Natural := 0; | |
215 | Long_Last : Natural := 0; | |
216 | Piece_Start : Natural; | |
217 | Ptr : Natural; | |
218 | ||
219 | begin | |
220 | Ptr := Startloc; | |
221 | ||
222 | -- Loop through pieces to find longest piece | |
223 | ||
224 | while Ptr <= Curlen loop | |
225 | Piece_Start := Ptr; | |
226 | ||
227 | -- Loop through characters in one piece of name | |
228 | ||
229 | while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop | |
230 | Ptr := Ptr + 1; | |
231 | end loop; | |
232 | ||
233 | if Ptr - Piece_Start > Long_Length then | |
234 | Long_Length := Ptr - Piece_Start; | |
235 | Long_Last := Ptr - 1; | |
236 | end if; | |
237 | ||
238 | Ptr := Ptr + 1; | |
239 | end loop; | |
240 | ||
241 | -- Remove last character of longest piece | |
242 | ||
243 | if Long_Last < Curlen then | |
244 | Buffer (Long_Last .. Curlen - 1) := | |
245 | Buffer (Long_Last + 1 .. Curlen); | |
246 | end if; | |
247 | ||
248 | Curlen := Curlen - 1; | |
249 | end; | |
250 | end loop; | |
251 | ||
252 | -- Final step, remove the spaces | |
253 | ||
254 | Len := 0; | |
255 | ||
256 | for J in 1 .. Curlen loop | |
257 | if Buffer (J) /= ' ' then | |
258 | Len := Len + 1; | |
259 | Buffer (Len) := Buffer (J); | |
260 | end if; | |
261 | end loop; | |
262 | ||
263 | return; | |
264 | ||
265 | end Krunch; |