1 /* String intrinsics helper functions.
2 Copyright (C) 2002-2023 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
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 /* Placate the sanitizer. */
91 if (!s1 && !s2)
92 return 0;
93 if (!s1)
94 return -1;
95 if (!s2)
96 return 1;
97
98 res = MEMCMP (s1, s2, ((len1 < len2) ? len1 : len2));
99 if (res != 0)
100 return res;
101
102 if (len1 == len2)
103 return 0;
104
105 if (len1 < len2)
106 {
107 len = len2 - len1;
108 s = (UCHARTYPE *) &s2[len1];
109 res = -1;
110 }
111 else
112 {
113 len = len1 - len2;
114 s = (UCHARTYPE *) &s1[len2];
115 res = 1;
116 }
117
118 while (len--)
119 {
120 if (*s != ' ')
121 {
122 if (*s > ' ')
123 return res;
124 else
125 return -res;
126 }
127 s++;
128 }
129
130 return 0;
131 }
132 iexport(compare_string);
133
134
135 /* The destination and source should not overlap. */
136
137 void
138 concat_string (gfc_charlen_type destlen, CHARTYPE * dest,
139 gfc_charlen_type len1, const CHARTYPE * s1,
140 gfc_charlen_type len2, const CHARTYPE * s2)
141 {
142 if (len1 >= destlen)
143 {
144 memcpy (dest, s1, destlen * sizeof (CHARTYPE));
145 return;
146 }
147 memcpy (dest, s1, len1 * sizeof (CHARTYPE));
148 dest += len1;
149 destlen -= len1;
150
151 if (len2 >= destlen)
152 {
153 memcpy (dest, s2, destlen * sizeof (CHARTYPE));
154 return;
155 }
156
157 memcpy (dest, s2, len2 * sizeof (CHARTYPE));
158 MEMSET (&dest[len2], ' ', destlen - len2);
159 }
160
161
162 /* Return string with all trailing blanks removed. */
163
164 void
165 string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen,
166 const CHARTYPE *src)
167 {
168 *len = string_len_trim (slen, src);
169
170 if (*len == 0)
171 *dest = &zero_length_string;
172 else
173 {
174 /* Allocate space for result string. */
175 *dest = xmallocarray (*len, sizeof (CHARTYPE));
176
177 /* Copy string if necessary. */
178 memcpy (*dest, src, *len * sizeof (CHARTYPE));
179 }
180 }
181
182
183 /* The length of a string not including trailing blanks. */
184
185 gfc_charlen_type
186 string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
187 {
188 if (len <= 0)
189 return 0;
190
191 const size_t long_len = sizeof (unsigned long);
192
193 size_t i = len - 1;
194
195 /* If we've got the standard (KIND=1) character type, we scan the string in
196 long word chunks to speed it up (until a long word is hit that does not
197 consist of ' 's). */
198 if (sizeof (CHARTYPE) == 1 && i >= long_len)
199 {
200 size_t starting;
201 unsigned long blank_longword;
202
203 /* Handle the first characters until we're aligned on a long word
204 boundary. Actually, s + i + 1 must be properly aligned, because
205 s + i will be the last byte of a long word read. */
206 starting = (
207 #ifdef __INTPTR_TYPE__
208 (__INTPTR_TYPE__)
209 #endif
210 (s + i + 1)) % long_len;
211 i -= starting;
212 for (; starting > 0; --starting)
213 if (s[i + starting] != ' ')
214 return i + starting + 1;
215
216 /* Handle the others in a batch until first non-blank long word is
217 found. Here again, s + i is the last byte of the current chunk,
218 to it starts at s + i - sizeof (long) + 1. */
219
220 #if __SIZEOF_LONG__ == 4
221 blank_longword = 0x20202020L;
222 #elif __SIZEOF_LONG__ == 8
223 blank_longword = 0x2020202020202020L;
224 #else
225 #error Invalid size of long!
226 #endif
227
228 while (i >= long_len)
229 {
230 i -= long_len;
231 if (*((unsigned long*) (s + i + 1)) != blank_longword)
232 {
233 i += long_len;
234 break;
235 }
236 }
237 }
238
239 /* Simply look for the first non-blank character. */
240 while (s[i] == ' ')
241 {
242 if (i == 0)
243 return 0;
244 --i;
245 }
246 return i + 1;
247 }
248
249
250 /* Find a substring within a string. */
251
252 gfc_charlen_type
253 string_index (gfc_charlen_type slen, const CHARTYPE *str,
254 gfc_charlen_type sslen, const CHARTYPE *sstr,
255 GFC_LOGICAL_4 back)
256 {
257 gfc_charlen_type start, last, delta, i;
258
259 if (sslen == 0)
260 return back ? (slen + 1) : 1;
261
262 if (sslen > slen)
263 return 0;
264
265 if (!back)
266 {
267 last = slen + 1 - sslen;
268 start = 0;
269 delta = 1;
270 }
271 else
272 {
273 last = -1;
274 start = slen - sslen;
275 delta = -1;
276 }
277
278 for (; start != last; start+= delta)
279 {
280 for (i = 0; i < sslen; i++)
281 {
282 if (str[start + i] != sstr[i])
283 break;
284 }
285 if (i == sslen)
286 return (start + 1);
287 }
288 return 0;
289 }
290
291
292 /* Remove leading blanks from a string, padding at end. The src and dest
293 should not overlap. */
294
295 void
296 adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
297 {
298 gfc_charlen_type i;
299
300 i = 0;
301 while (i < len && src[i] == ' ')
302 i++;
303
304 if (i < len)
305 memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
306 if (i > 0)
307 MEMSET (&dest[len - i], ' ', i);
308 }
309
310
311 /* Remove trailing blanks from a string. */
312
313 void
314 adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
315 {
316 gfc_charlen_type i;
317
318 i = len;
319 while (i > 0 && src[i - 1] == ' ')
320 i--;
321
322 if (i < len)
323 MEMSET (dest, ' ', len - i);
324 memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
325 }
326
327
328 /* Scan a string for any one of the characters in a set of characters. */
329
330 gfc_charlen_type
331 string_scan (gfc_charlen_type slen, const CHARTYPE *str,
332 gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
333 {
334 gfc_charlen_type i, j;
335
336 if (slen == 0 || setlen == 0)
337 return 0;
338
339 if (back)
340 {
341 for (i = slen; i != 0; i--)
342 {
343 for (j = 0; j < setlen; j++)
344 {
345 if (str[i - 1] == set[j])
346 return i;
347 }
348 }
349 }
350 else
351 {
352 for (i = 0; i < slen; i++)
353 {
354 for (j = 0; j < setlen; j++)
355 {
356 if (str[i] == set[j])
357 return (i + 1);
358 }
359 }
360 }
361
362 return 0;
363 }
364
365
366 /* Verify that a set of characters contains all the characters in a
367 string by identifying the position of the first character in a
368 characters that does not appear in a given set of characters. */
369
370 gfc_charlen_type
371 string_verify (gfc_charlen_type slen, const CHARTYPE *str,
372 gfc_charlen_type setlen, const CHARTYPE *set,
373 GFC_LOGICAL_4 back)
374 {
375 gfc_charlen_type start, last, delta, i;
376
377 if (slen == 0)
378 return 0;
379
380 if (back)
381 {
382 last = -1;
383 start = slen - 1;
384 delta = -1;
385 }
386 else
387 {
388 last = slen;
389 start = 0;
390 delta = 1;
391 }
392 for (; start != last; start += delta)
393 {
394 for (i = 0; i < setlen; i++)
395 {
396 if (str[start] == set[i])
397 break;
398 }
399 if (i == setlen)
400 return (start + 1);
401 }
402
403 return 0;
404 }
405
406
407 /* MIN and MAX intrinsics for strings. The front-end makes sure that
408 nargs is at least 2. */
409
410 void
411 string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
412 {
413 va_list ap;
414 int i;
415 CHARTYPE *next, *res;
416 gfc_charlen_type nextlen, reslen;
417
418 va_start (ap, nargs);
419 reslen = va_arg (ap, gfc_charlen_type);
420 res = va_arg (ap, CHARTYPE *);
421 *rlen = reslen;
422
423 if (res == NULL)
424 runtime_error ("First argument of '%s' intrinsic should be present",
425 op > 0 ? "MAX" : "MIN");
426
427 for (i = 1; i < nargs; i++)
428 {
429 nextlen = va_arg (ap, gfc_charlen_type);
430 next = va_arg (ap, CHARTYPE *);
431
432 if (next == NULL)
433 {
434 if (i == 1)
435 runtime_error ("Second argument of '%s' intrinsic should be "
436 "present", op > 0 ? "MAX" : "MIN");
437 else
438 continue;
439 }
440
441 if (nextlen > *rlen)
442 *rlen = nextlen;
443
444 if (op * compare_string (reslen, res, nextlen, next) < 0)
445 {
446 reslen = nextlen;
447 res = next;
448 }
449 }
450 va_end (ap);
451
452 if (*rlen == 0)
453 *dest = &zero_length_string;
454 else
455 {
456 CHARTYPE *tmp = xmallocarray (*rlen, sizeof (CHARTYPE));
457 memcpy (tmp, res, reslen * sizeof (CHARTYPE));
458 MEMSET (&tmp[reslen], ' ', *rlen - reslen);
459 *dest = tmp;
460 }
461 }