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