@@ -1144,6 +1144,9 @@ gfc_formal_arglist;
#define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist)
+struct gfc_dummy_arg;
+
+
/* The gfc_actual_arglist structure is for actual arguments and
for type parameter specification lists. */
typedef struct gfc_actual_arglist
@@ -1160,6 +1163,11 @@ typedef struct gfc_actual_arglist
gfc_param_spec_type spec_type;
struct gfc_expr *expr;
+
+ /* The dummy arg this actual arg is associated with, if the interface
+ is explicit. NULL otherwise. */
+ gfc_dummy_arg *associated_dummy;
+
struct gfc_actual_arglist *next;
}
gfc_actual_arglist;
@@ -2166,7 +2174,6 @@ typedef struct gfc_intrinsic_arg
gfc_typespec ts;
unsigned optional:1, value:1;
ENUM_BITFIELD (sym_intent) intent:2;
- gfc_actual_arglist *actual;
struct gfc_intrinsic_arg *next;
}
@@ -2191,6 +2198,8 @@ struct gfc_dummy_arg
} u;
};
+#define gfc_get_dummy_arg() XCNEW (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
@@ -3026,6 +3026,18 @@ lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
}
+static gfc_dummy_arg *
+get_nonintrinsic_dummy_arg (gfc_formal_arglist *formal)
+{
+ gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg ();
+
+ dummy_arg->kind = GFC_NON_INTRINSIC_DUMMY_ARG;
+ dummy_arg->u.non_intrinsic = formal;
+
+ return dummy_arg;
+}
+
+
/* Given formal and actual argument lists, see if they are compatible.
If they are compatible, the actual argument list is sorted to
correspond with the formal list, and elements for missing optional
@@ -3131,6 +3143,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
"call at %L", where);
return false;
}
+ else
+ a->associated_dummy = get_nonintrinsic_dummy_arg (f);
if (a->expr == NULL)
{
@@ -3546,9 +3560,12 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
/* The argument lists are compatible. We now relink a new actual
argument list with null arguments in the right places. The head
of the list remains the head. */
- for (i = 0; i < n; i++)
+ for (f = formal, i = 0; f; f = f->next, i++)
if (new_arg[i] == NULL)
- new_arg[i] = gfc_get_actual_arglist ();
+ {
+ new_arg[i] = gfc_get_actual_arglist ();
+ new_arg[i]->associated_dummy = get_nonintrinsic_dummy_arg (f);
+ }
if (na != 0)
{
@@ -4269,6 +4269,18 @@ remove_nullargs (gfc_actual_arglist **ap)
}
+static gfc_dummy_arg *
+get_intrinsic_dummy_arg (gfc_intrinsic_arg *intrinsic)
+{
+ gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg ();
+
+ dummy_arg->kind = GFC_INTRINSIC_DUMMY_ARG;
+ dummy_arg->u.intrinsic = intrinsic;
+
+ return dummy_arg;
+}
+
+
/* Given an actual arglist and a formal arglist, sort the actual
arglist so that its arguments are in a one-to-one correspondence
with the format arglist. Arguments that are not present are given
@@ -4286,8 +4298,14 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
remove_nullargs (ap);
actual = *ap;
+ auto_vec<gfc_intrinsic_arg *> dummy_args;
+ auto_vec<gfc_actual_arglist *> ordered_actual_args;
+
for (f = formal; f; f = f->next)
- f->actual = NULL;
+ dummy_args.safe_push (f);
+
+ ordered_actual_args.safe_grow_cleared (dummy_args.length (),
+ /* exact = */true);
f = formal;
a = actual;
@@ -4339,7 +4357,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
}
}
- for (;;)
+ for (int i = 0;; i++)
{ /* Put the nonkeyword arguments in a 1:1 correspondence */
if (f == NULL)
break;
@@ -4349,7 +4367,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
if (a->name != NULL)
goto keywords;
- f->actual = a;
+ ordered_actual_args[i] = a;
f = f->next;
a = a->next;
@@ -4367,7 +4385,8 @@ keywords:
to be keyword arguments. */
for (; a; a = a->next)
{
- for (f = formal; f; f = f->next)
+ int idx;
+ FOR_EACH_VEC_ELT (dummy_args, idx, f)
if (strcmp (a->name, f->name) == 0)
break;
@@ -4382,21 +4401,21 @@ keywords:
return false;
}
- if (f->actual != NULL)
+ if (ordered_actual_args[idx] != NULL)
{
gfc_error ("Argument %qs appears twice in call to %qs at %L",
f->name, name, where);
return false;
}
-
- f->actual = a;
+ ordered_actual_args[idx] = a;
}
optional:
/* At this point, all unmatched formal args must be optional. */
- for (f = formal; f; f = f->next)
+ int idx;
+ FOR_EACH_VEC_ELT (dummy_args, idx, f)
{
- if (f->actual == NULL && f->optional == 0)
+ if (ordered_actual_args[idx] == NULL && f->optional == 0)
{
gfc_error ("Missing actual argument %qs in call to %qs at %L",
f->name, name, where);
@@ -4409,9 +4428,9 @@ do_sort:
together in a way that corresponds with the formal list. */
actual = NULL;
- for (f = formal; f; f = f->next)
+ FOR_EACH_VEC_ELT (dummy_args, idx, f)
{
- a = f->actual;
+ a = ordered_actual_args[idx];
if (a && a->label != NULL && f->ts.type)
{
gfc_error ("ALTERNATE RETURN not permitted at %L", where);
@@ -4424,6 +4443,8 @@ do_sort:
a->missing_arg_type = f->ts.type;
}
+ a->associated_dummy = get_intrinsic_dummy_arg (f);
+
if (actual == NULL)
*ap = a;
else