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,
 172              const char * src)
 173 {
 174   int i;
 175
 176   /* Determine length of result string.  */
 177   for (i = slen - 1; i >= 0; i--)
 178     {
 179       if (src[i] != ' ')
 180         break;
 181     }
 182   *len = i + 1;
 183
 184   if (*len > 0)
 185     {
 186       /* Allocate space for result string.  */
 187       *dest = internal_malloc_size (*len);
 188
 189       /* copy string if necessary.  */
 190       memmove (*dest, src, *len);
 191     }
 192 }
 193
 194
 195 /* The length of a string not including trailing blanks.  */
 196
 197 GFC_INTEGER_4
 198 string_len_trim (GFC_INTEGER_4 len, const char * s)
 199 {
 200   int i;
 201
 202   for (i = len - 1; i >= 0; i--)
 203     {
 204       if (s[i] != ' ')
 205         break;
 206     }
 207   return i + 1;
 208 }
 209
 210
 211 /* Find a substring within a string.  */
 212
 213 GFC_INTEGER_4
 214 string_index (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 sslen,
 215               const char * sstr, GFC_LOGICAL_4 back)
 216 {
 217   int start;
 218   int last;
 219   int i;
 220   int delta;
 221
 222   if (sslen == 0)
 223     return 1;
 224
 225   if (sslen > slen)
 226     return 0;
 227
 228   if (!back)
 229     {
 230       last = slen + 1 - sslen;
 231       start = 0;
 232       delta = 1;
 233     }
 234   else
 235     {
 236       last = -1;
 237       start = slen - sslen;
 238       delta = -1;
 239     }
 240   i = 0;
 241   for (; start != last; start+= delta)
 242     {
 243       for (i = 0; i < sslen; i++)
 244         {
 245           if (str[start + i] != sstr[i])
 246             break;
 247         }
 248       if (i == sslen)
 249         return (start + 1);
 250     }
 251   return 0;
 252 }
 253
 254
 255 /* Remove leading blanks from a string, padding at end.  The src and dest
 256    should not overlap.  */
 257
 258 void
 259 adjustl (char *dest, GFC_INTEGER_4 len, const char *src)
 260 {
 261   int i;
 262
 263   i = 0;
 264   while (i<len && src[i] == ' ')
 265     i++;
 266
 267   if (i < len)
 268     memcpy (dest, &src[i], len - i);
 269   if (i > 0)
 270     memset (&dest[len - i], ' ', i);
 271 }
 272
 273
 274 /* Remove trailing blanks from a string.  */
 275
 276 void
 277 adjustr (char *dest, GFC_INTEGER_4 len, const char *src)
 278 {
 279   int i;
 280
 281   i = len;
 282   while (i > 0 && src[i - 1] == ' ')
 283     i--;
 284
 285   if (i < len)
 286     memset (dest, ' ', len - i);
 287   memcpy (dest + (len - i), src, i );
 288 }
 289
 290
 291 /* Scan a string for any one of the characters in a set of characters.  */
 292
 293 GFC_INTEGER_4
 294 string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 295              const char * set, GFC_LOGICAL_4 back)
 296 {
 297   int start;
 298   int last;
 299   int i;
 300   int delta;
 301
 302   if (slen == 0 || setlen == 0)
 303     return 0;
 304
 305   if (back)
 306     {
 307       last =  0;
 308       start = slen - 1;
 309       delta = -1;
 310     }
 311   else
 312     {
 313       last = slen - 1;
 314       start = 0;
 315       delta = 1;
 316     }
 317
 318   i = 0;
 319   for (; start != last; start += delta)
 320     {
 321       for (i = 0; i < setlen; i++)
 322         {
 323           if (str[start] == set[i])
 324             return (start + 1);
 325         }
 326     }
 327
 328   return 0;
 329 }
 330
 331
 332 /* Verify that a set of characters contains all the characters in a
 333    string by indentifying the position of the first character in a
 334    characters that dose not appear in a given set of characters.  */
 335
 336 GFC_INTEGER_4
 337 string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 338                const char * set, GFC_LOGICAL_4 back)
 339 {
 340   int start;
 341   int last;
 342   int i;
 343   int delta;
 344
 345   if (slen == 0)
 346     return 0;
 347
 348   if (back)
 349     {
 350       last = -1;
 351       start = slen - 1;
 352       delta = -1;
 353     }
 354   else
 355     {
 356       last = slen;
 357       start = 0;
 358       delta = 1;
 359     }
 360   for (; start != last; start += delta)
 361     {
 362       for (i = 0; i < setlen; i++)
 363         {
 364           if (str[start] == set[i])
 365             break;
 366         }
 367       if (i == setlen)
 368         return (start + 1);
 369     }
 370
 371   return 0;
 372 }
 373
 374
 375 /* Concatenate several copies of a string.  */
 376
 377 void
 378 string_repeat (char * dest, GFC_INTEGER_4 slen,
 379                const char * src, GFC_INTEGER_4 ncopies)
 380 {
 381   int i;
 382
 383   /* See if ncopies is valid.  */
 384   if (ncopies < 0)
 385     {
 386       /* The error is already reported.  */
 387       runtime_error ("Augument NCOPIES is negative.");
 388     }
 389
 390   /* Copy characters.  */
 391   for (i = 0; i < ncopies; i++)
 392     {
 393       memmove (dest + (i * slen), src, slen);
 394     }
 395 }