diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/intrinsic.c | 48 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 3 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.c | 21 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 61 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 24 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 20 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/index_5.f90 | 23 |
9 files changed, 121 insertions, 83 deletions
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index a5a087b..2d7d246 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -889,39 +889,6 @@ 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. */ @@ -2224,11 +2191,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_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); + 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); make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77); @@ -4531,10 +4498,9 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) arg = e->value.function.actual; - /* Special case hacks for MIN, MAX and INDEX. */ + /* Special case hacks for MIN and MAX. */ if (specific->resolve.f1m == gfc_resolve_max - || specific->resolve.f1m == gfc_resolve_min - || specific->resolve.f1m == gfc_resolve_index_func) + || specific->resolve.f1m == gfc_resolve_min) { (*specific->resolve.f1m) (e, arg); return; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 7511daa..fb655fb 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -519,7 +519,8 @@ 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_actual_arglist *); +void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); 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 e17fe45f..598c040 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1276,27 +1276,16 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) void -gfc_resolve_index_func (gfc_expr *f, gfc_actual_arglist *a) +gfc_resolve_index_func (gfc_expr *f, gfc_expr *str, + gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back, + gfc_expr *kind) { 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); else f->ts.kind = gfc_default_integer_kind; @@ -1311,8 +1300,6 @@ gfc_resolve_index_func (gfc_expr *f, gfc_actual_arglist *a) 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-array.c b/gcc/fortran/trans-array.c index 5ceb261..7932185 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -11460,6 +11460,59 @@ gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) } +/* Given an expression referring to an intrinsic function call, + return the intrinsic symbol. */ + +gfc_intrinsic_sym * +gfc_get_intrinsic_for_expr (gfc_expr *call) +{ + if (call == NULL) + return NULL; + + /* Normal procedure case. */ + if (call->expr_type == EXPR_FUNCTION) + return call->value.function.isym; + else + return NULL; +} + + +/* Indicates whether an argument to an intrinsic function should be used in + scalarization. It is usually the case, except for some intrinsics + requiring the value to be constant, and using the value at compile time only. + As the value is not used at runtime in those cases, we don’t produce code + for it, and it should not be visible to the scalarizer. + FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual + argument being examined in that call, and ARG_NUM the index number + of ACTUAL_ARG in the list of arguments. + The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is + identified using the name in ACTUAL_ARG if it is present (that is: if it’s + a keyword argument), otherwise using ARG_NUM. */ + +static bool +arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, + gfc_actual_arglist &actual_arg, int arg_num) +{ + if (function != NULL) + { + switch (function->id) + { + case GFC_ISYM_INDEX: + if ((actual_arg.name == NULL && arg_num == 3) + || (actual_arg.name != NULL + && strcmp ("kind", actual_arg.name) == 0)) + return false; + /* Fallthrough. */ + + default: + break; + } + } + + return true; +} + + /* Walk the arguments of an elemental function. PROC_EXPR is used to check whether an argument is permitted to be absent. If it is NULL, we don't do the check and the argument is assumed to be present. @@ -11467,6 +11520,7 @@ gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) gfc_ss * gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, + gfc_intrinsic_sym *intrinsic_sym, gfc_symbol *proc_ifc, gfc_ss_type type) { gfc_formal_arglist *dummy_arg; @@ -11483,10 +11537,13 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, else dummy_arg = NULL; + int arg_num = 0; scalar = 1; for (; arg; arg = arg->next) { - if (!arg->expr || arg->expr->expr_type == EXPR_NULL) + if (!arg->expr + || arg->expr->expr_type == EXPR_NULL + || !arg_evaluated_for_scalarization (intrinsic_sym, *arg, arg_num)) goto loop_continue; newss = gfc_walk_subexpr (head, arg->expr); @@ -11519,6 +11576,7 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, } loop_continue: + arg_num++; if (dummy_arg != NULL) dummy_arg = dummy_arg->next; } @@ -11579,6 +11637,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) ss = gfc_walk_elemental_function_args (old_ss, expr->value.function.actual, + gfc_get_intrinsic_for_expr (expr), gfc_get_proc_ifc_for_expr (expr), GFC_SS_REFERENCE); if (ss != old_ss diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 12068c7..8f806c3 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -76,6 +76,8 @@ void gfc_trans_static_array_pointer (gfc_symbol *); /* Get the procedure interface for a function call. */ gfc_symbol *gfc_get_proc_ifc_for_expr (gfc_expr *); +/* Get the intrinsic symbol for an intrinsic function call. */ +gfc_intrinsic_sym *gfc_get_intrinsic_for_expr (gfc_expr *); /* Generate scalarization information for an expression. */ gfc_ss *gfc_walk_expr (gfc_expr *); /* Workhorse for gfc_walk_expr. */ @@ -84,6 +86,7 @@ gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *); gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref); /* Walk the arguments of an elemental function. */ gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *, + gfc_intrinsic_sym *, gfc_symbol *, gfc_ss_type); /* Walk an intrinsic function. */ gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *, diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 49ba906..cb7f684 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -42,7 +42,6 @@ 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" @@ -2267,28 +2266,7 @@ module_sym: { /* All specific intrinsics take less than 5 arguments. */ gcc_assert (isym->formal->next->next->next->next == 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); + isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); } } } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 0d91958..3f86791 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -11084,6 +11084,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, if (isym->elemental) return gfc_walk_elemental_function_args (ss, expr->value.function.actual, + expr->value.function.isym, NULL, GFC_SS_SCALAR); if (expr->rank == 0) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index eaf2cc2..bdf7957 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -356,6 +356,25 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, } +/* Given an executable statement referring to an intrinsic function call, + returns the intrinsic symbol. */ + +static gfc_intrinsic_sym * +get_intrinsic_for_code (gfc_code *code) +{ + if (code->op == EXEC_CALL) + { + gfc_intrinsic_sym * const isym = code->resolved_isym; + if (isym) + return isym; + else + return gfc_get_intrinsic_for_expr (code->expr1); + } + + return NULL; +} + + /* Get the interface symbol for the procedure corresponding to the given call. We can't get the procedure symbol directly as we have to handle the case of (deferred) type-bound procedures. */ @@ -402,6 +421,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, ss = gfc_ss_terminator; if (code->resolved_sym->attr.elemental) ss = gfc_walk_elemental_function_args (ss, code->ext.actual, + get_intrinsic_for_code (code), get_proc_ifc_for_call (code), GFC_SS_REFERENCE); diff --git a/gcc/testsuite/gfortran.dg/index_5.f90 b/gcc/testsuite/gfortran.dg/index_5.f90 new file mode 100644 index 0000000..e039455 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/index_5.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/97896 +! An ICE occured with INDEX when the KIND argument was present +! because of a mismatch between the number of arguments expected +! during the scalarization process and the number of arguments actually +! used. +! +! Test contributed by Harald Anlauf <anlauf@gcc.gnu.org>, based on an initial +! submission by G. Steinmetz <gscfq@t-online.de>. + +program p + implicit none + logical :: a(2) + integer :: b(2) + integer(8) :: d(2) + b = index ('xyxyz','yx', back=a) + b = index ('xyxyz','yx', back=a, kind=4) + d = index ('xyxyz','yx', back=a, kind=8) + b = index ('xyxyz','yx', back=a, kind=8) + d = index ('xyxyz','yx', back=a, kind=4) +end + |