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