diff options
Diffstat (limited to 'libgfortran/intrinsics')
| -rw-r--r-- | libgfortran/intrinsics/extends_type_of.c | 2 | ||||
| -rw-r--r-- | libgfortran/intrinsics/string_intrinsics_inc.c | 52 |
2 files changed, 53 insertions, 1 deletions
diff --git a/libgfortran/intrinsics/extends_type_of.c b/libgfortran/intrinsics/extends_type_of.c index 8768b2d..dab14ee 100644 --- a/libgfortran/intrinsics/extends_type_of.c +++ b/libgfortran/intrinsics/extends_type_of.c @@ -58,7 +58,7 @@ is_extension_of (struct vtype *v1, struct vtype *v2) while (v1) { - if (v1->hash == v2->hash) return 1; + if (v1 == v2) return 1; v1 = v1->extends; } return 0; diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c b/libgfortran/intrinsics/string_intrinsics_inc.c index d86bb6c..aeecf68 100644 --- a/libgfortran/intrinsics/string_intrinsics_inc.c +++ b/libgfortran/intrinsics/string_intrinsics_inc.c @@ -33,6 +33,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #define string_verify SUFFIX(string_verify) #define string_trim SUFFIX(string_trim) #define string_minmax SUFFIX(string_minmax) +#define string_split SUFFIX(string_split) #define zero_length_string SUFFIX(zero_length_string) #define compare_string SUFFIX(compare_string) @@ -72,6 +73,10 @@ export_proto(string_trim); extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...); export_proto(string_minmax); +extern gfc_charlen_type string_split (gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, GFC_LOGICAL_4); +export_proto (string_split); /* Use for functions which can return a zero-length string. */ static CHARTYPE zero_length_string = 0; @@ -459,3 +464,50 @@ string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...) *dest = tmp; } } + +gfc_charlen_type +string_split (gfc_charlen_type stringlen, const CHARTYPE *string, + gfc_charlen_type setlen, const CHARTYPE *set, + gfc_charlen_type pos, GFC_LOGICAL_4 back) +{ + gfc_charlen_type i, j; + + if (!back) + { + if (pos > stringlen) + runtime_error ("If BACK is present with the value false, the value of " + "POS shall be in the range [0, LEN (STRING)], " + "where POS = %ld and LEN (STRING) = %ld", + pos, stringlen); + + for (i = pos + 1; i <= stringlen; i++) + { + for (j = 0; j < setlen; j++) + { + if (string[i - 1] == set[j]) + return i; + } + } + + return stringlen + 1; + } + else + { + if (pos < 1 || pos > (stringlen + 1)) + runtime_error ("If BACK is present with the value true, the value of " + "POS shall be in the range [1, LEN (STRING) + 1], " + "where POS = %ld and LEN (STRING) = %ld", + pos, stringlen); + + for (i = pos - 1; i != 0; i--) + { + for (j = 0; j < setlen; j++) + { + if (string[i - 1] == set[j]) + return i; + } + } + + return 0; + } +} |