The KIND argument of the INDEX intrinsic is a compile time constant
that is used at compile time only to resolve to a kind-specific library
method. It is otherwise completely ignored at runtime, and there is
no code generated for it as the library procedure has no kind argument.
This confuses the scalarizer which expects to see every argument
of elemental functions to be used when calling a procedure.
This change removes the argument from the scalarization lists
at the beginning of the scalarization process, so that the argument
is completely ignored.
gcc/fortran/
PR fortran/97896
* trans-array.h (gfc_get_intrinsic_for_expr,
gfc_get_proc_ifc_for_expr): New.
* trans-array.c (gfc_get_intrinsic_for_expr,
arg_evaluated_for_scalarization): New.
(gfc_walk_elemental_function_args): Add intrinsic procedure
as argument. Count arguments. Check arg_evaluated_for_scalarization.
* trans-intrinsic.c (gfc_walk_intrinsic_function): Update call.
* trans-stmt.c (get_intrinsic_for_code): New.
(gfc_trans_call): Update call.
gcc/testsuite/
PR fortran/97896
* gfortran.dg/index_5.f90: New.
---
gcc/fortran/trans-array.c | 61 ++++++++++++++++++++++++++-
gcc/fortran/trans-array.h | 3 ++
gcc/fortran/trans-intrinsic.c | 1 +
gcc/fortran/trans-stmt.c | 20 +++++++++
gcc/testsuite/gfortran.dg/index_5.f90 | 23 ++++++++++
5 files changed, 107 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/index_5.f90
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c5d61f0065c..aae79c8cbd4 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -11177,6 +11177,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.
@@ -11184,6 +11237,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;
@@ -11200,10 +11254,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);
@@ -11236,6 +11293,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;
}
@@ -11296,6 +11354,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 e4d443d7118..def6f8a43a0 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -74,6 +74,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. */
@@ -82,6 +84,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-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c67a9fca46f..30042637de4 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -11172,6 +11172,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 7cbdef7a304..c7521098e22 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 00000000000..e039455d175
--- /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 <anl...@gcc.gnu.org>, based on an initial
+! submission by G. Steinmetz <gs...@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
+
