1 /* String intrinsics helper functions.
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
4 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
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)
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
);
47 extern void adjustl (CHARTYPE
*, gfc_charlen_type
, const CHARTYPE
*);
48 export_proto(adjustl
);
50 extern void adjustr (CHARTYPE
*, gfc_charlen_type
, const CHARTYPE
*);
51 export_proto(adjustr
);
53 extern gfc_charlen_type
string_index (gfc_charlen_type
, const CHARTYPE
*,
54 gfc_charlen_type
, const CHARTYPE
*,
56 export_proto(string_index
);
58 extern gfc_charlen_type
string_scan (gfc_charlen_type
, const CHARTYPE
*,
59 gfc_charlen_type
, const CHARTYPE
*,
61 export_proto(string_scan
);
63 extern gfc_charlen_type
string_verify (gfc_charlen_type
, const CHARTYPE
*,
64 gfc_charlen_type
, const CHARTYPE
*,
66 export_proto(string_verify
);
68 extern void string_trim (gfc_charlen_type
*, CHARTYPE
**, gfc_charlen_type
,
70 export_proto(string_trim
);
72 extern void string_minmax (gfc_charlen_type
*, CHARTYPE
**, int, int, ...);
73 export_proto(string_minmax
);
76 /* Use for functions which can return a zero-length string. */
77 static CHARTYPE zero_length_string
= 0;
80 /* Strings of unequal length are extended with pad characters. */
83 compare_string (gfc_charlen_type len1
, const CHARTYPE
*s1
,
84 gfc_charlen_type len2
, const CHARTYPE
*s2
)
90 res
= MEMCMP (s1
, s2
, ((len1
< len2
) ? len1
: len2
));
100 s
= (UCHARTYPE
*) &s2
[len1
];
106 s
= (UCHARTYPE
*) &s1
[len2
];
124 iexport(compare_string
);
127 /* The destination and source should not overlap. */
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
)
136 memcpy (dest
, s1
, destlen
* sizeof (CHARTYPE
));
139 memcpy (dest
, s1
, len1
* sizeof (CHARTYPE
));
145 memcpy (dest
, s2
, destlen
* sizeof (CHARTYPE
));
149 memcpy (dest
, s2
, len2
* sizeof (CHARTYPE
));
150 MEMSET (&dest
[len2
], ' ', destlen
- len2
);
154 /* Return string with all trailing blanks removed. */
157 string_trim (gfc_charlen_type
*len
, CHARTYPE
**dest
, gfc_charlen_type slen
,
160 *len
= string_len_trim (slen
, src
);
163 *dest
= &zero_length_string
;
166 /* Allocate space for result string. */
167 *dest
= xmallocarray (*len
, sizeof (CHARTYPE
));
169 /* Copy string if necessary. */
170 memcpy (*dest
, src
, *len
* sizeof (CHARTYPE
));
175 /* The length of a string not including trailing blanks. */
178 string_len_trim (gfc_charlen_type len
, const CHARTYPE
*s
)
180 const gfc_charlen_type long_len
= (gfc_charlen_type
) sizeof (unsigned long);
185 /* If we've got the standard (KIND=1) character type, we scan the string in
186 long word chunks to speed it up (until a long word is hit that does not
188 if (sizeof (CHARTYPE
) == 1 && i
>= long_len
)
191 unsigned long blank_longword
;
193 /* Handle the first characters until we're aligned on a long word
194 boundary. Actually, s + i + 1 must be properly aligned, because
195 s + i will be the last byte of a long word read. */
196 starting
= ((unsigned long)
197 #ifdef __INTPTR_TYPE__
200 (s
+ i
+ 1)) % long_len
;
202 for (; starting
> 0; --starting
)
203 if (s
[i
+ starting
] != ' ')
204 return i
+ starting
+ 1;
206 /* Handle the others in a batch until first non-blank long word is
207 found. Here again, s + i is the last byte of the current chunk,
208 to it starts at s + i - sizeof (long) + 1. */
210 #if __SIZEOF_LONG__ == 4
211 blank_longword
= 0x20202020L
;
212 #elif __SIZEOF_LONG__ == 8
213 blank_longword
= 0x2020202020202020L
;
215 #error Invalid size of long!
218 while (i
>= long_len
)
221 if (*((unsigned long*) (s
+ i
+ 1)) != blank_longword
)
229 /* Simply look for the first non-blank character. */
240 /* Find a substring within a string. */
243 string_index (gfc_charlen_type slen
, const CHARTYPE
*str
,
244 gfc_charlen_type sslen
, const CHARTYPE
*sstr
,
247 gfc_charlen_type start
, last
, delta
, i
;
250 return back
? (slen
+ 1) : 1;
257 last
= slen
+ 1 - sslen
;
264 start
= slen
- sslen
;
268 for (; start
!= last
; start
+= delta
)
270 for (i
= 0; i
< sslen
; i
++)
272 if (str
[start
+ i
] != sstr
[i
])
282 /* Remove leading blanks from a string, padding at end. The src and dest
283 should not overlap. */
286 adjustl (CHARTYPE
*dest
, gfc_charlen_type len
, const CHARTYPE
*src
)
291 while (i
< len
&& src
[i
] == ' ')
295 memcpy (dest
, &src
[i
], (len
- i
) * sizeof (CHARTYPE
));
297 MEMSET (&dest
[len
- i
], ' ', i
);
301 /* Remove trailing blanks from a string. */
304 adjustr (CHARTYPE
*dest
, gfc_charlen_type len
, const CHARTYPE
*src
)
309 while (i
> 0 && src
[i
- 1] == ' ')
313 MEMSET (dest
, ' ', len
- i
);
314 memcpy (&dest
[len
- i
], src
, i
* sizeof (CHARTYPE
));
318 /* Scan a string for any one of the characters in a set of characters. */
321 string_scan (gfc_charlen_type slen
, const CHARTYPE
*str
,
322 gfc_charlen_type setlen
, const CHARTYPE
*set
, GFC_LOGICAL_4 back
)
324 gfc_charlen_type i
, j
;
326 if (slen
== 0 || setlen
== 0)
331 for (i
= slen
; i
!= 0; i
--)
333 for (j
= 0; j
< setlen
; j
++)
335 if (str
[i
- 1] == set
[j
])
342 for (i
= 0; i
< slen
; i
++)
344 for (j
= 0; j
< setlen
; j
++)
346 if (str
[i
] == set
[j
])
356 /* Verify that a set of characters contains all the characters in a
357 string by identifying the position of the first character in a
358 characters that does not appear in a given set of characters. */
361 string_verify (gfc_charlen_type slen
, const CHARTYPE
*str
,
362 gfc_charlen_type setlen
, const CHARTYPE
*set
,
365 gfc_charlen_type start
, last
, delta
, i
;
382 for (; start
!= last
; start
+= delta
)
384 for (i
= 0; i
< setlen
; i
++)
386 if (str
[start
] == set
[i
])
397 /* MIN and MAX intrinsics for strings. The front-end makes sure that
398 nargs is at least 2. */
401 string_minmax (gfc_charlen_type
*rlen
, CHARTYPE
**dest
, int op
, int nargs
, ...)
405 CHARTYPE
*next
, *res
;
406 gfc_charlen_type nextlen
, reslen
;
408 va_start (ap
, nargs
);
409 reslen
= va_arg (ap
, gfc_charlen_type
);
410 res
= va_arg (ap
, CHARTYPE
*);
414 runtime_error ("First argument of '%s' intrinsic should be present",
415 op
> 0 ? "MAX" : "MIN");
417 for (i
= 1; i
< nargs
; i
++)
419 nextlen
= va_arg (ap
, gfc_charlen_type
);
420 next
= va_arg (ap
, CHARTYPE
*);
425 runtime_error ("Second argument of '%s' intrinsic should be "
426 "present", op
> 0 ? "MAX" : "MIN");
434 if (op
* compare_string (reslen
, res
, nextlen
, next
) < 0)
443 *dest
= &zero_length_string
;
446 CHARTYPE
*tmp
= xmallocarray (*rlen
, sizeof (CHARTYPE
));
447 memcpy (tmp
, res
, reslen
* sizeof (CHARTYPE
));
448 MEMSET (&tmp
[reslen
], ' ', *rlen
- reslen
);