===================================================================
@@ -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;
===================================================================
@@ -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 *);
===================================================================
@@ -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;
}
===================================================================
@@ -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);
}
}
}