[Patch, fortran] PR50981 (elemental/optional interaction) follow-up fix

[Mikael Morin <mikael dot morin at sfr dot fr>]

Hello,

this fixes the fairly recent PR50981 patch
[http://gcc.gnu.org/ml/fortran/2011-12/msg00170.html] which didn't work 
for subroutine calls, as they use code->resolved_sym instead of 
code->expr1 to store the procedure symbol.


The first patch moves gfc_walk_elemental_function_args's code to get the 
procedure interface into a new procedure.

The second patch moves the procedure call out of 
gfc_walk_elemental_function_args.

The third patch changes the function called in gfc_trans_call so that 
code->resolved_sym is used if code->expr1 fails to give the interface.
I choose to try code->expr1 first for fear that in typebound calls, 
code->resolved_sym may point to the base object, which is obviously not 
the procedure interface.

The testcase is Tobias' comment #13
[http://gcc.gnu.org/bugzilla/show_bug.cgi?id=50981#c13] stripped down to 
the working part.

Regression tested on x86_64-unknown-freebsd9.0. OK for trunk?

Mikael

Attachment: call_interface-1.CL
Description: Text document

diff --git a/trans-array.c b/trans-array.c
index d3c81a8..2584e78 100644
--- a/trans-array.c
+++ b/trans-array.c
@@ -8427,6 +8427,36 @@ gfc_reverse_ss (gfc_ss * ss)
 }
 
 
+/* Given an expression refering to a procedure, return the symbol of its
+   interface.  We can't get the procedure symbol directly as we have to handle
+   the case of (deferred) type-bound procedures.  */
+
+gfc_symbol *
+gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
+{
+  gfc_symbol *sym;
+  gfc_ref *ref;
+
+  if (procedure_ref == NULL)
+    return NULL;
+
+  /* Normal procedure case.  */
+  sym = procedure_ref->symtree->n.sym;
+
+  /* Typebound procedure case.  */
+  for (ref = procedure_ref->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	  && ref->u.c.component->attr.proc_pointer)
+	sym = ref->u.c.component->ts.interface;
+      else
+	sym = NULL;
+    }
+
+  return sym;
+}
+
+
 /* 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.
@@ -8436,6 +8466,7 @@ gfc_ss *
 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
 				  gfc_expr *proc_expr, gfc_ss_type type)
 {
+  gfc_symbol *proc_ifc;
   gfc_formal_arglist *dummy_arg;
   int scalar;
   gfc_ss *head;
@@ -8445,24 +8476,9 @@ 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;
-	}
-    }
+  proc_ifc = gfc_get_proc_ifc_for_expr (proc_expr);
+  if (proc_ifc)
+    dummy_arg = proc_ifc->formal;
   else
     dummy_arg = NULL;

Attachment: call_interface-2.CL
Description: Text document

diff --git a/trans-array.c b/trans-array.c
index 2584e78..de6fa13 100644
--- a/trans-array.c
+++ b/trans-array.c
@@ -8464,9 +8464,8 @@ 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_expr *proc_expr, gfc_ss_type type)
+				  gfc_symbol *proc_ifc, gfc_ss_type type)
 {
-  gfc_symbol *proc_ifc;
   gfc_formal_arglist *dummy_arg;
   int scalar;
   gfc_ss *head;
@@ -8476,7 +8475,6 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
   head = gfc_ss_terminator;
   tail = NULL;
 
-  proc_ifc = gfc_get_proc_ifc_for_expr (proc_expr);
   if (proc_ifc)
     dummy_arg = proc_ifc->formal;
   else
@@ -8566,7 +8564,8 @@ 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,
-					     expr, GFC_SS_REFERENCE);
+					     gfc_get_proc_ifc_for_expr (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.  */
diff --git a/trans-array.h b/trans-array.h
index 6ca630e..9bafb94 100644
--- a/trans-array.h
+++ b/trans-array.h
@@ -66,6 +66,8 @@ void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
 /* Generate an initializer for a static pointer or allocatable array.  */
 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 *);
 /* Generate scalarization information for an expression.  */
 gfc_ss *gfc_walk_expr (gfc_expr *);
 /* Workhorse for gfc_walk_expr.  */
@@ -74,7 +76,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_expr *, gfc_ss_type);
+					  gfc_symbol *, gfc_ss_type);
 /* Walk an intrinsic function.  */
 gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
 				     gfc_intrinsic_sym *);
diff --git a/trans-stmt.c b/trans-stmt.c
index 7a6f8b2..ddbf35e 100644
--- a/trans-stmt.c
+++ b/trans-stmt.c
@@ -372,7 +372,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,
-					   code->expr1, GFC_SS_REFERENCE);
+					   gfc_get_proc_ifc_for_expr (code->expr1),
+					   GFC_SS_REFERENCE);
 
   /* Is not an elemental subroutine call with array valued arguments.  */
   if (ss == gfc_ss_terminator)

Attachment: call_interface-3.CL
Description: Text document

diff --git a/trans-stmt.c b/trans-stmt.c
index ddbf35e..9b116d3 100644
--- a/trans-stmt.c
+++ b/trans-stmt.c
@@ -348,6 +348,27 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 }
 
 
+/* 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
@@ -372,7 +393,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,
-					   gfc_get_proc_ifc_for_expr (code->expr1),
+					   get_proc_ifc_for_call (code),
 					   GFC_SS_REFERENCE);
 
   /* Is not an elemental subroutine call with array valued arguments.  */

Attachment: call_interface-test.CL
Description: Text document

Attachment: elemental_optional_args_5.f90
Description: Text document