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