libgfortran/intrinsics/string_intrinsics.c

   1 /* String intrinsics helper functions.
   2    Copyright 2002, 2005, 2007 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU General Public
   9 License as published by the Free Software Foundation; either
  10 version 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31
  32 /* Unlike what the name of this file suggests, we don't actually
  33    implement the Fortran intrinsics here.  At least, not with the
  34    names they have in the standard.  The functions here provide all
  35    the support we need for the standard string intrinsics, and the
  36    compiler translates the actual intrinsics calls to calls to
  37    functions in this file.  */
  38
  39 #include "libgfortran.h"
  40
  41 #include <stdlib.h>
  42 #include <string.h>
  43
  44
  45 /* String functions.  */
  46
  47 extern void concat_string (GFC_INTEGER_4, char *,
  48                            GFC_INTEGER_4, const char *,
  49                            GFC_INTEGER_4, const char *);
  50 export_proto(concat_string);
  51
  52 extern GFC_INTEGER_4 string_len_trim (GFC_INTEGER_4, const char *);
  53 export_proto(string_len_trim);
  54
  55 extern void adjustl (char *, GFC_INTEGER_4, const char *);
  56 export_proto(adjustl);
  57
  58 extern void adjustr (char *, GFC_INTEGER_4, const char *);
  59 export_proto(adjustr);
  60
  61 extern GFC_INTEGER_4 string_index (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
  62                                    const char *, GFC_LOGICAL_4);
  63 export_proto(string_index);
  64
  65 extern GFC_INTEGER_4 string_scan (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
  66                                   const char *, GFC_LOGICAL_4);
  67 export_proto(string_scan);
  68
  69 extern GFC_INTEGER_4 string_verify (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
  70                                     const char *, GFC_LOGICAL_4);
  71 export_proto(string_verify);
  72
  73 extern void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *);
  74 export_proto(string_trim);
  75
  76 extern void string_minmax (GFC_INTEGER_4 *, void **, int, int, ...);
  77 export_proto(string_minmax);
  78
  79
  80 /* Use for functions which can return a zero-length string.  */
  81 static char zero_length_string = '\0';
  82
  83
  84 /* Strings of unequal length are extended with pad characters.  */
  85
  86 int
  87 compare_string (GFC_INTEGER_4 len1, const char * s1,
  88                 GFC_INTEGER_4 len2, const char * s2)
  89 {
  90   int res;
  91   const unsigned char *s;
  92   int len;
  93
  94   res = memcmp (s1, s2, (len1 < len2) ? len1 : len2);
  95   if (res != 0)
  96     return res;
  97
  98   if (len1 == len2)
  99     return 0;
 100
 101   if (len1 < len2)
 102     {
 103       len = len2 - len1;
 104       s = (unsigned char *) &s2[len1];
 105       res = -1;
 106     }
 107   else
 108     {
 109       len = len1 - len2;
 110       s = (unsigned char *) &s1[len2];
 111       res = 1;
 112     }
 113
 114   while (len--)
 115     {
 116       if (*s != ' ')
 117         {
 118           if (*s > ' ')
 119             return res;
 120           else
 121             return -res;
 122         }
 123       s++;
 124     }
 125
 126   return 0;
 127 }
 128 iexport(compare_string);
 129
 130
 131 /* The destination and source should not overlap.  */
 132
 133 void
 134 concat_string (GFC_INTEGER_4 destlen, char * dest,
 135                GFC_INTEGER_4 len1, const char * s1,
 136                GFC_INTEGER_4 len2, const char * s2)
 137 {
 138   if (len1 >= destlen)
 139     {
 140       memcpy (dest, s1, destlen);
 141       return;
 142     }
 143   memcpy (dest, s1, len1);
 144   dest += len1;
 145   destlen -= len1;
 146
 147   if (len2 >= destlen)
 148     {
 149       memcpy (dest, s2, destlen);
 150       return;
 151     }
 152
 153   memcpy (dest, s2, len2);
 154   memset (&dest[len2], ' ', destlen - len2);
 155 }
 156
 157
 158 /* Return string with all trailing blanks removed.  */
 159
 160 void
 161 string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen,
 162              const char * src)
 163 {
 164   int i;
 165
 166   /* Determine length of result string.  */
 167   for (i = slen - 1; i >= 0; i--)
 168     {
 169       if (src[i] != ' ')
 170         break;
 171     }
 172   *len = i + 1;
 173
 174   if (*len == 0)
 175     *dest = &zero_length_string;
 176   else
 177     {
 178       /* Allocate space for result string.  */
 179       *dest = internal_malloc_size (*len);
 180
 181       /* Copy string if necessary.  */
 182       memmove (*dest, src, *len);
 183     }
 184 }
 185
 186
 187 /* The length of a string not including trailing blanks.  */
 188
 189 GFC_INTEGER_4
 190 string_len_trim (GFC_INTEGER_4 len, const char * s)
 191 {
 192   int i;
 193
 194   for (i = len - 1; i >= 0; i--)
 195     {
 196       if (s[i] != ' ')
 197         break;
 198     }
 199   return i + 1;
 200 }
 201
 202
 203 /* Find a substring within a string.  */
 204
 205 GFC_INTEGER_4
 206 string_index (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 sslen,
 207               const char * sstr, GFC_LOGICAL_4 back)
 208 {
 209   int start;
 210   int last;
 211   int i;
 212   int delta;
 213
 214   if (sslen == 0)
 215     return 1;
 216
 217   if (sslen > slen)
 218     return 0;
 219
 220   if (!back)
 221     {
 222       last = slen + 1 - sslen;
 223       start = 0;
 224       delta = 1;
 225     }
 226   else
 227     {
 228       last = -1;
 229       start = slen - sslen;
 230       delta = -1;
 231     }
 232   i = 0;
 233   for (; start != last; start+= delta)
 234     {
 235       for (i = 0; i < sslen; i++)
 236         {
 237           if (str[start + i] != sstr[i])
 238             break;
 239         }
 240       if (i == sslen)
 241         return (start + 1);
 242     }
 243   return 0;
 244 }
 245
 246
 247 /* Remove leading blanks from a string, padding at end.  The src and dest
 248    should not overlap.  */
 249
 250 void
 251 adjustl (char *dest, GFC_INTEGER_4 len, const char *src)
 252 {
 253   int i;
 254
 255   i = 0;
 256   while (i<len && src[i] == ' ')
 257     i++;
 258
 259   if (i < len)
 260     memcpy (dest, &src[i], len - i);
 261   if (i > 0)
 262     memset (&dest[len - i], ' ', i);
 263 }
 264
 265
 266 /* Remove trailing blanks from a string.  */
 267
 268 void
 269 adjustr (char *dest, GFC_INTEGER_4 len, const char *src)
 270 {
 271   int i;
 272
 273   i = len;
 274   while (i > 0 && src[i - 1] == ' ')
 275     i--;
 276
 277   if (i < len)
 278     memset (dest, ' ', len - i);
 279   memcpy (dest + (len - i), src, i );
 280 }
 281
 282
 283 /* Scan a string for any one of the characters in a set of characters.  */
 284
 285 GFC_INTEGER_4
 286 string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 287              const char * set, GFC_LOGICAL_4 back)
 288 {
 289   int i, j;
 290
 291   if (slen == 0 || setlen == 0)
 292     return 0;
 293
 294   if (back)
 295     {
 296       for (i = slen - 1; i >= 0; i--)
 297         {
 298           for (j = 0; j < setlen; j++)
 299             {
 300               if (str[i] == set[j])
 301                 return (i + 1);
 302             }
 303         }
 304     }
 305   else
 306     {
 307       for (i = 0; i < slen; i++)
 308         {
 309           for (j = 0; j < setlen; j++)
 310             {
 311               if (str[i] == set[j])
 312                 return (i + 1);
 313             }
 314         }
 315     }
 316
 317   return 0;
 318 }
 319
 320
 321 /* Verify that a set of characters contains all the characters in a
 322    string by identifying the position of the first character in a
 323    characters that does not appear in a given set of characters.  */
 324
 325 GFC_INTEGER_4
 326 string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 327                const char * set, GFC_LOGICAL_4 back)
 328 {
 329   int start;
 330   int last;
 331   int i;
 332   int delta;
 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_INTEGER_4 *rlen, void **dest, int op, int nargs, ...)
 369 {
 370   va_list ap;
 371   int i;
 372   char * next, * res;
 373   GFC_INTEGER_4 nextlen, reslen;
 374
 375   va_start (ap, nargs);
 376   reslen = va_arg (ap, GFC_INTEGER_4);
 377   res = va_arg (ap, char *);
 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_INTEGER_4);
 387       next = va_arg (ap, char *);
 388
 389
 390       if (next == NULL)
 391         {
 392           if (i == 1)
 393             runtime_error ("Second argument of '%s' intrinsic should be "
 394                            "present", op > 0 ? "MAX" : "MIN");
 395           else
 396             continue;
 397         }
 398
 399       if (nextlen > *rlen)
 400         *rlen = nextlen;
 401
 402       if (op * compare_string (reslen, res, nextlen, next) < 0)
 403         {
 404           reslen = nextlen;
 405           res = next;
 406         }
 407     }
 408   va_end (ap);
 409
 410   if (*rlen == 0)
 411     *dest = &zero_length_string;
 412   else
 413     {
 414       char * tmp = internal_malloc_size (*rlen);
 415       memcpy (tmp, res, reslen);
 416       memset (&tmp[reslen], ' ', *rlen - reslen);
 417       *dest = tmp;
 418     }
 419 }