OSDN Git Service

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