1 /* String intrinsics helper functions.
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public
8 License as published by the Free Software Foundation; either
9 version 3 of the License, or (at your option) any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
19
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23 <http://www.gnu.org/licenses/>. */
24
25
26 /* Rename the functions. */
27 #define concat_string SUFFIX(concat_string)
28 #define string_len_trim SUFFIX(string_len_trim)
29 #define adjustl SUFFIX(adjustl)
30 #define adjustr SUFFIX(adjustr)
31 #define string_index SUFFIX(string_index)
32 #define string_scan SUFFIX(string_scan)
33 #define string_verify SUFFIX(string_verify)
34 #define string_trim SUFFIX(string_trim)
35 #define string_minmax SUFFIX(string_minmax)
36 #define zero_length_string SUFFIX(zero_length_string)
37 #define compare_string SUFFIX(compare_string)
38
39
40 /* The prototypes. */
41
42 extern void concat_string (gfc_charlen_type, CHARTYPE *,
43 gfc_charlen_type, const CHARTYPE *,
44 gfc_charlen_type, const CHARTYPE *);
45 export_proto(concat_string);
46
47 extern void adjustl (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
48 export_proto(adjustl);
49
50 extern void adjustr (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
51 export_proto(adjustr);
52
53 extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *,
54 gfc_charlen_type, const CHARTYPE *,
55 GFC_LOGICAL_4);
56 export_proto(string_index);
57
58 extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *,
59 gfc_charlen_type, const CHARTYPE *,
60 GFC_LOGICAL_4);
61 export_proto(string_scan);
62
63 extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *,
64 gfc_charlen_type, const CHARTYPE *,
65 GFC_LOGICAL_4);
66 export_proto(string_verify);
67
68 extern void string_trim (gfc_charlen_type *, CHARTYPE **, gfc_charlen_type,
69 const CHARTYPE *);
70 export_proto(string_trim);
71
72 extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...);
73 export_proto(string_minmax);
74
75
76 /* Use for functions which can return a zero-length string. */
77 static CHARTYPE zero_length_string = 0;
78
79
80 /* Strings of unequal length are extended with pad characters. */
81
82 int
compare_string(gfc_charlen_type len1,const CHARTYPE * s1,gfc_charlen_type len2,const CHARTYPE * s2)83 compare_string (gfc_charlen_type len1, const CHARTYPE *s1,
84 gfc_charlen_type len2, const CHARTYPE *s2)
85 {
86 const UCHARTYPE *s;
87 gfc_charlen_type len;
88 int res;
89
90 res = MEMCMP (s1, s2, ((len1 < len2) ? len1 : len2));
91 if (res != 0)
92 return res;
93
94 if (len1 == len2)
95 return 0;
96
97 if (len1 < len2)
98 {
99 len = len2 - len1;
100 s = (UCHARTYPE *) &s2[len1];
101 res = -1;
102 }
103 else
104 {
105 len = len1 - len2;
106 s = (UCHARTYPE *) &s1[len2];
107 res = 1;
108 }
109
110 while (len--)
111 {
112 if (*s != ' ')
113 {
114 if (*s > ' ')
115 return res;
116 else
117 return -res;
118 }
119 s++;
120 }
121
122 return 0;
123 }
124 iexport(compare_string);
125
126
127 /* The destination and source should not overlap. */
128
129 void
concat_string(gfc_charlen_type destlen,CHARTYPE * dest,gfc_charlen_type len1,const CHARTYPE * s1,gfc_charlen_type len2,const CHARTYPE * s2)130 concat_string (gfc_charlen_type destlen, CHARTYPE * dest,
131 gfc_charlen_type len1, const CHARTYPE * s1,
132 gfc_charlen_type len2, const CHARTYPE * s2)
133 {
134 if (len1 >= destlen)
135 {
136 memcpy (dest, s1, destlen * sizeof (CHARTYPE));
137 return;
138 }
139 memcpy (dest, s1, len1 * sizeof (CHARTYPE));
140 dest += len1;
141 destlen -= len1;
142
143 if (len2 >= destlen)
144 {
145 memcpy (dest, s2, destlen * sizeof (CHARTYPE));
146 return;
147 }
148
149 memcpy (dest, s2, len2 * sizeof (CHARTYPE));
150 MEMSET (&dest[len2], ' ', destlen - len2);
151 }
152
153
154 /* Return string with all trailing blanks removed. */
155
156 void
string_trim(gfc_charlen_type * len,CHARTYPE ** dest,gfc_charlen_type slen,const CHARTYPE * src)157 string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen,
158 const CHARTYPE *src)
159 {
160 *len = string_len_trim (slen, src);
161
162 if (*len == 0)
163 *dest = &zero_length_string;
164 else
165 {
166 /* Allocate space for result string. */
167 *dest = xmallocarray (*len, sizeof (CHARTYPE));
168
169 /* Copy string if necessary. */
170 memcpy (*dest, src, *len * sizeof (CHARTYPE));
171 }
172 }
173
174
175 /* The length of a string not including trailing blanks. */
176
177 gfc_charlen_type
string_len_trim(gfc_charlen_type len,const CHARTYPE * s)178 string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
179 {
180 if (len <= 0)
181 return 0;
182
183 const size_t long_len = sizeof (unsigned long);
184
185 size_t i = len - 1;
186
187 /* If we've got the standard (KIND=1) character type, we scan the string in
188 long word chunks to speed it up (until a long word is hit that does not
189 consist of ' 's). */
190 if (sizeof (CHARTYPE) == 1 && i >= long_len)
191 {
192 size_t starting;
193 unsigned long blank_longword;
194
195 /* Handle the first characters until we're aligned on a long word
196 boundary. Actually, s + i + 1 must be properly aligned, because
197 s + i will be the last byte of a long word read. */
198 starting = (
199 #ifdef __INTPTR_TYPE__
200 (__INTPTR_TYPE__)
201 #endif
202 (s + i + 1)) % long_len;
203 i -= starting;
204 for (; starting > 0; --starting)
205 if (s[i + starting] != ' ')
206 return i + starting + 1;
207
208 /* Handle the others in a batch until first non-blank long word is
209 found. Here again, s + i is the last byte of the current chunk,
210 to it starts at s + i - sizeof (long) + 1. */
211
212 #if __SIZEOF_LONG__ == 4
213 blank_longword = 0x20202020L;
214 #elif __SIZEOF_LONG__ == 8
215 blank_longword = 0x2020202020202020L;
216 #else
217 #error Invalid size of long!
218 #endif
219
220 while (i >= long_len)
221 {
222 i -= long_len;
223 if (*((unsigned long*) (s + i + 1)) != blank_longword)
224 {
225 i += long_len;
226 break;
227 }
228 }
229 }
230
231 /* Simply look for the first non-blank character. */
232 while (s[i] == ' ')
233 {
234 if (i == 0)
235 return 0;
236 --i;
237 }
238 return i + 1;
239 }
240
241
242 /* Find a substring within a string. */
243
244 gfc_charlen_type
string_index(gfc_charlen_type slen,const CHARTYPE * str,gfc_charlen_type sslen,const CHARTYPE * sstr,GFC_LOGICAL_4 back)245 string_index (gfc_charlen_type slen, const CHARTYPE *str,
246 gfc_charlen_type sslen, const CHARTYPE *sstr,
247 GFC_LOGICAL_4 back)
248 {
249 gfc_charlen_type start, last, delta, i;
250
251 if (sslen == 0)
252 return back ? (slen + 1) : 1;
253
254 if (sslen > slen)
255 return 0;
256
257 if (!back)
258 {
259 last = slen + 1 - sslen;
260 start = 0;
261 delta = 1;
262 }
263 else
264 {
265 last = -1;
266 start = slen - sslen;
267 delta = -1;
268 }
269
270 for (; start != last; start+= delta)
271 {
272 for (i = 0; i < sslen; i++)
273 {
274 if (str[start + i] != sstr[i])
275 break;
276 }
277 if (i == sslen)
278 return (start + 1);
279 }
280 return 0;
281 }
282
283
284 /* Remove leading blanks from a string, padding at end. The src and dest
285 should not overlap. */
286
287 void
adjustl(CHARTYPE * dest,gfc_charlen_type len,const CHARTYPE * src)288 adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
289 {
290 gfc_charlen_type i;
291
292 i = 0;
293 while (i < len && src[i] == ' ')
294 i++;
295
296 if (i < len)
297 memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
298 if (i > 0)
299 MEMSET (&dest[len - i], ' ', i);
300 }
301
302
303 /* Remove trailing blanks from a string. */
304
305 void
adjustr(CHARTYPE * dest,gfc_charlen_type len,const CHARTYPE * src)306 adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
307 {
308 gfc_charlen_type i;
309
310 i = len;
311 while (i > 0 && src[i - 1] == ' ')
312 i--;
313
314 if (i < len)
315 MEMSET (dest, ' ', len - i);
316 memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
317 }
318
319
320 /* Scan a string for any one of the characters in a set of characters. */
321
322 gfc_charlen_type
string_scan(gfc_charlen_type slen,const CHARTYPE * str,gfc_charlen_type setlen,const CHARTYPE * set,GFC_LOGICAL_4 back)323 string_scan (gfc_charlen_type slen, const CHARTYPE *str,
324 gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
325 {
326 gfc_charlen_type i, j;
327
328 if (slen == 0 || setlen == 0)
329 return 0;
330
331 if (back)
332 {
333 for (i = slen; i != 0; i--)
334 {
335 for (j = 0; j < setlen; j++)
336 {
337 if (str[i - 1] == set[j])
338 return i;
339 }
340 }
341 }
342 else
343 {
344 for (i = 0; i < slen; i++)
345 {
346 for (j = 0; j < setlen; j++)
347 {
348 if (str[i] == set[j])
349 return (i + 1);
350 }
351 }
352 }
353
354 return 0;
355 }
356
357
358 /* Verify that a set of characters contains all the characters in a
359 string by identifying the position of the first character in a
360 characters that does not appear in a given set of characters. */
361
362 gfc_charlen_type
string_verify(gfc_charlen_type slen,const CHARTYPE * str,gfc_charlen_type setlen,const CHARTYPE * set,GFC_LOGICAL_4 back)363 string_verify (gfc_charlen_type slen, const CHARTYPE *str,
364 gfc_charlen_type setlen, const CHARTYPE *set,
365 GFC_LOGICAL_4 back)
366 {
367 gfc_charlen_type start, last, delta, i;
368
369 if (slen == 0)
370 return 0;
371
372 if (back)
373 {
374 last = -1;
375 start = slen - 1;
376 delta = -1;
377 }
378 else
379 {
380 last = slen;
381 start = 0;
382 delta = 1;
383 }
384 for (; start != last; start += delta)
385 {
386 for (i = 0; i < setlen; i++)
387 {
388 if (str[start] == set[i])
389 break;
390 }
391 if (i == setlen)
392 return (start + 1);
393 }
394
395 return 0;
396 }
397
398
399 /* MIN and MAX intrinsics for strings. The front-end makes sure that
400 nargs is at least 2. */
401
402 void
string_minmax(gfc_charlen_type * rlen,CHARTYPE ** dest,int op,int nargs,...)403 string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
404 {
405 va_list ap;
406 int i;
407 CHARTYPE *next, *res;
408 gfc_charlen_type nextlen, reslen;
409
410 va_start (ap, nargs);
411 reslen = va_arg (ap, gfc_charlen_type);
412 res = va_arg (ap, CHARTYPE *);
413 *rlen = reslen;
414
415 if (res == NULL)
416 runtime_error ("First argument of '%s' intrinsic should be present",
417 op > 0 ? "MAX" : "MIN");
418
419 for (i = 1; i < nargs; i++)
420 {
421 nextlen = va_arg (ap, gfc_charlen_type);
422 next = va_arg (ap, CHARTYPE *);
423
424 if (next == NULL)
425 {
426 if (i == 1)
427 runtime_error ("Second argument of '%s' intrinsic should be "
428 "present", op > 0 ? "MAX" : "MIN");
429 else
430 continue;
431 }
432
433 if (nextlen > *rlen)
434 *rlen = nextlen;
435
436 if (op * compare_string (reslen, res, nextlen, next) < 0)
437 {
438 reslen = nextlen;
439 res = next;
440 }
441 }
442 va_end (ap);
443
444 if (*rlen == 0)
445 *dest = &zero_length_string;
446 else
447 {
448 CHARTYPE *tmp = xmallocarray (*rlen, sizeof (CHARTYPE));
449 memcpy (tmp, res, reslen * sizeof (CHARTYPE));
450 MEMSET (&tmp[reslen], ' ', *rlen - reslen);
451 *dest = tmp;
452 }
453 }
454