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