libgfortran/intrinsics/string_intrinsics.c

   1 /* String intrinsics helper functions.
   2    Copyright 2002 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 (libgfor).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU Lesser General Public
   9 License as published by the Free Software Foundation; either
  10 version 2.1 of the License, or (at your option) any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU Lesser General Public License for more details.
  16
  17 You should have received a copy of the GNU Lesser General Public
  18 License along with libgfor; see the file COPYING.LIB.  If not,
  19 write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22
  23 /* Unlike what the name of this file suggests, we don't actually
  24    implement the Fortran intrinsics here.  At least, not with the
  25    names they have in the standard.  The functions here provide all
  26    the support we need for the standard string intrinsics, and the
  27    compiler translates the actual intrinsics calls to calls to
  28    functions in this file.  */
  29
  30 #include <stdlib.h>
  31 #include <string.h>
  32
  33 #include "libgfortran.h"
  34
  35
  36 /* String functions.  */
  37
  38 #define copy_string prefix(copy_string)
  39 void copy_string (GFC_INTEGER_4, char *, GFC_INTEGER_4, const char *);
  40
  41 #define concat_string prefix(concat_string)
  42 void concat_string (GFC_INTEGER_4, char *,
  43                     GFC_INTEGER_4, const char *,
  44                     GFC_INTEGER_4, const char *);
  45
  46 #define string_len_trim prefix(string_len_trim)
  47 GFC_INTEGER_4 string_len_trim (GFC_INTEGER_4, const char *);
  48
  49 #define adjustl prefix(adjustl)
  50 void adjustl (char *, GFC_INTEGER_4, const char *);
  51
  52 #define adjustr prefix(adjustr)
  53 void adjustr (char *, GFC_INTEGER_4, const char *);
  54
  55 #define string_index prefix(string_index)
  56 GFC_INTEGER_4 string_index (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
  57                             const char *, GFC_LOGICAL_4);
  58
  59 #define string_scan prefix(string_scan)
  60 GFC_INTEGER_4 string_scan (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
  61                            const char *, GFC_LOGICAL_4);
  62
  63 #define string_verify prefix(string_verify)
  64 GFC_INTEGER_4 string_verify (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
  65                              const char *, GFC_LOGICAL_4);
  66
  67 #define string_trim prefix(string_trim)
  68 void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *);
  69
  70 #define string_repeat prefix(string_repeat)
  71 void string_repeat (char *, GFC_INTEGER_4, const char *, GFC_INTEGER_4);
  72
  73 /* The two areas may overlap so we use memmove.  */
  74
  75 void
  76 copy_string (GFC_INTEGER_4 destlen, char * dest,
  77              GFC_INTEGER_4 srclen, const char * src)
  78 {
  79   if (srclen >= destlen)
  80     {
  81       /* This will truncate if too long.  */
  82       memmove (dest, src, destlen);
  83       /*memcpy (dest, src, destlen);*/
  84     }
  85   else
  86     {
  87       memmove (dest, src, srclen);
  88       /*memcpy (dest, src, srclen);*/
  89       /* Pad with spaces.  */
  90       memset (&dest[srclen], ' ', destlen - srclen);
  91     }
  92 }
  93
  94
  95 /* Strings of unequal length are extended with pad characters.  */
  96
  97 GFC_INTEGER_4
  98 compare_string (GFC_INTEGER_4 len1, const char * s1,
  99                 GFC_INTEGER_4 len2, const char * s2)
 100 {
 101   int res;
 102   const char *s;
 103   int len;
 104
 105   res = strncmp (s1, s2, (len1 < len2) ? len1 : len2);
 106   if (res != 0)
 107     return res;
 108
 109   if (len1 == len2)
 110     return 0;
 111
 112   if (len1 < len2)
 113     {
 114       len = len2 - len1;
 115       s = &s2[len1];
 116       res = -1;
 117     }
 118   else
 119     {
 120       len = len1 - len2;
 121       s = &s1[len2];
 122       res = 1;
 123     }
 124
 125   while (len--)
 126     {
 127       if (*s != ' ')
 128         {
 129           if (*s > ' ')
 130             return res;
 131           else
 132             return -res;
 133         }
 134       s++;
 135     }
 136
 137   return 0;
 138 }
 139
 140
 141 /* The destination and source should not overlap.  */
 142
 143 void
 144 concat_string (GFC_INTEGER_4 destlen, char * dest,
 145                GFC_INTEGER_4 len1, const char * s1,
 146                GFC_INTEGER_4 len2, const char * s2)
 147 {
 148   if (len1 >= destlen)
 149     {
 150       memcpy (dest, s1, destlen);
 151       return;
 152     }
 153   memcpy (dest, s1, len1);
 154   dest += len1;
 155   destlen -= len1;
 156
 157   if (len2 >= destlen)
 158     {
 159       memcpy (dest, s2, destlen);
 160       return;
 161     }
 162
 163   memcpy (dest, s2, len2);
 164   memset (&dest[len2], ' ', destlen - len2);
 165 }
 166
 167
 168 /* Return string with all trailing blanks removed.  */
 169
 170 void
 171 string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen, const char * src)
 172 {
 173   int i;
 174
 175   /* Determine length of result string.  */
 176   for (i = slen - 1; i >= 0; i--)
 177     {
 178       if (src[i] != ' ')
 179         break;
 180     }
 181   *len = i + 1;
 182
 183   if (*len > 0)
 184     {
 185       /* Allocate space for result string.  */
 186       *dest = internal_malloc (*len);
 187
 188       /* copy string if necessary.  */
 189       memmove (*dest, src, *len);
 190     }
 191 }
 192
 193
 194 /* The length of a string not including trailing blanks.  */
 195
 196 GFC_INTEGER_4
 197 string_len_trim (GFC_INTEGER_4 len, const char * s)
 198 {
 199   int i;
 200
 201   for (i = len - 1; i >= 0; i--)
 202     {
 203       if (s[i] != ' ')
 204         break;
 205     }
 206   return i + 1;
 207 }
 208
 209
 210 /* Find a substring within a string.  */
 211
 212 GFC_INTEGER_4
 213 string_index (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 sslen,
 214               const char * sstr, GFC_LOGICAL_4 back)
 215 {
 216   int start;
 217   int last;
 218   int i;
 219   int delta;
 220
 221   if (sslen == 0)
 222     return 1;
 223
 224   if (sslen > slen)
 225     return 0;
 226
 227   if (!back)
 228     {
 229       last = slen + 1 - sslen;
 230       start = 0;
 231       delta = 1;
 232     }
 233   else
 234     {
 235       last = -1;
 236       start = slen - sslen;
 237       delta = -1;
 238     }
 239   i = 0;
 240   for (; start != last; start+= delta)
 241     {
 242       for (i = 0; i < sslen; i++)
 243         {
 244           if (str[start + i] != sstr[i])
 245             break;
 246         }
 247       if (i == sslen)
 248         return (start + 1);
 249     }
 250   return 0;
 251 }
 252
 253
 254 /* Remove leading blanks from a string, padding at end.  The src and dest
 255    should not overlap.  */
 256
 257 void
 258 adjustl (char *dest, GFC_INTEGER_4 len, const char *src)
 259 {
 260   int i;
 261
 262   i = 0;
 263   while (i<len && src[i] == ' ')
 264     i++;
 265
 266   if (i < len)
 267     memcpy (dest, &src[i], len - i);
 268   if (i > 0)
 269     memset (&dest[len - i], ' ', i);
 270 }
 271
 272
 273 /* Remove trailing blanks from a string.  */
 274
 275 void
 276 adjustr (char *dest, GFC_INTEGER_4 len, const char *src)
 277 {
 278   int i;
 279
 280   i = len;
 281   while (i > 0 && src[i - 1] == ' ')
 282     i--;
 283
 284   if (i < len)
 285     memset (dest, ' ', len - i);
 286   memcpy (dest + (len - i), src, i );
 287 }
 288
 289
 290 /* Scan a string for any one of the characters in a set of characters.  */
 291
 292 GFC_INTEGER_4
 293 string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 294              const char * set, GFC_LOGICAL_4 back)
 295 {
 296   int start;
 297   int last;
 298   int i;
 299   int delta;
 300
 301   if (slen == 0 || setlen == 0)
 302     return 0;
 303
 304   if (back)
 305     {
 306       last =  0;
 307       start = slen - 1;
 308       delta = -1;
 309     }
 310   else
 311     {
 312       last = slen - 1;
 313       start = 0;
 314       delta = 1;
 315     }
 316
 317   i = 0;
 318   for (; start != last; start += delta)
 319     {
 320       for (i = 0; i < setlen; i++)
 321         {
 322           if (str[start] == set[i])
 323             return (start + 1);
 324         }
 325     }
 326
 327   return 0;
 328 }
 329
 330
 331 /* Verify that a set of characters contains all the characters in a
 332    string by indentifying the position of the first character in a
 333    characters that dose not appear in a given set of characters.  */
 334
 335 GFC_INTEGER_4
 336 string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 337                const char * set, GFC_LOGICAL_4 back)
 338 {
 339   int start;
 340   int last;
 341   int i;
 342   int delta;
 343
 344   if (slen == 0)
 345     return 0;
 346
 347   if (back)
 348     {
 349       last = -1;
 350       start = slen - 1;
 351       delta = -1;
 352     }
 353   else
 354     {
 355       last = slen;
 356       start = 0;
 357       delta = 1;
 358     }
 359   for (; start != last; start += delta)
 360     {
 361       for (i = 0; i < setlen; i++)
 362         {
 363           if (str[start] == set[i])
 364             break;
 365         }
 366       if (i == setlen)
 367         return (start + 1);
 368     }
 369
 370   return 0;
 371 }
 372
 373
 374 /* Concatenate several copies of a string.  */
 375
 376 void
 377 string_repeat (char * dest, GFC_INTEGER_4 slen,
 378                const char * src, GFC_INTEGER_4 ncopies)
 379 {
 380   int i;
 381
 382   /* See if ncopies is valid.  */
 383   if (ncopies < 0)
 384     {
 385       /* The error is already reported.  */
 386       runtime_error ("Augument NCOPIES is negative.");
 387     }
 388
 389   /* Copy characters.  */
 390   for (i = 0; i < ncopies; i++)
 391     {
 392       memmove (dest + (i * slen), src, slen);
 393     }
 394 }
 395