libgfortran/intrinsics/string_intrinsics_inc.c

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