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