From: Thomas Koenig Date: Mon, 30 Dec 2019 10:43:38 +0000 (+0000) Subject: Remove KIND argument from INDEX so it does not mess up scalarization. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d09847357b965a2c2cda063827ce362d4c9c86f2;p=gcc.git Remove KIND argument from INDEX so it does not mess up scalarization. 2019-12-30 Thomas Koenig PR fortran/91541 * intrinsic.c (add_sym_4ind): New function. (add_functions): Use it for INDEX. (resolve_intrinsic): Also call f1m for INDEX. * intrinsic.h (gfc_resolve_index_func): Adjust prototype to take a gfc_arglist instead of individual arguments. * iresolve.c (gfc_resolve_index_func): Adjust arguments. Remove KIND argument if present, and make sure this is not done twice. * trans-decl.c: Include "intrinsic.h". (gfc_get_extern_function_decl): Special case for resolving INDEX. 2019-12-30 Thomas Koenig PR fortran/91541 * gfortran.dg/index_3.f90: New test. From-SVN: r279763 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5b92597641b..1e6d236910f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2019-12-30 Thomas Koenig + + PR fortran/91541 + * intrinsic.c (add_sym_4ind): New function. + (add_functions): Use it for INDEX. + (resolve_intrinsic): Also call f1m for INDEX. + * intrinsic.h (gfc_resolve_index_func): Adjust prototype to + take a gfc_arglist instead of individual arguments. + * iresolve.c (gfc_resolve_index_func): Adjust arguments. + Remove KIND argument if present, and make sure this is + not done twice. + * trans-decl.c: Include "intrinsic.h". + (gfc_get_extern_function_decl): Special case for resolving INDEX. + 2019-12-30 Thomas Koenig PR fortran/92961 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index c913f5ab152..9596018fe0a 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -851,6 +851,39 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty (void *) 0); } +/* Add a symbol to the function list where the function takes 4 + arguments and resolution may need to change the number or + arrangement of arguments. This is the case for INDEX, which needs + its KIND argument removed. */ + +static void +add_sym_4ind (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + void (*resolve) (gfc_expr *, gfc_actual_arglist *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4 ) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f4 = check; + sf.f4 = simplify; + rf.f1m = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, + (void *) 0); +} + /* Add a symbol to the subroutine list where the subroutine takes 4 arguments. */ @@ -2153,11 +2186,11 @@ add_functions (void) /* The resolution function for INDEX is called gfc_resolve_index_func because the name gfc_resolve_index is already used in resolve.c. */ - add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, - BT_INTEGER, di, GFC_STD_F77, - gfc_check_index, gfc_simplify_index, gfc_resolve_index_func, - stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, - bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); + add_sym_4ind ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, + BT_INTEGER, di, GFC_STD_F77, + gfc_check_index, gfc_simplify_index, gfc_resolve_index_func, + stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, + bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77); @@ -4434,9 +4467,10 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) arg = e->value.function.actual; - /* Special case hacks for MIN and MAX. */ + /* Special case hacks for MIN, MAX and INDEX. */ if (specific->resolve.f1m == gfc_resolve_max - || specific->resolve.f1m == gfc_resolve_min) + || specific->resolve.f1m == gfc_resolve_min + || specific->resolve.f1m == gfc_resolve_index_func) { (*specific->resolve.f1m) (e, arg); return; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 0c60dab8390..f7d0a15f379 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -517,8 +517,7 @@ void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *); -void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *); +void gfc_resolve_index_func (gfc_expr *, gfc_actual_arglist *); void gfc_resolve_ierrno (gfc_expr *); void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 53338dda0a7..2a44a0a9978 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1352,16 +1352,31 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) void -gfc_resolve_index_func (gfc_expr *f, gfc_expr *str, - gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back, - gfc_expr *kind) +gfc_resolve_index_func (gfc_expr *f, gfc_actual_arglist *a) { gfc_typespec ts; gfc_clear_ts (&ts); + gfc_expr *str, *back, *kind; + gfc_actual_arglist *a_sub_str, *a_back, *a_kind; + + if (f->do_not_resolve_again) + return; + + a_sub_str = a->next; + a_back = a_sub_str->next; + a_kind = a_back->next; + + str = a->expr; + back = a_back->expr; + kind = a_kind->expr; f->ts.type = BT_INTEGER; if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); + { + f->ts.kind = mpz_get_si ((kind)->value.integer); + a_back->next = NULL; + gfc_free_actual_arglist (a_kind); + } else f->ts.kind = gfc_default_integer_kind; @@ -1376,6 +1391,8 @@ gfc_resolve_index_func (gfc_expr *f, gfc_expr *str, f->value.function.name = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind); + + f->do_not_resolve_again = 1; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d0fc5d38e20..a8fe7b997c2 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -42,6 +42,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-types.h" #include "trans-array.h" #include "trans-const.h" +#include "intrinsic.h" /* For gfc_resolve_index_func. */ /* Only for gfc_trans_code. Shouldn't need to include this. */ #include "trans-stmt.h" #include "gomp-constants.h" @@ -2210,7 +2211,28 @@ module_sym: { /* All specific intrinsics take less than 5 arguments. */ gcc_assert (isym->formal->next->next->next->next == NULL); - isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); + if (isym->resolve.f1m == gfc_resolve_index_func) + { + /* gfc_resolve_index_func is special because it takes a + gfc_actual_arglist instead of individual arguments. */ + gfc_actual_arglist *a, *n; + int i; + a = gfc_get_actual_arglist(); + n = a; + + for (i = 0; i < 4; i++) + { + n->next = gfc_get_actual_arglist(); + n = n->next; + } + + a->expr = &argexpr; + isym->resolve.f1m (&e, a); + a->expr = NULL; + gfc_free_actual_arglist (a); + } + else + isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); } } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d7044518a02..8cb6f299f7c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-12-30 Thomas Koenig + + PR fortran/91541 + * gfortran.dg/index_3.f90: New test. + 2019-12-30 Thomas Koenig PR fortran/92961 diff --git a/gcc/testsuite/gfortran.dg/index_3.f90 b/gcc/testsuite/gfortran.dg/index_3.f90 new file mode 100644 index 00000000000..40c476a2613 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/index_3.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR 91541 - this used to give an ICE. +! Bug report by Gerhard Steinmetz. +program p + integer :: z(2) + z = index('100101', '10', [.false.,.true.],kind=4) + if (z(1) /= 1 .or. z(2) /= 4) stop 1 +end