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 }
 175
 176
 177 /* The length of a string not including trailing blanks.  */
 178
 179 GFC_INTEGER_4
 180 string_len_trim (GFC_INTEGER_4 len, const char * s)
 181 {
 182   int i;
 183
 184   for (i = len - 1; i >= 0; i--)
 185     {
 186       if (s[i] != ' ')
 187         break;
 188     }
 189   return i + 1;
 190 }
 191
 192
 193 /* Find a substring within a string.  */
 194
 195 GFC_INTEGER_4
 196 string_index (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 sslen,
 197               const char * sstr, GFC_LOGICAL_4 back)
 198 {
 199   int start;
 200   int last;
 201   int i;
 202   int delta;
 203
 204   if (sslen == 0)
 205     return 1;
 206
 207   if (sslen > slen)
 208     return 0;
 209
 210   if (!back)
 211     {
 212       last = slen + 1 - sslen;
 213       start = 0;
 214       delta = 1;
 215     }
 216   else
 217     {
 218       last = -1;
 219       start = slen - sslen;
 220       delta = -1;
 221     }
 222   i = 0;
 223   for (; start != last; start+= delta)
 224     {
 225       for (i = 0; i < sslen; i++)
 226         {
 227           if (str[start + i] != sstr[i])
 228             break;
 229         }
 230       if (i == sslen)
 231         return (start + 1);
 232     }
 233   return 0;
 234 }
 235
 236
 237 /* Remove leading blanks from a string, padding at end.  The src and dest
 238    should not overlap.  */
 239
 240 void
 241 adjustl (char *dest, GFC_INTEGER_4 len, const char *src)
 242 {
 243   int i;
 244
 245   i = 0;
 246   while (i<len && src[i] == ' ')
 247     i++;
 248
 249   if (i < len)
 250     memcpy (dest, &src[i], len - i);
 251   if (i > 0)
 252     memset (&dest[len - i], ' ', i);
 253 }
 254
 255
 256 /* Remove trailing blanks from a string.  */
 257
 258 void
 259 adjustr (char *dest, GFC_INTEGER_4 len, const char *src)
 260 {
 261   int i;
 262
 263   i = len;
 264   while (i > 0 && src[i - 1] == ' ')
 265     i--;
 266
 267   if (i < len)
 268     memset (dest, ' ', len - i);
 269   memcpy (dest + (len - i), src, i );
 270 }
 271
 272
 273 /* Scan a string for any one of the characters in a set of characters.  */
 274
 275 GFC_INTEGER_4
 276 string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 277              const char * set, GFC_LOGICAL_4 back)
 278 {
 279   int i, j;
 280
 281   if (slen == 0 || setlen == 0)
 282     return 0;
 283
 284   if (back)
 285     {
 286       for (i = slen - 1; i >= 0; i--)
 287         {
 288           for (j = 0; j < setlen; j++)
 289             {
 290               if (str[i] == set[j])
 291                 return (i + 1);
 292             }
 293         }
 294     }
 295   else
 296     {
 297       for (i = 0; i < slen; i++)
 298         {
 299           for (j = 0; j < setlen; j++)
 300             {
 301               if (str[i] == set[j])
 302                 return (i + 1);
 303             }
 304         }
 305     }
 306
 307   return 0;
 308 }
 309
 310
 311 /* Verify that a set of characters contains all the characters in a
 312    string by identifying the position of the first character in a
 313    characters that does not appear in a given set of characters.  */
 314
 315 GFC_INTEGER_4
 316 string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 317                const char * set, GFC_LOGICAL_4 back)
 318 {
 319   int start;
 320   int last;
 321   int i;
 322   int delta;
 323
 324   if (slen == 0)
 325     return 0;
 326
 327   if (back)
 328     {
 329       last = -1;
 330       start = slen - 1;
 331       delta = -1;
 332     }
 333   else
 334     {
 335       last = slen;
 336       start = 0;
 337       delta = 1;
 338     }
 339   for (; start != last; start += delta)
 340     {
 341       for (i = 0; i < setlen; i++)
 342         {
 343           if (str[start] == set[i])
 344             break;
 345         }
 346       if (i == setlen)
 347         return (start + 1);
 348     }
 349
 350   return 0;
 351 }