@@ -8295,12 +8295,16 @@ gfc_reverse_ss (gfc_ss * ss)
}
-/* Walk the arguments of an elemental function. */
+/* 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.
+*/
gfc_ss *
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
- gfc_ss_type type)
+ gfc_expr *proc_expr, gfc_ss_type type)
{
+ gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
@@ -8308,6 +8312,28 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
head = gfc_ss_terminator;
tail = NULL;
+
+ if (proc_expr)
+ {
+ gfc_ref *ref;
+
+ /* Normal procedure case. */
+ dummy_arg = proc_expr->symtree->n.sym->formal;
+
+ /* Typebound procedure case. */
+ for (ref = proc_expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->ts.interface)
+ dummy_arg = ref->u.c.component->ts.interface->formal;
+ else
+ dummy_arg = NULL;
+ }
+ }
+ else
+ dummy_arg = NULL;
+
scalar = 1;
for (; arg; arg = arg->next)
{
@@ -8321,6 +8347,14 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
newss = gfc_get_scalar_ss (head, arg->expr);
newss->info->type = type;
+
+ if (dummy_arg != NULL
+ && dummy_arg->sym->attr.optional
+ && arg->expr
+ && arg->expr->symtree
+ && arg->expr->symtree->n.sym->attr.optional
+ && arg->expr->ref == NULL)
+ newss->info->data.scalar.can_be_null_ref = true;
}
else
scalar = 0;
@@ -8332,6 +8366,9 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
while (tail->next != gfc_ss_terminator)
tail = tail->next;
}
+
+ if (dummy_arg != NULL)
+ dummy_arg = dummy_arg->next;
}
if (scalar)
@@ -8381,7 +8418,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
by reference. */
if (sym->attr.elemental || (comp && comp->attr.elemental))
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
- GFC_SS_REFERENCE);
+ expr, GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */
@@ -73,7 +73,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_ss_type);
+ gfc_expr *, gfc_ss_type);
/* Walk an intrinsic function. */
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
gfc_intrinsic_sym *);
@@ -7145,7 +7145,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,
- GFC_SS_SCALAR);
+ NULL, GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;
@@ -348,7 +348,8 @@ 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, GFC_SS_REFERENCE);
+ ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
+ code->expr1, GFC_SS_REFERENCE);
/* Is not an elemental subroutine call with array valued arguments. */
if (ss == gfc_ss_terminator)