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 (!back)
 225     {
 226       last = slen + 1 - sslen;
 227       start = 0;
 228       delta = 1;
 229     }
 230   else
 231     {
 232       last = -1;
 233       start = slen - sslen;
 234       delta = -1;
 235     }
 236   i = 0;
 237   for (; start != last; start+= delta)
 238     {
 239       for (i = 0; i < sslen; i++)
 240         {
 241           if (str[start + i] != sstr[i])
 242             break;
 243         }
 244       if (i == sslen)
 245         return (start + 1);
 246     }
 247   return 0;
 248 }
 249
 250
 251 /* Remove leading blanks from a string, padding at end.  The src and dest
 252    should not overlap.  */
 253
 254 void
 255 adjustl (char *dest, GFC_INTEGER_4 len, const char *src)
 256 {
 257   int i;
 258
 259   i = 0;
 260   while (i<len && src[i] == ' ')
 261     i++;
 262
 263   if (i < len)
 264     memcpy (dest, &src[i], len - i);
 265   if (i > 0)
 266     memset (&dest[len - i], ' ', i);
 267 }
 268
 269
 270 /* Remove trailing blanks from a string.  */
 271
 272 void
 273 adjustr (char *dest, GFC_INTEGER_4 len, const char *src)
 274 {
 275   int i;
 276
 277   i = len;
 278   while (i > 0 && src[i - 1] == ' ')
 279     i--;
 280
 281   if (i < len)
 282     memset (dest, ' ', len - i);
 283   memcpy (dest + (len - i), src, i );
 284 }
 285
 286
 287 /* Scan a string for any one of the characters in a set of characters.  */
 288
 289 GFC_INTEGER_4
 290 string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 291              const char * set, GFC_LOGICAL_4 back)
 292 {
 293   int start;
 294   int last;
 295   int i;
 296   int delta;
 297
 298   if (slen == 0 || setlen == 0)
 299     return 0;
 300
 301   if (back)
 302     {
 303       last =  0;
 304       start = slen - 1;
 305       delta = -1;
 306     }
 307   else
 308     {
 309       last = slen - 1;
 310       start = 0;
 311       delta = 1;
 312     }
 313
 314   i = 0;
 315   for (; start != last; start += delta)
 316     {
 317       for (i = 0; i < setlen; i++)
 318         {
 319           if (str[start] == set[i])
 320             return (start + 1);
 321         }
 322     }
 323
 324   return 0;
 325 }
 326
 327
 328 /* Verify that a set of characters contains all the characters in a
 329    string by indentifying the position of the first character in a
 330    characters that dose not appear in a given set of characters.  */
 331
 332 GFC_INTEGER_4
 333 string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 334                const char * set, GFC_LOGICAL_4 back)
 335 {
 336   int start;
 337   int last;
 338   int i;
 339   int delta;
 340
 341   if (slen == 0)
 342     return 0;
 343
 344   if (back)
 345     {
 346       last =  0;
 347       start = slen - 1;
 348       delta = -1;
 349     }
 350   else
 351     {
 352       last = slen - 1;
 353       start = 0;
 354       delta = 1;
 355     }
 356   i = 0;
 357   for (; start != last; start += delta)
 358     {
 359       for (i = 0; i < setlen; i++)
 360         {
 361           if (str[start] == set[i])
 362             break;
 363         }
 364       if (i == setlen)
 365         return (start + 1);
 366     }
 367
 368   return 0;
 369 }
 370
 371
 372 /* Concatenate several copies of a string.  */
 373
 374 void
 375 string_repeat (char * dest, GFC_INTEGER_4 slen,
 376                const char * src, GFC_INTEGER_4 ncopies)
 377 {
 378   int i;
 379
 380   /* See if ncopies is valid.  */
 381   if (ncopies < 0)
 382     {
 383       /* The error is already reported.  */
 384       runtime_error ("Augument NCOPIES is negative.");
 385     }
 386
 387   /* Copy characters.  */
 388   for (i = 0; i < ncopies; i++)
 389     {
 390       memmove (dest + (i * slen), src, slen);
 391     }
 392 }
 393