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