@@ -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
@@ -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 *,
@@ -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)
@@ -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);
new file mode 100644
@@ -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
+