1 /* String intrinsics helper functions. 2 Copyright (C) 2002-2019 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 } 462