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