libgfortran/intrinsics/string_intrinsics.c

   1 /* String intrinsics helper functions.
   2    Copyright 2002, 2005 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
  42 #include "libgfortran.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 /* Strings of unequal length are extended with pad characters.  */
  77
  78 GFC_INTEGER_4
  79 compare_string (GFC_INTEGER_4 len1, const char * s1,
  80                 GFC_INTEGER_4 len2, const char * s2)
  81 {
  82   int res;
  83   const unsigned char *s;
  84   int len;
  85
  86   res = memcmp (s1, s2, (len1 < len2) ? len1 : len2);
  87   if (res != 0)
  88     return res;
  89
  90   if (len1 == len2)
  91     return 0;
  92
  93   if (len1 < len2)
  94     {
  95       len = len2 - len1;
  96       s = (unsigned char *) &s2[len1];
  97       res = -1;
  98     }
  99   else
 100     {
 101       len = len1 - len2;
 102       s = (unsigned char *) &s1[len2];
 103       res = 1;
 104     }
 105
 106   while (len--)
 107     {
 108       if (*s != ' ')
 109         {
 110           if (*s > ' ')
 111             return res;
 112           else
 113             return -res;
 114         }
 115       s++;
 116     }
 117
 118   return 0;
 119 }
 120 iexport(compare_string);
 121
 122
 123 /* The destination and source should not overlap.  */
 124
 125 void
 126 concat_string (GFC_INTEGER_4 destlen, char * dest,
 127                GFC_INTEGER_4 len1, const char * s1,
 128                GFC_INTEGER_4 len2, const char * s2)
 129 {
 130   if (len1 >= destlen)
 131     {
 132       memcpy (dest, s1, destlen);
 133       return;
 134     }
 135   memcpy (dest, s1, len1);
 136   dest += len1;
 137   destlen -= len1;
 138
 139   if (len2 >= destlen)
 140     {
 141       memcpy (dest, s2, destlen);
 142       return;
 143     }
 144
 145   memcpy (dest, s2, len2);
 146   memset (&dest[len2], ' ', destlen - len2);
 147 }
 148
 149
 150 /* Return string with all trailing blanks removed.  */
 151
 152 void
 153 string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen,
 154              const char * src)
 155 {
 156   int i;
 157
 158   /* Determine length of result string.  */
 159   for (i = slen - 1; i >= 0; i--)
 160     {
 161       if (src[i] != ' ')
 162         break;
 163     }
 164   *len = i + 1;
 165
 166   if (*len > 0)
 167     {
 168       /* Allocate space for result string.  */
 169       *dest = internal_malloc_size (*len);
 170
 171       /* copy string if necessary.  */
 172       memmove (*dest, src, *len);
 173     }
 174   else
 175     *dest = NULL;
 176 }
 177
 178
 179 /* The length of a string not including trailing blanks.  */
 180
 181 GFC_INTEGER_4
 182 string_len_trim (GFC_INTEGER_4 len, const char * s)
 183 {
 184   int i;
 185
 186   for (i = len - 1; i >= 0; i--)
 187     {
 188       if (s[i] != ' ')
 189         break;
 190     }
 191   return i + 1;
 192 }
 193
 194
 195 /* Find a substring within a string.  */
 196
 197 GFC_INTEGER_4
 198 string_index (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 sslen,
 199               const char * sstr, GFC_LOGICAL_4 back)
 200 {
 201   int start;
 202   int last;
 203   int i;
 204   int delta;
 205
 206   if (sslen == 0)
 207     return 1;
 208
 209   if (sslen > slen)
 210     return 0;
 211
 212   if (!back)
 213     {
 214       last = slen + 1 - sslen;
 215       start = 0;
 216       delta = 1;
 217     }
 218   else
 219     {
 220       last = -1;
 221       start = slen - sslen;
 222       delta = -1;
 223     }
 224   i = 0;
 225   for (; start != last; start+= delta)
 226     {
 227       for (i = 0; i < sslen; i++)
 228         {
 229           if (str[start + i] != sstr[i])
 230             break;
 231         }
 232       if (i == sslen)
 233         return (start + 1);
 234     }
 235   return 0;
 236 }
 237
 238
 239 /* Remove leading blanks from a string, padding at end.  The src and dest
 240    should not overlap.  */
 241
 242 void
 243 adjustl (char *dest, GFC_INTEGER_4 len, const char *src)
 244 {
 245   int i;
 246
 247   i = 0;
 248   while (i<len && src[i] == ' ')
 249     i++;
 250
 251   if (i < len)
 252     memcpy (dest, &src[i], len - i);
 253   if (i > 0)
 254     memset (&dest[len - i], ' ', i);
 255 }
 256
 257
 258 /* Remove trailing blanks from a string.  */
 259
 260 void
 261 adjustr (char *dest, GFC_INTEGER_4 len, const char *src)
 262 {
 263   int i;
 264
 265   i = len;
 266   while (i > 0 && src[i - 1] == ' ')
 267     i--;
 268
 269   if (i < len)
 270     memset (dest, ' ', len - i);
 271   memcpy (dest + (len - i), src, i );
 272 }
 273
 274
 275 /* Scan a string for any one of the characters in a set of characters.  */
 276
 277 GFC_INTEGER_4
 278 string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 279              const char * set, GFC_LOGICAL_4 back)
 280 {
 281   int i, j;
 282
 283   if (slen == 0 || setlen == 0)
 284     return 0;
 285
 286   if (back)
 287     {
 288       for (i = slen - 1; i >= 0; i--)
 289         {
 290           for (j = 0; j < setlen; j++)
 291             {
 292               if (str[i] == set[j])
 293                 return (i + 1);
 294             }
 295         }
 296     }
 297   else
 298     {
 299       for (i = 0; i < slen; i++)
 300         {
 301           for (j = 0; j < setlen; j++)
 302             {
 303               if (str[i] == set[j])
 304                 return (i + 1);
 305             }
 306         }
 307     }
 308
 309   return 0;
 310 }
 311
 312
 313 /* Verify that a set of characters contains all the characters in a
 314    string by identifying the position of the first character in a
 315    characters that does not appear in a given set of characters.  */
 316
 317 GFC_INTEGER_4
 318 string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 319                const char * set, GFC_LOGICAL_4 back)
 320 {
 321   int start;
 322   int last;
 323   int i;
 324   int delta;
 325
 326   if (slen == 0)
 327     return 0;
 328
 329   if (back)
 330     {
 331       last = -1;
 332       start = slen - 1;
 333       delta = -1;
 334     }
 335   else
 336     {
 337       last = slen;
 338       start = 0;
 339       delta = 1;
 340     }
 341   for (; start != last; start += delta)
 342     {
 343       for (i = 0; i < setlen; i++)
 344         {
 345           if (str[start] == set[i])
 346             break;
 347         }
 348       if (i == setlen)
 349         return (start + 1);
 350     }
 351
 352   return 0;
 353 }