libgfortran/intrinsics/string_intrinsics_inc.c

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