diff options
author | Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2008-05-14 21:51:27 +0000 |
---|---|---|
committer | François-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2008-05-14 21:51:27 +0000 |
commit | 4b267817ff0af3f2d5ec219e57a5db5ddb345543 (patch) | |
tree | 4927e53c7e5dc8572ba91ace7e7dd690a041a236 /libgfortran/intrinsics | |
parent | c5fcd67041670039f624444358456f0a29c40b50 (diff) | |
download | gcc-4b267817ff0af3f2d5ec219e57a5db5ddb345543.zip gcc-4b267817ff0af3f2d5ec219e57a5db5ddb345543.tar.gz gcc-4b267817ff0af3f2d5ec219e57a5db5ddb345543.tar.bz2 |
libgfortran.h (gfc_char4_t): New type.
2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* libgfortran.h (gfc_char4_t): New type.
(GFC_SIZE_OF_CHAR_KIND): New macro.
(compare_string): Adjust prototype.
(compare_string_char4): New prototype.
* gfortran.map (GFORTRAN_1.1): Add _gfortran_adjustl_char4,
_gfortran_adjustr_char4, _gfortran_compare_string_char4,
_gfortran_concat_string_char4, _gfortran_string_index_char4,
_gfortran_string_len_trim_char4, _gfortran_string_minmax_char4,
_gfortran_string_scan_char4, _gfortran_string_trim_char4 and
_gfortran_string_verify_char4.
* intrinsics/string_intrinsics_inc.c: New file from content of
string_intrinsics.c with types replaced by macros.
* intrinsics/string_intrinsics.c: Move content to
string_intrinsics_inc.c.
From-SVN: r135313
Diffstat (limited to 'libgfortran/intrinsics')
-rw-r--r-- | libgfortran/intrinsics/string_intrinsics.c | 396 | ||||
-rw-r--r-- | libgfortran/intrinsics/string_intrinsics_inc.c | 418 |
2 files changed, 449 insertions, 365 deletions
diff --git a/libgfortran/intrinsics/string_intrinsics.c b/libgfortran/intrinsics/string_intrinsics.c index 1a76945..f6d9663 100644 --- a/libgfortran/intrinsics/string_intrinsics.c +++ b/libgfortran/intrinsics/string_intrinsics.c @@ -1,8 +1,7 @@ /* String intrinsics helper functions. - Copyright 2002, 2005, 2007 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> + Copyright 2008 Free Software Foundation, Inc. -This file is part of the GNU Fortran 95 runtime library (libgfortran). +This file is part of the GNU Fortran runtime library (libgfortran). Libgfortran is free software; you can redistribute it and/or modify it under the terms of the GNU General Public @@ -42,378 +41,45 @@ Boston, MA 02110-1301, USA. */ #include <string.h> -/* String functions. */ +/* Helper function to set parts of wide strings to a constant (usually + spaces). */ -extern void concat_string (GFC_INTEGER_4, char *, - GFC_INTEGER_4, const char *, - GFC_INTEGER_4, const char *); -export_proto(concat_string); - -extern GFC_INTEGER_4 string_len_trim (GFC_INTEGER_4, const char *); -export_proto(string_len_trim); - -extern void adjustl (char *, GFC_INTEGER_4, const char *); -export_proto(adjustl); - -extern void adjustr (char *, GFC_INTEGER_4, const char *); -export_proto(adjustr); - -extern GFC_INTEGER_4 string_index (GFC_INTEGER_4, const char *, GFC_INTEGER_4, - const char *, GFC_LOGICAL_4); -export_proto(string_index); - -extern GFC_INTEGER_4 string_scan (GFC_INTEGER_4, const char *, GFC_INTEGER_4, - const char *, GFC_LOGICAL_4); -export_proto(string_scan); - -extern GFC_INTEGER_4 string_verify (GFC_INTEGER_4, const char *, GFC_INTEGER_4, - const char *, GFC_LOGICAL_4); -export_proto(string_verify); - -extern void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *); -export_proto(string_trim); - -extern void string_minmax (GFC_INTEGER_4 *, void **, int, int, ...); -export_proto(string_minmax); - - -/* Use for functions which can return a zero-length string. */ -static char zero_length_string = '\0'; - - -/* Strings of unequal length are extended with pad characters. */ - -int -compare_string (GFC_INTEGER_4 len1, const char * s1, - GFC_INTEGER_4 len2, const char * s2) -{ - int res; - const unsigned char *s; - int len; - - res = memcmp (s1, s2, (len1 < len2) ? len1 : len2); - if (res != 0) - return res; - - if (len1 == len2) - return 0; - - if (len1 < len2) - { - len = len2 - len1; - s = (unsigned char *) &s2[len1]; - res = -1; - } - else - { - len = len1 - len2; - s = (unsigned char *) &s1[len2]; - res = 1; - } - - while (len--) - { - if (*s != ' ') - { - if (*s > ' ') - return res; - else - return -res; - } - s++; - } - - return 0; -} -iexport(compare_string); - - -/* The destination and source should not overlap. */ - -void -concat_string (GFC_INTEGER_4 destlen, char * dest, - GFC_INTEGER_4 len1, const char * s1, - GFC_INTEGER_4 len2, const char * s2) -{ - if (len1 >= destlen) - { - memcpy (dest, s1, destlen); - return; - } - memcpy (dest, s1, len1); - dest += len1; - destlen -= len1; - - if (len2 >= destlen) - { - memcpy (dest, s2, destlen); - return; - } - - memcpy (dest, s2, len2); - memset (&dest[len2], ' ', destlen - len2); -} - - -/* Return string with all trailing blanks removed. */ - -void -string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen, - const char * src) -{ - int i; - - /* Determine length of result string. */ - for (i = slen - 1; i >= 0; i--) - { - if (src[i] != ' ') - break; - } - *len = i + 1; - - if (*len == 0) - *dest = &zero_length_string; - else - { - /* Allocate space for result string. */ - *dest = internal_malloc_size (*len); - - /* Copy string if necessary. */ - memmove (*dest, src, *len); - } -} - - -/* The length of a string not including trailing blanks. */ - -GFC_INTEGER_4 -string_len_trim (GFC_INTEGER_4 len, const char * s) -{ - int i; - - for (i = len - 1; i >= 0; i--) - { - if (s[i] != ' ') - break; - } - return i + 1; -} - - -/* Find a substring within a string. */ - -GFC_INTEGER_4 -string_index (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 sslen, - const char * sstr, GFC_LOGICAL_4 back) -{ - int start; - int last; - int i; - int delta; - - if (sslen == 0) - return 1; - - if (sslen > slen) - return 0; - - if (!back) - { - last = slen + 1 - sslen; - start = 0; - delta = 1; - } - else - { - last = -1; - start = slen - sslen; - delta = -1; - } - i = 0; - for (; start != last; start+= delta) - { - for (i = 0; i < sslen; i++) - { - if (str[start + i] != sstr[i]) - break; - } - if (i == sslen) - return (start + 1); - } - return 0; -} - - -/* Remove leading blanks from a string, padding at end. The src and dest - should not overlap. */ - -void -adjustl (char *dest, GFC_INTEGER_4 len, const char *src) -{ - int i; - - i = 0; - while (i<len && src[i] == ' ') - i++; - - if (i < len) - memcpy (dest, &src[i], len - i); - if (i > 0) - memset (&dest[len - i], ' ', i); -} - - -/* Remove trailing blanks from a string. */ - -void -adjustr (char *dest, GFC_INTEGER_4 len, const char *src) -{ - int i; - - i = len; - while (i > 0 && src[i - 1] == ' ') - i--; - - if (i < len) - memset (dest, ' ', len - i); - memcpy (dest + (len - i), src, i ); -} - - -/* Scan a string for any one of the characters in a set of characters. */ - -GFC_INTEGER_4 -string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen, - const char * set, GFC_LOGICAL_4 back) -{ - int i, j; - - if (slen == 0 || setlen == 0) - return 0; - - if (back) - { - for (i = slen - 1; i >= 0; i--) - { - for (j = 0; j < setlen; j++) - { - if (str[i] == set[j]) - return (i + 1); - } - } - } - else - { - for (i = 0; i < slen; i++) - { - for (j = 0; j < setlen; j++) - { - if (str[i] == set[j]) - return (i + 1); - } - } - } - - return 0; -} - - -/* Verify that a set of characters contains all the characters in a - string by identifying the position of the first character in a - characters that does not appear in a given set of characters. */ - -GFC_INTEGER_4 -string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen, - const char * set, GFC_LOGICAL_4 back) +static gfc_char4_t * +memset_char4 (gfc_char4_t *b, gfc_char4_t c, size_t len) { - int start; - int last; - int i; - int delta; - - if (slen == 0) - return 0; + size_t i; - if (back) - { - last = -1; - start = slen - 1; - delta = -1; - } - else - { - last = slen; - start = 0; - delta = 1; - } - for (; start != last; start += delta) - { - for (i = 0; i < setlen; i++) - { - if (str[start] == set[i]) - break; - } - if (i == setlen) - return (start + 1); - } + for (i = 0; i < len; i++) + b[i] = c; - return 0; + return b; } -/* MIN and MAX intrinsics for strings. The front-end makes sure that - nargs is at least 2. */ +/* All other functions are defined using a few generic macros in + string_intrinsics_inc.c, so we avoid code duplication between the + various character type kinds. */ -void -string_minmax (GFC_INTEGER_4 *rlen, void **dest, int op, int nargs, ...) -{ - va_list ap; - int i; - char * next, * res; - GFC_INTEGER_4 nextlen, reslen; - - va_start (ap, nargs); - reslen = va_arg (ap, GFC_INTEGER_4); - res = va_arg (ap, char *); - *rlen = reslen; - - if (res == NULL) - runtime_error ("First argument of '%s' intrinsic should be present", - op > 0 ? "MAX" : "MIN"); +#undef CHARTYPE +#define CHARTYPE char +#undef UCHARTYPE +#define UCHARTYPE unsigned char +#undef SUFFIX +#define SUFFIX(x) x +#undef MEMSET +#define MEMSET memset - for (i = 1; i < nargs; i++) - { - nextlen = va_arg (ap, GFC_INTEGER_4); - next = va_arg (ap, char *); +#include "string_intrinsics_inc.c" - if (next == NULL) - { - if (i == 1) - runtime_error ("Second argument of '%s' intrinsic should be " - "present", op > 0 ? "MAX" : "MIN"); - else - continue; - } +#undef CHARTYPE +#define CHARTYPE gfc_char4_t +#undef UCHARTYPE +#define UCHARTYPE gfc_char4_t +#undef SUFFIX +#define SUFFIX(x) x ## _char4 +#undef MEMSET +#define MEMSET memset_char4 - if (nextlen > *rlen) - *rlen = nextlen; +#include "string_intrinsics_inc.c" - if (op * compare_string (reslen, res, nextlen, next) < 0) - { - reslen = nextlen; - res = next; - } - } - va_end (ap); - - if (*rlen == 0) - *dest = &zero_length_string; - else - { - char * tmp = internal_malloc_size (*rlen); - memcpy (tmp, res, reslen); - memset (&tmp[reslen], ' ', *rlen - reslen); - *dest = tmp; - } -} diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c b/libgfortran/intrinsics/string_intrinsics_inc.c new file mode 100644 index 0000000..87e137e --- /dev/null +++ b/libgfortran/intrinsics/string_intrinsics_inc.c @@ -0,0 +1,418 @@ +/* String intrinsics helper functions. + Copyright 2002, 2005, 2007, 2008 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later version. + +In addition to the permissions in the GNU General Public License, the +Free Software Foundation gives you unlimited permission to link the +compiled version of this file into combinations with other programs, +and to distribute those combinations without any restriction coming +from the use of this file. (The General Public License restrictions +do apply in other respects; for example, they cover modification of +the file, and distribution when not linked into a combine +executable.) + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public +License along with libgfortran; see the file COPYING. If not, +write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + + +/* Rename the functions. */ +#define concat_string SUFFIX(concat_string) +#define string_len_trim SUFFIX(string_len_trim) +#define adjustl SUFFIX(adjustl) +#define adjustr SUFFIX(adjustr) +#define string_index SUFFIX(string_index) +#define string_scan SUFFIX(string_scan) +#define string_verify SUFFIX(string_verify) +#define string_trim SUFFIX(string_trim) +#define string_minmax SUFFIX(string_minmax) +#define zero_length_string SUFFIX(zero_length_string) +#define compare_string SUFFIX(compare_string) + + +/* The prototypes. */ + +extern void concat_string (gfc_charlen_type, CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *); +export_proto(concat_string); + +extern gfc_charlen_type string_len_trim (gfc_charlen_type, const CHARTYPE *); +export_proto(string_len_trim); + +extern void adjustl (CHARTYPE *, gfc_charlen_type, const CHARTYPE *); +export_proto(adjustl); + +extern void adjustr (CHARTYPE *, gfc_charlen_type, const CHARTYPE *); +export_proto(adjustr); + +extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + GFC_LOGICAL_4); +export_proto(string_index); + +extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + GFC_LOGICAL_4); +export_proto(string_scan); + +extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + GFC_LOGICAL_4); +export_proto(string_verify); + +extern void string_trim (gfc_charlen_type *, CHARTYPE **, gfc_charlen_type, + const CHARTYPE *); +export_proto(string_trim); + +extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...); +export_proto(string_minmax); + + +/* Use for functions which can return a zero-length string. */ +static CHARTYPE zero_length_string = 0; + + +/* Strings of unequal length are extended with pad characters. */ + +int +compare_string (gfc_charlen_type len1, const CHARTYPE *s1, + gfc_charlen_type len2, const CHARTYPE *s2) +{ + const UCHARTYPE *s; + gfc_charlen_type len; + int res; + + res = memcmp (s1, s2, ((len1 < len2) ? len1 : len2) * sizeof (CHARTYPE)); + if (res != 0) + return res; + + if (len1 == len2) + return 0; + + if (len1 < len2) + { + len = len2 - len1; + s = (UCHARTYPE *) &s2[len1]; + res = -1; + } + else + { + len = len1 - len2; + s = (UCHARTYPE *) &s1[len2]; + res = 1; + } + + while (len--) + { + if (*s != ' ') + { + if (*s > ' ') + return res; + else + return -res; + } + s++; + } + + return 0; +} +iexport(compare_string); + + +/* The destination and source should not overlap. */ + +void +concat_string (gfc_charlen_type destlen, CHARTYPE * dest, + gfc_charlen_type len1, const CHARTYPE * s1, + gfc_charlen_type len2, const CHARTYPE * s2) +{ + if (len1 >= destlen) + { + memcpy (dest, s1, destlen * sizeof (CHARTYPE)); + return; + } + memcpy (dest, s1, len1 * sizeof (CHARTYPE)); + dest += len1; + destlen -= len1; + + if (len2 >= destlen) + { + memcpy (dest, s2, destlen * sizeof (CHARTYPE)); + return; + } + + memcpy (dest, s2, len2 * sizeof (CHARTYPE)); + MEMSET (&dest[len2], ' ', destlen - len2); +} + + +/* Return string with all trailing blanks removed. */ + +void +string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen, + const CHARTYPE *src) +{ + gfc_charlen_type i; + + /* Determine length of result string. */ + for (i = slen - 1; i >= 0; i--) + { + if (src[i] != ' ') + break; + } + *len = i + 1; + + if (*len == 0) + *dest = &zero_length_string; + else + { + /* Allocate space for result string. */ + *dest = internal_malloc_size (*len * sizeof (CHARTYPE)); + + /* Copy string if necessary. */ + memcpy (*dest, src, *len * sizeof (CHARTYPE)); + } +} + + +/* The length of a string not including trailing blanks. */ + +gfc_charlen_type +string_len_trim (gfc_charlen_type len, const CHARTYPE *s) +{ + gfc_charlen_type i; + + for (i = len - 1; i >= 0; i--) + { + if (s[i] != ' ') + break; + } + return i + 1; +} + + +/* Find a substring within a string. */ + +gfc_charlen_type +string_index (gfc_charlen_type slen, const CHARTYPE *str, + gfc_charlen_type sslen, const CHARTYPE *sstr, + GFC_LOGICAL_4 back) +{ + gfc_charlen_type start, last, delta, i; + + if (sslen == 0) + return 1; + + if (sslen > slen) + return 0; + + if (!back) + { + last = slen + 1 - sslen; + start = 0; + delta = 1; + } + else + { + last = -1; + start = slen - sslen; + delta = -1; + } + + for (; start != last; start+= delta) + { + for (i = 0; i < sslen; i++) + { + if (str[start + i] != sstr[i]) + break; + } + if (i == sslen) + return (start + 1); + } + return 0; +} + + +/* Remove leading blanks from a string, padding at end. The src and dest + should not overlap. */ + +void +adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src) +{ + gfc_charlen_type i; + + i = 0; + while (i < len && src[i] == ' ') + i++; + + if (i < len) + memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE)); + if (i > 0) + MEMSET (&dest[len - i], ' ', i); +} + + +/* Remove trailing blanks from a string. */ + +void +adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src) +{ + gfc_charlen_type i; + + i = len; + while (i > 0 && src[i - 1] == ' ') + i--; + + if (i < len) + MEMSET (dest, ' ', len - i); + memcpy (&dest[len - i], src, i * sizeof (CHARTYPE)); +} + + +/* Scan a string for any one of the characters in a set of characters. */ + +gfc_charlen_type +string_scan (gfc_charlen_type slen, const CHARTYPE *str, + gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back) +{ + gfc_charlen_type i, j; + + if (slen == 0 || setlen == 0) + return 0; + + if (back) + { + for (i = slen - 1; i >= 0; i--) + { + for (j = 0; j < setlen; j++) + { + if (str[i] == set[j]) + return (i + 1); + } + } + } + else + { + for (i = 0; i < slen; i++) + { + for (j = 0; j < setlen; j++) + { + if (str[i] == set[j]) + return (i + 1); + } + } + } + + return 0; +} + + +/* Verify that a set of characters contains all the characters in a + string by identifying the position of the first character in a + characters that does not appear in a given set of characters. */ + +gfc_charlen_type +string_verify (gfc_charlen_type slen, const CHARTYPE *str, + gfc_charlen_type setlen, const CHARTYPE *set, + GFC_LOGICAL_4 back) +{ + gfc_charlen_type start, last, delta, i; + + if (slen == 0) + return 0; + + if (back) + { + last = -1; + start = slen - 1; + delta = -1; + } + else + { + last = slen; + start = 0; + delta = 1; + } + for (; start != last; start += delta) + { + for (i = 0; i < setlen; i++) + { + if (str[start] == set[i]) + break; + } + if (i == setlen) + return (start + 1); + } + + return 0; +} + + +/* MIN and MAX intrinsics for strings. The front-end makes sure that + nargs is at least 2. */ + +void +string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...) +{ + va_list ap; + int i; + CHARTYPE *next, *res; + gfc_charlen_type nextlen, reslen; + + va_start (ap, nargs); + reslen = va_arg (ap, gfc_charlen_type); + res = va_arg (ap, CHARTYPE *); + *rlen = reslen; + + if (res == NULL) + runtime_error ("First argument of '%s' intrinsic should be present", + op > 0 ? "MAX" : "MIN"); + + for (i = 1; i < nargs; i++) + { + nextlen = va_arg (ap, gfc_charlen_type); + next = va_arg (ap, CHARTYPE *); + + if (next == NULL) + { + if (i == 1) + runtime_error ("Second argument of '%s' intrinsic should be " + "present", op > 0 ? "MAX" : "MIN"); + else + continue; + } + + if (nextlen > *rlen) + *rlen = nextlen; + + if (op * compare_string (reslen, res, nextlen, next) < 0) + { + reslen = nextlen; + res = next; + } + } + va_end (ap); + + if (*rlen == 0) + *dest = &zero_length_string; + else + { + CHARTYPE *tmp = internal_malloc_size (*rlen * sizeof (CHARTYPE)); + memcpy (tmp, res, reslen * sizeof (CHARTYPE)); + MEMSET (&tmp[reslen], ' ', *rlen - reslen); + *dest = tmp; + } +} |