libgfortran/intrinsics/string_intrinsics_inc.c

   1 /* String intrinsics helper functions.
   2    Copyright 2002, 2005, 2007, 2008 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 2 of the License, or (at your option) any later version.
  10
  11 In addition to the permissions in the GNU General Public License, the
  12 Free Software Foundation gives you unlimited permission to link the
  13 compiled version of this file into combinations with other programs,
  14 and to distribute those combinations without any restriction coming
  15 from the use of this file.  (The General Public License restrictions
  16 do apply in other respects; for example, they cover modification of
  17 the file, and distribution when not linked into a combine
  18 executable.)
  19
  20 Libgfortran is distributed in the hope that it will be useful,
  21 but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 GNU General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public
  26 License along with libgfortran; see the file COPYING.  If not,
  27 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  28 Boston, MA 02110-1301, USA.  */
  29
  30
  31 /* Rename the functions.  */
  32 #define concat_string SUFFIX(concat_string)
  33 #define string_len_trim SUFFIX(string_len_trim)
  34 #define adjustl SUFFIX(adjustl)
  35 #define adjustr SUFFIX(adjustr)
  36 #define string_index SUFFIX(string_index)
  37 #define string_scan SUFFIX(string_scan)
  38 #define string_verify SUFFIX(string_verify)
  39 #define string_trim SUFFIX(string_trim)
  40 #define string_minmax SUFFIX(string_minmax)
  41 #define zero_length_string SUFFIX(zero_length_string)
  42 #define compare_string SUFFIX(compare_string)
  43
  44
  45 /* The prototypes.  */
  46
  47 extern void concat_string (gfc_charlen_type, CHARTYPE *,
  48                            gfc_charlen_type, const CHARTYPE *,
  49                            gfc_charlen_type, const CHARTYPE *);
  50 export_proto(concat_string);
  51
  52 extern gfc_charlen_type string_len_trim (gfc_charlen_type, const CHARTYPE *);
  53 export_proto(string_len_trim);
  54
  55 extern void adjustl (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
  56 export_proto(adjustl);
  57
  58 extern void adjustr (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
  59 export_proto(adjustr);
  60
  61 extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *,
  62                                       gfc_charlen_type, const CHARTYPE *,
  63                                       GFC_LOGICAL_4);
  64 export_proto(string_index);
  65
  66 extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *,
  67                                      gfc_charlen_type, const CHARTYPE *,
  68                                      GFC_LOGICAL_4);
  69 export_proto(string_scan);
  70
  71 extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *,
  72                                        gfc_charlen_type, const CHARTYPE *,
  73                                        GFC_LOGICAL_4);
  74 export_proto(string_verify);
  75
  76 extern void string_trim (gfc_charlen_type *, CHARTYPE **, gfc_charlen_type,
  77                          const CHARTYPE *);
  78 export_proto(string_trim);
  79
  80 extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...);
  81 export_proto(string_minmax);
  82
  83
  84 /* Use for functions which can return a zero-length string.  */
  85 static CHARTYPE zero_length_string = 0;
  86
  87
  88 /* Strings of unequal length are extended with pad characters.  */
  89
  90 int
  91 compare_string (gfc_charlen_type len1, const CHARTYPE *s1,
  92                 gfc_charlen_type len2, const CHARTYPE *s2)
  93 {
  94   const UCHARTYPE *s;
  95   gfc_charlen_type len;
  96   int res;
  97
  98   res = memcmp (s1, s2, ((len1 < len2) ? len1 : len2) * sizeof (CHARTYPE));
  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   gfc_charlen_type i;
 169
 170   /* Determine length of result string.  */
 171   for (i = slen - 1; i >= 0; i--)
 172     {
 173       if (src[i] != ' ')
 174         break;
 175     }
 176   *len = i + 1;
 177
 178   if (*len == 0)
 179     *dest = &zero_length_string;
 180   else
 181     {
 182       /* Allocate space for result string.  */
 183       *dest = internal_malloc_size (*len * sizeof (CHARTYPE));
 184
 185       /* Copy string if necessary.  */
 186       memcpy (*dest, src, *len * sizeof (CHARTYPE));
 187     }
 188 }
 189
 190
 191 /* The length of a string not including trailing blanks.  */
 192
 193 gfc_charlen_type
 194 string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
 195 {
 196   gfc_charlen_type i;
 197
 198   for (i = len - 1; i >= 0; i--)
 199     {
 200       if (s[i] != ' ')
 201         break;
 202     }
 203   return i + 1;
 204 }
 205
 206
 207 /* Find a substring within a string.  */
 208
 209 gfc_charlen_type
 210 string_index (gfc_charlen_type slen, const CHARTYPE *str,
 211               gfc_charlen_type sslen, const CHARTYPE *sstr,
 212               GFC_LOGICAL_4 back)
 213 {
 214   gfc_charlen_type start, last, delta, i;
 215
 216   if (sslen == 0)
 217     return back ? (slen + 1) : 1;
 218
 219   if (sslen > slen)
 220     return 0;
 221
 222   if (!back)
 223     {
 224       last = slen + 1 - sslen;
 225       start = 0;
 226       delta = 1;
 227     }
 228   else
 229     {
 230       last = -1;
 231       start = slen - sslen;
 232       delta = -1;
 233     }
 234
 235   for (; start != last; start+= delta)
 236     {
 237       for (i = 0; i < sslen; i++)
 238         {
 239           if (str[start + i] != sstr[i])
 240             break;
 241         }
 242       if (i == sslen)
 243         return (start + 1);
 244     }
 245   return 0;
 246 }
 247
 248
 249 /* Remove leading blanks from a string, padding at end.  The src and dest
 250    should not overlap.  */
 251
 252 void
 253 adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
 254 {
 255   gfc_charlen_type i;
 256
 257   i = 0;
 258   while (i < len && src[i] == ' ')
 259     i++;
 260
 261   if (i < len)
 262     memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
 263   if (i > 0)
 264     MEMSET (&dest[len - i], ' ', i);
 265 }
 266
 267
 268 /* Remove trailing blanks from a string.  */
 269
 270 void
 271 adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
 272 {
 273   gfc_charlen_type i;
 274
 275   i = len;
 276   while (i > 0 && src[i - 1] == ' ')
 277     i--;
 278
 279   if (i < len)
 280     MEMSET (dest, ' ', len - i);
 281   memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
 282 }
 283
 284
 285 /* Scan a string for any one of the characters in a set of characters.  */
 286
 287 gfc_charlen_type
 288 string_scan (gfc_charlen_type slen, const CHARTYPE *str,
 289              gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
 290 {
 291   gfc_charlen_type i, j;
 292
 293   if (slen == 0 || setlen == 0)
 294     return 0;
 295
 296   if (back)
 297     {
 298       for (i = slen - 1; i >= 0; i--)
 299         {
 300           for (j = 0; j < setlen; j++)
 301             {
 302               if (str[i] == set[j])
 303                 return (i + 1);
 304             }
 305         }
 306     }
 307   else
 308     {
 309       for (i = 0; i < slen; i++)
 310         {
 311           for (j = 0; j < setlen; j++)
 312             {
 313               if (str[i] == set[j])
 314                 return (i + 1);
 315             }
 316         }
 317     }
 318
 319   return 0;
 320 }
 321
 322
 323 /* Verify that a set of characters contains all the characters in a
 324    string by identifying the position of the first character in a
 325    characters that does not appear in a given set of characters.  */
 326
 327 gfc_charlen_type
 328 string_verify (gfc_charlen_type slen, const CHARTYPE *str,
 329                gfc_charlen_type setlen, const CHARTYPE *set,
 330                GFC_LOGICAL_4 back)
 331 {
 332   gfc_charlen_type start, last, delta, i;
 333
 334   if (slen == 0)
 335     return 0;
 336
 337   if (back)
 338     {
 339       last = -1;
 340       start = slen - 1;
 341       delta = -1;
 342     }
 343   else
 344     {
 345       last = slen;
 346       start = 0;
 347       delta = 1;
 348     }
 349   for (; start != last; start += delta)
 350     {
 351       for (i = 0; i < setlen; i++)
 352         {
 353           if (str[start] == set[i])
 354             break;
 355         }
 356       if (i == setlen)
 357         return (start + 1);
 358     }
 359
 360   return 0;
 361 }
 362
 363
 364 /* MIN and MAX intrinsics for strings.  The front-end makes sure that
 365    nargs is at least 2.  */
 366
 367 void
 368 string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
 369 {
 370   va_list ap;
 371   int i;
 372   CHARTYPE *next, *res;
 373   gfc_charlen_type nextlen, reslen;
 374
 375   va_start (ap, nargs);
 376   reslen = va_arg (ap, gfc_charlen_type);
 377   res = va_arg (ap, CHARTYPE *);
 378   *rlen = reslen;
 379
 380   if (res == NULL)
 381     runtime_error ("First argument of '%s' intrinsic should be present",
 382                    op > 0 ? "MAX" : "MIN");
 383
 384   for (i = 1; i < nargs; i++)
 385     {
 386       nextlen = va_arg (ap, gfc_charlen_type);
 387       next = va_arg (ap, CHARTYPE *);
 388
 389       if (next == NULL)
 390         {
 391           if (i == 1)
 392             runtime_error ("Second argument of '%s' intrinsic should be "
 393                            "present", op > 0 ? "MAX" : "MIN");
 394           else
 395             continue;
 396         }
 397
 398       if (nextlen > *rlen)
 399         *rlen = nextlen;
 400
 401       if (op * compare_string (reslen, res, nextlen, next) < 0)
 402         {
 403           reslen = nextlen;
 404           res = next;
 405         }
 406     }
 407   va_end (ap);
 408
 409   if (*rlen == 0)
 410     *dest = &zero_length_string;
 411   else
 412     {
 413       CHARTYPE *tmp = internal_malloc_size (*rlen * sizeof (CHARTYPE));
 414       memcpy (tmp, res, reslen * sizeof (CHARTYPE));
 415       MEMSET (&tmp[reslen], ' ', *rlen - reslen);
 416       *dest = tmp;
 417     }
 418 }