[gcc r12-5315] fortran: Reverse actual vs dummy argument mapping

[gcc r12-5315] fortran: Reverse actual vs dummy argument mapping

[Mikael Morin]

https://gcc.gnu.org/g:5888512f24121032a438e3aaf10dc93550dc2819

commit r12-5315-g5888512f24121032a438e3aaf10dc93550dc2819
Author: Mikael Morin <mikael@gcc.gnu.org>
Date:   Sun Nov 7 14:39:59 2021 +0100

    fortran: Reverse actual vs dummy argument mapping
    
    There was originally no way from an actual argument to get
    to the corresponding dummy argument, even if the job of sorting
    and matching actual with dummy arguments was done.
    The closest was a field named actual in gfc_intrinsic_arg that was
    used as scratch data when sorting arguments of one specific call.
    However that value was overwritten later on as arguments of another
    call to the same procedure were sorted and matched.
    
    This change removes that field from gfc_intrinsic_arg and adds instead
    a new field associated_dummy in gfc_actual_arglist.
    
    The new field has as type a new wrapper struct gfc_dummy_arg that provides
    a common interface to both dummy arguments of user-defined procedures
    (which have type gfc_formal_arglist) and dummy arguments of intrinsic procedures
    (which have type gfc_intrinsic_arg).
    
    As the removed field was used in the code sorting and matching arguments,
    that code has to be updated.  Two local vectors with matching indices
    are introduced for respectively dummy and actual arguments, and the
    loops are modified to use indices and update those argument vectors.
    
    gcc/fortran/ChangeLog:
            * gfortran.h (gfc_dummy_arg_kind, gfc_dummy_arg): New.
            (gfc_actual_arglist): New field associated_dummy.
            (gfc_intrinsic_arg): Remove field actual.
            * interface.c (get_nonintrinsic_dummy_arg): New.
            (gfc_compare_actual): Initialize associated_dummy.
            * intrinsic.c (get_intrinsic_dummy_arg): New.
            (sort_actual):  Add argument vectors.
            Use loops with indices on argument vectors.
            Initialize associated_dummy.

Diff:
---
 gcc/fortran/gfortran.h  | 31 +++++++++++++++++++++++++++++--
 gcc/fortran/interface.c | 21 +++++++++++++++++++--
 gcc/fortran/intrinsic.c | 43 ++++++++++++++++++++++++++++++++-----------
 3 files changed, 80 insertions(+), 15 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 1ad2f0df702..86c096a9da7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1199,6 +1199,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
@@ -1215,6 +1218,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;
@@ -2299,14 +2307,33 @@ 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;
-
 }
 gfc_intrinsic_arg;
 
 
+typedef enum {
+  GFC_UNDEFINED_DUMMY_ARG = 0,
+  GFC_INTRINSIC_DUMMY_ARG,
+  GFC_NON_INTRINSIC_DUMMY_ARG
+}
+gfc_dummy_arg_intrinsicness;
+
+/* dummy arg of either an intrinsic or a user-defined procedure.  */
+struct gfc_dummy_arg
+{
+  gfc_dummy_arg_intrinsicness intrinsicness;
+
+  union {
+    gfc_intrinsic_arg *intrinsic;
+    gfc_formal_arglist *non_intrinsic;
+  } 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
    to check functions of intrinsics with X arguments. f1m is used for
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 30c99ef3938..2c9d371ba2d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3043,6 +3043,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->intrinsicness = 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
@@ -3151,6 +3163,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)
 	{
@@ -3680,9 +3694,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)
     {
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 33b827673e7..cb07326ef62 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4237,6 +4237,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->intrinsicness = 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
@@ -4254,8 +4266,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;
@@ -4307,7 +4325,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;
@@ -4317,7 +4335,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;
@@ -4335,7 +4353,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;
 
@@ -4350,21 +4369,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);
@@ -4377,9 +4396,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);
@@ -4392,6 +4411,8 @@ do_sort:
 	  a->missing_arg_type = f->ts.type;
 	}
 
+      a->associated_dummy = get_intrinsic_dummy_arg (f);
+
       if (actual == NULL)
 	*ap = a;
       else