Index: intrinsic.c =================================================================== --- intrinsic.c (Revision 279405) +++ intrinsic.c (Arbeitskopie) @@ -851,7 +851,40 @@ add_sym_4 (const char *name, gfc_isym_id id, enum (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, gf 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; Index: intrinsic.h =================================================================== --- intrinsic.h (Revision 279405) +++ intrinsic.h (Arbeitskopie) @@ -517,8 +517,7 @@ void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gf 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 *); Index: iresolve.c =================================================================== --- iresolve.c (Revision 279405) +++ iresolve.c (Arbeitskopie) @@ -1352,16 +1352,31 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_exp 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 @@ void f->value.function.name = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind); + + f->do_not_resolve_again = 1; } Index: trans-decl.c =================================================================== --- trans-decl.c (Revision 279405) +++ trans-decl.c (Arbeitskopie) @@ -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); } } }