libgfortran/intrinsics/string_intrinsics_inc.c

   1 /* String intrinsics helper functions.
   2    Copyright (C) 2002-2017 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   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
 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
 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
 178 string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
 179 {
 180   const gfc_charlen_type long_len = (gfc_charlen_type) sizeof (unsigned long);
 181   gfc_charlen_type i;
 182
 183   i = len - 1;
 184
 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
 187      consist of ' 's).  */
 188   if (sizeof (CHARTYPE) == 1 && i >= long_len)
 189     {
 190       int starting;
 191       unsigned long blank_longword;
 192
 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__
 198                   (__INTPTR_TYPE__)
 199 #endif
 200                   (s + i + 1)) % long_len;
 201       i -= starting;
 202       for (; starting > 0; --starting)
 203         if (s[i + starting] != ' ')
 204           return i + starting + 1;
 205
 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.  */
 209
 210 #if __SIZEOF_LONG__ == 4
 211       blank_longword = 0x20202020L;
 212 #elif __SIZEOF_LONG__ == 8
 213       blank_longword = 0x2020202020202020L;
 214 #else
 215       #error Invalid size of long!
 216 #endif
 217
 218       while (i >= long_len)
 219         {
 220           i -= long_len;
 221           if (*((unsigned long*) (s + i + 1)) != blank_longword)
 222             {
 223               i += long_len;
 224               break;
 225             }
 226         }
 227     }
 228
 229   /* Simply look for the first non-blank character.  */
 230   while (s[i] == ' ')
 231     {
 232       if (i == 0)
 233         return 0;
 234       --i;
 235     }
 236   return i + 1;
 237 }
 238
 239
 240 /* Find a substring within a string.  */
 241
 242 gfc_charlen_type
 243 string_index (gfc_charlen_type slen, const CHARTYPE *str,
 244               gfc_charlen_type sslen, const CHARTYPE *sstr,
 245               GFC_LOGICAL_4 back)
 246 {
 247   gfc_charlen_type start, last, delta, i;
 248
 249   if (sslen == 0)
 250     return back ? (slen + 1) : 1;
 251
 252   if (sslen > slen)
 253     return 0;
 254
 255   if (!back)
 256     {
 257       last = slen + 1 - sslen;
 258       start = 0;
 259       delta = 1;
 260     }
 261   else
 262     {
 263       last = -1;
 264       start = slen - sslen;
 265       delta = -1;
 266     }
 267
 268   for (; start != last; start+= delta)
 269     {
 270       for (i = 0; i < sslen; i++)
 271         {
 272           if (str[start + i] != sstr[i])
 273             break;
 274         }
 275       if (i == sslen)
 276         return (start + 1);
 277     }
 278   return 0;
 279 }
 280
 281
 282 /* Remove leading blanks from a string, padding at end.  The src and dest
 283    should not overlap.  */
 284
 285 void
 286 adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
 287 {
 288   gfc_charlen_type i;
 289
 290   i = 0;
 291   while (i < len && src[i] == ' ')
 292     i++;
 293
 294   if (i < len)
 295     memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
 296   if (i > 0)
 297     MEMSET (&dest[len - i], ' ', i);
 298 }
 299
 300
 301 /* Remove trailing blanks from a string.  */
 302
 303 void
 304 adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
 305 {
 306   gfc_charlen_type i;
 307
 308   i = len;
 309   while (i > 0 && src[i - 1] == ' ')
 310     i--;
 311
 312   if (i < len)
 313     MEMSET (dest, ' ', len - i);
 314   memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
 315 }
 316
 317
 318 /* Scan a string for any one of the characters in a set of characters.  */
 319
 320 gfc_charlen_type
 321 string_scan (gfc_charlen_type slen, const CHARTYPE *str,
 322              gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
 323 {
 324   gfc_charlen_type i, j;
 325
 326   if (slen == 0 || setlen == 0)
 327     return 0;
 328
 329   if (back)
 330     {
 331       for (i = slen; i != 0; i--)
 332         {
 333           for (j = 0; j < setlen; j++)
 334             {
 335               if (str[i - 1] == set[j])
 336                 return i;
 337             }
 338         }
 339     }
 340   else
 341     {
 342       for (i = 0; i < slen; i++)
 343         {
 344           for (j = 0; j < setlen; j++)
 345             {
 346               if (str[i] == set[j])
 347                 return (i + 1);
 348             }
 349         }
 350     }
 351
 352   return 0;
 353 }
 354
 355
 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.  */
 359
 360 gfc_charlen_type
 361 string_verify (gfc_charlen_type slen, const CHARTYPE *str,
 362                gfc_charlen_type setlen, const CHARTYPE *set,
 363                GFC_LOGICAL_4 back)
 364 {
 365   gfc_charlen_type start, last, delta, i;
 366
 367   if (slen == 0)
 368     return 0;
 369
 370   if (back)
 371     {
 372       last = -1;
 373       start = slen - 1;
 374       delta = -1;
 375     }
 376   else
 377     {
 378       last = slen;
 379       start = 0;
 380       delta = 1;
 381     }
 382   for (; start != last; start += delta)
 383     {
 384       for (i = 0; i < setlen; i++)
 385         {
 386           if (str[start] == set[i])
 387             break;
 388         }
 389       if (i == setlen)
 390         return (start + 1);
 391     }
 392
 393   return 0;
 394 }
 395
 396
 397 /* MIN and MAX intrinsics for strings.  The front-end makes sure that
 398    nargs is at least 2.  */
 399
 400 void
 401 string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
 402 {
 403   va_list ap;
 404   int i;
 405   CHARTYPE *next, *res;
 406   gfc_charlen_type nextlen, reslen;
 407
 408   va_start (ap, nargs);
 409   reslen = va_arg (ap, gfc_charlen_type);
 410   res = va_arg (ap, CHARTYPE *);
 411   *rlen = reslen;
 412
 413   if (res == NULL)
 414     runtime_error ("First argument of '%s' intrinsic should be present",
 415                    op > 0 ? "MAX" : "MIN");
 416
 417   for (i = 1; i < nargs; i++)
 418     {
 419       nextlen = va_arg (ap, gfc_charlen_type);
 420       next = va_arg (ap, CHARTYPE *);
 421
 422       if (next == NULL)
 423         {
 424           if (i == 1)
 425             runtime_error ("Second argument of '%s' intrinsic should be "
 426                            "present", op > 0 ? "MAX" : "MIN");
 427           else
 428             continue;
 429         }
 430
 431       if (nextlen > *rlen)
 432         *rlen = nextlen;
 433
 434       if (op * compare_string (reslen, res, nextlen, next) < 0)
 435         {
 436           reslen = nextlen;
 437           res = next;
 438         }
 439     }
 440   va_end (ap);
 441
 442   if (*rlen == 0)
 443     *dest = &zero_length_string;
 444   else
 445     {
 446       CHARTYPE *tmp = xmallocarray (*rlen, sizeof (CHARTYPE));
 447       memcpy (tmp, res, reslen * sizeof (CHARTYPE));
 448       MEMSET (&tmp[reslen], ' ', *rlen - reslen);
 449       *dest = tmp;
 450     }
 451 }