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