@@ -2333,6 +2333,10 @@ struct gfc_dummy_arg
#define gfc_get_dummy_arg() XCNEW (gfc_dummy_arg)
+const gfc_typespec & gfc_dummy_arg_get_typespec (gfc_dummy_arg &);
+bool gfc_dummy_arg_is_optional (gfc_dummy_arg &);
+
+
/* Specifies the various kinds of check functions used to verify the
argument lists of intrinsic functions. fX with X an integer refer
to check functions of intrinsics with X arguments. f1m is used for
@@ -5503,3 +5503,37 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
f = &((*f)->next);
}
}
+
+
+const gfc_typespec &
+gfc_dummy_arg_get_typespec (gfc_dummy_arg & dummy_arg)
+{
+ switch (dummy_arg.intrinsicness)
+ {
+ case GFC_INTRINSIC_DUMMY_ARG:
+ return dummy_arg.u.intrinsic->ts;
+
+ case GFC_NON_INTRINSIC_DUMMY_ARG:
+ return dummy_arg.u.non_intrinsic->sym->ts;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+bool
+gfc_dummy_arg_is_optional (gfc_dummy_arg & dummy_arg)
+{
+ switch (dummy_arg.intrinsicness)
+ {
+ case GFC_INTRINSIC_DUMMY_ARG:
+ return dummy_arg.u.intrinsic->optional;
+
+ case GFC_NON_INTRINSIC_DUMMY_ARG:
+ return dummy_arg.u.non_intrinsic->sym->attr.optional;
+
+ default:
+ gcc_unreachable ();
+ }
+}
@@ -3010,7 +3010,8 @@ gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
/* If the expression is of polymorphic type, it's actual size is not known,
so we avoid copying it anywhere. */
if (ss_info->data.scalar.dummy_arg
- && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS
+ && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
+ == BT_CLASS
&& ss_info->expr->ts.type == BT_CLASS)
return true;
@@ -11521,9 +11522,8 @@ arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
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_ss_type type)
{
- gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
@@ -11532,15 +11532,11 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
head = gfc_ss_terminator;
tail = NULL;
- if (proc_ifc)
- dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
- else
- dummy_arg = NULL;
-
int arg_num = 0;
scalar = 1;
for (; arg; arg = arg->next)
{
+ gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
if (!arg->expr
|| arg->expr->expr_type == EXPR_NULL
|| !arg_evaluated_for_scalarization (intrinsic_sym, *arg, arg_num))
@@ -11554,13 +11550,13 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
newss = gfc_get_scalar_ss (head, arg->expr);
newss->info->type = type;
if (dummy_arg)
- newss->info->data.scalar.dummy_arg = dummy_arg->sym;
+ newss->info->data.scalar.dummy_arg = dummy_arg;
}
else
scalar = 0;
if (dummy_arg != NULL
- && dummy_arg->sym->attr.optional
+ && gfc_dummy_arg_is_optional (*dummy_arg)
&& arg->expr->expr_type == EXPR_VARIABLE
&& (gfc_expr_attr (arg->expr).optional
|| gfc_expr_attr (arg->expr).allocatable
@@ -11577,8 +11573,6 @@ 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;
}
if (scalar)
@@ -11638,7 +11632,6 @@ 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
&& (comp
@@ -87,7 +87,7 @@ 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);
+ gfc_ss_type);
/* Walk an intrinsic function. */
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
gfc_intrinsic_sym *);
@@ -11085,7 +11085,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);
+ GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;
@@ -375,27 +375,6 @@ get_intrinsic_for_code (gfc_code *code)
}
-/* 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. */
-
-static gfc_symbol *
-get_proc_ifc_for_call (gfc_code *c)
-{
- gfc_symbol *sym;
-
- gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
-
- sym = gfc_get_proc_ifc_for_expr (c->expr1);
-
- /* Fall back/last resort try. */
- if (sym == NULL)
- sym = c->resolved_sym;
-
- return sym;
-}
-
-
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree
@@ -422,7 +401,6 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
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);
/* MVBITS is inlined but needs the dependency checking found here. */
@@ -266,8 +266,8 @@ typedef struct gfc_ss_info
struct
{
/* If the scalar is passed as actual argument to an (elemental) procedure,
- this is the symbol of the corresponding dummy argument. */
- gfc_symbol *dummy_arg;
+ this is the corresponding dummy argument. */
+ gfc_dummy_arg *dummy_arg;
tree value;
/* Tells that the scalar is a reference to a variable that might
be present on the lhs, so that we should evaluate the value