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 (libgfortran).
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.
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
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.
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. */
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. */
42 #include "libgfortran.h"
45 /* String functions. */
47 extern void copy_string (GFC_INTEGER_4
, char *, GFC_INTEGER_4
, const char *);
48 export_proto(copy_string
);
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
);
55 extern GFC_INTEGER_4
string_len_trim (GFC_INTEGER_4
, const char *);
56 export_proto(string_len_trim
);
58 extern void adjustl (char *, GFC_INTEGER_4
, const char *);
59 export_proto(adjustl
);
61 extern void adjustr (char *, GFC_INTEGER_4
, const char *);
62 export_proto(adjustr
);
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
);
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
);
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
);
76 extern void string_trim (GFC_INTEGER_4
*, void **, GFC_INTEGER_4
, const char *);
77 export_proto(string_trim
);
79 extern void string_repeat (char *, GFC_INTEGER_4
, const char *, GFC_INTEGER_4
);
80 export_proto(string_repeat
);
82 /* The two areas may overlap so we use memmove. */
85 copy_string (GFC_INTEGER_4 destlen
, char * dest
,
86 GFC_INTEGER_4 srclen
, const char * src
)
88 if (srclen
>= destlen
)
90 /* This will truncate if too long. */
91 memmove (dest
, src
, destlen
);
92 /*memcpy (dest, src, destlen);*/
96 memmove (dest
, src
, srclen
);
97 /*memcpy (dest, src, srclen);*/
98 /* Pad with spaces. */
99 memset (&dest
[srclen
], ' ', destlen
- srclen
);
104 /* Strings of unequal length are extended with pad characters. */
107 compare_string (GFC_INTEGER_4 len1
, const char * s1
,
108 GFC_INTEGER_4 len2
, const char * s2
)
114 res
= strncmp (s1
, s2
, (len1
< len2
) ? len1
: len2
);
148 iexport(compare_string
);
151 /* The destination and source should not overlap. */
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
)
160 memcpy (dest
, s1
, destlen
);
163 memcpy (dest
, s1
, len1
);
169 memcpy (dest
, s2
, destlen
);
173 memcpy (dest
, s2
, len2
);
174 memset (&dest
[len2
], ' ', destlen
- len2
);
178 /* Return string with all trailing blanks removed. */
181 string_trim (GFC_INTEGER_4
* len
, void ** dest
, GFC_INTEGER_4 slen
,
186 /* Determine length of result string. */
187 for (i
= slen
- 1; i
>= 0; i
--)
196 /* Allocate space for result string. */
197 *dest
= internal_malloc_size (*len
);
199 /* copy string if necessary. */
200 memmove (*dest
, src
, *len
);
205 /* The length of a string not including trailing blanks. */
208 string_len_trim (GFC_INTEGER_4 len
, const char * s
)
212 for (i
= len
- 1; i
>= 0; i
--)
221 /* Find a substring within a string. */
224 string_index (GFC_INTEGER_4 slen
, const char * str
, GFC_INTEGER_4 sslen
,
225 const char * sstr
, GFC_LOGICAL_4 back
)
240 last
= slen
+ 1 - sslen
;
247 start
= slen
- sslen
;
251 for (; start
!= last
; start
+= delta
)
253 for (i
= 0; i
< sslen
; i
++)
255 if (str
[start
+ i
] != sstr
[i
])
265 /* Remove leading blanks from a string, padding at end. The src and dest
266 should not overlap. */
269 adjustl (char *dest
, GFC_INTEGER_4 len
, const char *src
)
274 while (i
<len
&& src
[i
] == ' ')
278 memcpy (dest
, &src
[i
], len
- i
);
280 memset (&dest
[len
- i
], ' ', i
);
284 /* Remove trailing blanks from a string. */
287 adjustr (char *dest
, GFC_INTEGER_4 len
, const char *src
)
292 while (i
> 0 && src
[i
- 1] == ' ')
296 memset (dest
, ' ', len
- i
);
297 memcpy (dest
+ (len
- i
), src
, i
);
301 /* Scan a string for any one of the characters in a set of characters. */
304 string_scan (GFC_INTEGER_4 slen
, const char * str
, GFC_INTEGER_4 setlen
,
305 const char * set
, GFC_LOGICAL_4 back
)
312 if (slen
== 0 || setlen
== 0)
329 for (; start
!= last
; start
+= delta
)
331 for (i
= 0; i
< setlen
; i
++)
333 if (str
[start
] == set
[i
])
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. */
347 string_verify (GFC_INTEGER_4 slen
, const char * str
, GFC_INTEGER_4 setlen
,
348 const char * set
, GFC_LOGICAL_4 back
)
370 for (; start
!= last
; start
+= delta
)
372 for (i
= 0; i
< setlen
; i
++)
374 if (str
[start
] == set
[i
])
385 /* Concatenate several copies of a string. */
388 string_repeat (char * dest
, GFC_INTEGER_4 slen
,
389 const char * src
, GFC_INTEGER_4 ncopies
)
393 /* See if ncopies is valid. */
396 /* The error is already reported. */
397 runtime_error ("Augument NCOPIES is negative.");
400 /* Copy characters. */
401 for (i
= 0; i
< ncopies
; i
++)
403 memmove (dest
+ (i
* slen
), src
, slen
);