OSDN Git Service

2014-03-15 Jerry DeLisle <jvdelisle@gcc.gnu>
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / string_intrinsics_inc.c
1 /* String intrinsics helper functions.
2    Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or
7 modify it under the terms of the GNU General Public
8 License as published by the Free Software Foundation; either
9 version 3 of the License, or (at your option) any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 GNU General Public License for more details.
15
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
19
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
23 <http://www.gnu.org/licenses/>.  */
24
25
26 /* Rename the functions.  */
27 #define concat_string SUFFIX(concat_string)
28 #define string_len_trim SUFFIX(string_len_trim)
29 #define adjustl SUFFIX(adjustl)
30 #define adjustr SUFFIX(adjustr)
31 #define string_index SUFFIX(string_index)
32 #define string_scan SUFFIX(string_scan)
33 #define string_verify SUFFIX(string_verify)
34 #define string_trim SUFFIX(string_trim)
35 #define string_minmax SUFFIX(string_minmax)
36 #define zero_length_string SUFFIX(zero_length_string)
37 #define compare_string SUFFIX(compare_string)
38
39
40 /* The prototypes.  */
41
42 extern void concat_string (gfc_charlen_type, CHARTYPE *,
43                            gfc_charlen_type, const CHARTYPE *,
44                            gfc_charlen_type, const CHARTYPE *);
45 export_proto(concat_string);
46
47 extern void adjustl (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
48 export_proto(adjustl);
49
50 extern void adjustr (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
51 export_proto(adjustr);
52
53 extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *,
54                                       gfc_charlen_type, const CHARTYPE *,
55                                       GFC_LOGICAL_4);
56 export_proto(string_index);
57
58 extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *,
59                                      gfc_charlen_type, const CHARTYPE *,
60                                      GFC_LOGICAL_4);
61 export_proto(string_scan);
62
63 extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *,
64                                        gfc_charlen_type, const CHARTYPE *,
65                                        GFC_LOGICAL_4);
66 export_proto(string_verify);
67
68 extern void string_trim (gfc_charlen_type *, CHARTYPE **, gfc_charlen_type,
69                          const CHARTYPE *);
70 export_proto(string_trim);
71
72 extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...);
73 export_proto(string_minmax);
74
75
76 /* Use for functions which can return a zero-length string.  */
77 static CHARTYPE zero_length_string = 0;
78
79
80 /* Strings of unequal length are extended with pad characters.  */
81
82 int
83 compare_string (gfc_charlen_type len1, const CHARTYPE *s1,
84                 gfc_charlen_type len2, const CHARTYPE *s2)
85 {
86   const UCHARTYPE *s;
87   gfc_charlen_type len;
88   int res;
89
90   res = MEMCMP (s1, s2, ((len1 < len2) ? len1 : len2));
91   if (res != 0)
92     return res;
93
94   if (len1 == len2)
95     return 0;
96
97   if (len1 < len2)
98     {
99       len = len2 - len1;
100       s = (UCHARTYPE *) &s2[len1];
101       res = -1;
102     }
103   else
104     {
105       len = len1 - len2;
106       s = (UCHARTYPE *) &s1[len2];
107       res = 1;
108     }
109
110   while (len--)
111     {
112       if (*s != ' ')
113         {
114           if (*s > ' ')
115             return res;
116           else
117             return -res;
118         }
119       s++;
120     }
121
122   return 0;
123 }
124 iexport(compare_string);
125
126
127 /* The destination and source should not overlap.  */
128
129 void
130 concat_string (gfc_charlen_type destlen, CHARTYPE * dest,
131                gfc_charlen_type len1, const CHARTYPE * s1,
132                gfc_charlen_type len2, const CHARTYPE * s2)
133 {
134   if (len1 >= destlen)
135     {
136       memcpy (dest, s1, destlen * sizeof (CHARTYPE));
137       return;
138     }
139   memcpy (dest, s1, len1 * sizeof (CHARTYPE));
140   dest += len1;
141   destlen -= len1;
142
143   if (len2 >= destlen)
144     {
145       memcpy (dest, s2, destlen * sizeof (CHARTYPE));
146       return;
147     }
148
149   memcpy (dest, s2, len2 * sizeof (CHARTYPE));
150   MEMSET (&dest[len2], ' ', destlen - len2);
151 }
152
153
154 /* Return string with all trailing blanks removed.  */
155
156 void
157 string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen,
158              const CHARTYPE *src)
159 {
160   *len = string_len_trim (slen, src);
161
162   if (*len == 0)
163     *dest = &zero_length_string;
164   else
165     {
166       /* Allocate space for result string.  */
167       *dest = internal_malloc_size (*len * sizeof (CHARTYPE));
168
169       /* Copy string if necessary.  */
170       memcpy (*dest, src, *len * sizeof (CHARTYPE));
171     }
172 }
173
174
175 /* The length of a string not including trailing blanks.  */
176
177 gfc_charlen_type
178 string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
179 {
180   const gfc_charlen_type long_len = (gfc_charlen_type) sizeof (unsigned long);
181   gfc_charlen_type i;
182
183   i = len - 1;
184
185   /* If we've got the standard (KIND=1) character type, we scan the string in
186      long word chunks to speed it up (until a long word is hit that does not
187      consist of ' 's).  */
188   if (sizeof (CHARTYPE) == 1 && i >= long_len)
189     {
190       int starting;
191       unsigned long blank_longword;
192
193       /* Handle the first characters until we're aligned on a long word
194          boundary.  Actually, s + i + 1 must be properly aligned, because
195          s + i will be the last byte of a long word read.  */
196       starting = ((unsigned long)
197 #ifdef __INTPTR_TYPE__
198                   (__INTPTR_TYPE__)
199 #endif
200                   (s + i + 1)) % long_len;
201       i -= starting;
202       for (; starting > 0; --starting)
203         if (s[i + starting] != ' ')
204           return i + starting + 1;
205
206       /* Handle the others in a batch until first non-blank long word is
207          found.  Here again, s + i is the last byte of the current chunk,
208          to it starts at s + i - sizeof (long) + 1.  */
209
210 #if __SIZEOF_LONG__ == 4
211       blank_longword = 0x20202020L;
212 #elif __SIZEOF_LONG__ == 8
213       blank_longword = 0x2020202020202020L;
214 #else
215       #error Invalid size of long!
216 #endif
217
218       while (i >= long_len)
219         {
220           i -= long_len;
221           if (*((unsigned long*) (s + i + 1)) != blank_longword)
222             {
223               i += long_len;
224               break;
225             }
226         }
227
228       /* Now continue for the last characters with naive approach below.  */
229       assert (i >= 0);
230     }
231
232   /* Simply look for the first non-blank character.  */
233   while (i >= 0 && s[i] == ' ')
234     --i;
235   return i + 1;
236 }
237
238
239 /* Find a substring within a string.  */
240
241 gfc_charlen_type
242 string_index (gfc_charlen_type slen, const CHARTYPE *str,
243               gfc_charlen_type sslen, const CHARTYPE *sstr,
244               GFC_LOGICAL_4 back)
245 {
246   gfc_charlen_type start, last, delta, i;
247
248   if (sslen == 0)
249     return back ? (slen + 1) : 1;
250
251   if (sslen > slen)
252     return 0;
253
254   if (!back)
255     {
256       last = slen + 1 - sslen;
257       start = 0;
258       delta = 1;
259     }
260   else
261     {
262       last = -1;
263       start = slen - sslen;
264       delta = -1;
265     }
266
267   for (; start != last; start+= delta)
268     {
269       for (i = 0; i < sslen; i++)
270         {
271           if (str[start + i] != sstr[i])
272             break;
273         }
274       if (i == sslen)
275         return (start + 1);
276     }
277   return 0;
278 }
279
280
281 /* Remove leading blanks from a string, padding at end.  The src and dest
282    should not overlap.  */
283
284 void
285 adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
286 {
287   gfc_charlen_type i;
288
289   i = 0;
290   while (i < len && src[i] == ' ')
291     i++;
292
293   if (i < len)
294     memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
295   if (i > 0)
296     MEMSET (&dest[len - i], ' ', i);
297 }
298
299
300 /* Remove trailing blanks from a string.  */
301
302 void
303 adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
304 {
305   gfc_charlen_type i;
306
307   i = len;
308   while (i > 0 && src[i - 1] == ' ')
309     i--;
310
311   if (i < len)
312     MEMSET (dest, ' ', len - i);
313   memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
314 }
315
316
317 /* Scan a string for any one of the characters in a set of characters.  */
318
319 gfc_charlen_type
320 string_scan (gfc_charlen_type slen, const CHARTYPE *str,
321              gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
322 {
323   gfc_charlen_type i, j;
324
325   if (slen == 0 || setlen == 0)
326     return 0;
327
328   if (back)
329     {
330       for (i = slen - 1; i >= 0; i--)
331         {
332           for (j = 0; j < setlen; j++)
333             {
334               if (str[i] == set[j])
335                 return (i + 1);
336             }
337         }
338     }
339   else
340     {
341       for (i = 0; i < slen; i++)
342         {
343           for (j = 0; j < setlen; j++)
344             {
345               if (str[i] == set[j])
346                 return (i + 1);
347             }
348         }
349     }
350
351   return 0;
352 }
353
354
355 /* Verify that a set of characters contains all the characters in a
356    string by identifying the position of the first character in a
357    characters that does not appear in a given set of characters.  */
358
359 gfc_charlen_type
360 string_verify (gfc_charlen_type slen, const CHARTYPE *str,
361                gfc_charlen_type setlen, const CHARTYPE *set,
362                GFC_LOGICAL_4 back)
363 {
364   gfc_charlen_type start, last, delta, i;
365
366   if (slen == 0)
367     return 0;
368
369   if (back)
370     {
371       last = -1;
372       start = slen - 1;
373       delta = -1;
374     }
375   else
376     {
377       last = slen;
378       start = 0;
379       delta = 1;
380     }
381   for (; start != last; start += delta)
382     {
383       for (i = 0; i < setlen; i++)
384         {
385           if (str[start] == set[i])
386             break;
387         }
388       if (i == setlen)
389         return (start + 1);
390     }
391
392   return 0;
393 }
394
395
396 /* MIN and MAX intrinsics for strings.  The front-end makes sure that
397    nargs is at least 2.  */
398
399 void
400 string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
401 {
402   va_list ap;
403   int i;
404   CHARTYPE *next, *res;
405   gfc_charlen_type nextlen, reslen;
406
407   va_start (ap, nargs);
408   reslen = va_arg (ap, gfc_charlen_type);
409   res = va_arg (ap, CHARTYPE *);
410   *rlen = reslen;
411
412   if (res == NULL)
413     runtime_error ("First argument of '%s' intrinsic should be present",
414                    op > 0 ? "MAX" : "MIN");
415
416   for (i = 1; i < nargs; i++)
417     {
418       nextlen = va_arg (ap, gfc_charlen_type);
419       next = va_arg (ap, CHARTYPE *);
420
421       if (next == NULL)
422         {
423           if (i == 1)
424             runtime_error ("Second argument of '%s' intrinsic should be "
425                            "present", op > 0 ? "MAX" : "MIN");
426           else
427             continue;
428         }
429
430       if (nextlen > *rlen)
431         *rlen = nextlen;
432
433       if (op * compare_string (reslen, res, nextlen, next) < 0)
434         {
435           reslen = nextlen;
436           res = next;
437         }
438     }
439   va_end (ap);
440
441   if (*rlen == 0)
442     *dest = &zero_length_string;
443   else
444     {
445       CHARTYPE *tmp = internal_malloc_size (*rlen * sizeof (CHARTYPE));
446       memcpy (tmp, res, reslen * sizeof (CHARTYPE));
447       MEMSET (&tmp[reslen], ' ', *rlen - reslen);
448       *dest = tmp;
449     }
450 }