1 /* String intrinsics helper functions.
2 Copyright 2002 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 runtime library (libgfor).
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.
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.
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. */
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. */
33 #include "libgfortran.h"
36 /* String functions. */
38 #define copy_string prefix(copy_string)
39 void copy_string (GFC_INTEGER_4
, char *, GFC_INTEGER_4
, const char *);
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 *);
46 #define string_len_trim prefix(string_len_trim)
47 GFC_INTEGER_4
string_len_trim (GFC_INTEGER_4
, const char *);
49 #define adjustl prefix(adjustl)
50 void adjustl (char *, GFC_INTEGER_4
, const char *);
52 #define adjustr prefix(adjustr)
53 void adjustr (char *, GFC_INTEGER_4
, const char *);
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
);
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
);
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
);
67 #define string_trim prefix(string_trim)
68 void string_trim (GFC_INTEGER_4
*, void **, GFC_INTEGER_4
, const char *);
70 #define string_repeat prefix(string_repeat)
71 void string_repeat (char *, GFC_INTEGER_4
, const char *, GFC_INTEGER_4
);
73 /* The two areas may overlap so we use memmove. */
76 copy_string (GFC_INTEGER_4 destlen
, char * dest
,
77 GFC_INTEGER_4 srclen
, const char * src
)
79 if (srclen
>= destlen
)
81 /* This will truncate if too long. */
82 memmove (dest
, src
, destlen
);
83 /*memcpy (dest, src, destlen);*/
87 memmove (dest
, src
, srclen
);
88 /*memcpy (dest, src, srclen);*/
89 /* Pad with spaces. */
90 memset (&dest
[srclen
], ' ', destlen
- srclen
);
95 /* Strings of unequal length are extended with pad characters. */
98 compare_string (GFC_INTEGER_4 len1
, const char * s1
,
99 GFC_INTEGER_4 len2
, const char * s2
)
105 res
= strncmp (s1
, s2
, (len1
< len2
) ? len1
: len2
);
141 /* The destination and source should not overlap. */
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
)
150 memcpy (dest
, s1
, destlen
);
153 memcpy (dest
, s1
, len1
);
159 memcpy (dest
, s2
, destlen
);
163 memcpy (dest
, s2
, len2
);
164 memset (&dest
[len2
], ' ', destlen
- len2
);
168 /* Return string with all trailing blanks removed. */
171 string_trim (GFC_INTEGER_4
* len
, void ** dest
, GFC_INTEGER_4 slen
, const char * src
)
175 /* Determine length of result string. */
176 for (i
= slen
- 1; i
>= 0; i
--)
185 /* Allocate space for result string. */
186 *dest
= internal_malloc (*len
);
188 /* copy string if necessary. */
189 memmove (*dest
, src
, *len
);
194 /* The length of a string not including trailing blanks. */
197 string_len_trim (GFC_INTEGER_4 len
, const char * s
)
201 for (i
= len
- 1; i
>= 0; i
--)
210 /* Find a substring within a string. */
213 string_index (GFC_INTEGER_4 slen
, const char * str
, GFC_INTEGER_4 sslen
,
214 const char * sstr
, GFC_LOGICAL_4 back
)
226 last
= slen
+ 1 - sslen
;
233 start
= slen
- sslen
;
237 for (; start
!= last
; start
+= delta
)
239 for (i
= 0; i
< sslen
; i
++)
241 if (str
[start
+ i
] != sstr
[i
])
251 /* Remove leading blanks from a string, padding at end. The src and dest
252 should not overlap. */
255 adjustl (char *dest
, GFC_INTEGER_4 len
, const char *src
)
260 while (i
<len
&& src
[i
] == ' ')
264 memcpy (dest
, &src
[i
], len
- i
);
266 memset (&dest
[len
- i
], ' ', i
);
270 /* Remove trailing blanks from a string. */
273 adjustr (char *dest
, GFC_INTEGER_4 len
, const char *src
)
278 while (i
> 0 && src
[i
- 1] == ' ')
282 memset (dest
, ' ', len
- i
);
283 memcpy (dest
+ (len
- i
), src
, i
);
287 /* Scan a string for any one of the characters in a set of characters. */
290 string_scan (GFC_INTEGER_4 slen
, const char * str
, GFC_INTEGER_4 setlen
,
291 const char * set
, GFC_LOGICAL_4 back
)
298 if (slen
== 0 || setlen
== 0)
315 for (; start
!= last
; start
+= delta
)
317 for (i
= 0; i
< setlen
; i
++)
319 if (str
[start
] == set
[i
])
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. */
333 string_verify (GFC_INTEGER_4 slen
, const char * str
, GFC_INTEGER_4 setlen
,
334 const char * set
, GFC_LOGICAL_4 back
)
357 for (; start
!= last
; start
+= delta
)
359 for (i
= 0; i
< setlen
; i
++)
361 if (str
[start
] == set
[i
])
372 /* Concatenate several copies of a string. */
375 string_repeat (char * dest
, GFC_INTEGER_4 slen
,
376 const char * src
, GFC_INTEGER_4 ncopies
)
380 /* See if ncopies is valid. */
383 /* The error is already reported. */
384 runtime_error ("Augument NCOPIES is negative.");
387 /* Copy characters. */
388 for (i
= 0; i
< ncopies
; i
++)
390 memmove (dest
+ (i
* slen
), src
, slen
);