[Patch, fortran] PR38665 - [4.4 Regression] ICE in check_host_association

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

Dear All,

Another one of these pesky regressions!  The bug and the patch are
self-explanatory.  Please note the TODO in resolve.c.

Bootstrapped and regtested on FC9/x86_i64 - OK for trunk and for 4.3 in a week?

Paul

2009-01-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/38665
	* gfortran.h : Add bit to gfc_expr 'user_operator'
	* interface.c (gfc_extend_expr): Set the above if the operator
	is substituted by a function.
	* resolve.c (check_host_association): Return if above is set.

2009-01-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/38665
	* gfortran.dg/host_assoc_function_5.f90: New test.

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 143055)
+++ gcc/fortran/interface.c	(working copy)
@@ -2670,6 +2670,7 @@
   e->value.function.esym = NULL;
   e->value.function.isym = NULL;
   e->value.function.name = NULL;
+  e->user_operator = 1;
 
   if (gfc_pure (NULL) && !gfc_pure (sym))
     {
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 143055)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -1553,6 +1553,10 @@
   /* Sometimes, when an error has been emitted, it is necessary to prevent
       it from recurring.  */
   unsigned int error : 1;
+  
+  /* Mark and expression where a user operator has been substituted by
+     a function call in interface.c(gfc_extend_expr).  */
+  unsigned int user_operator : 1;
 
   /* Used to quickly find a given constructor by its offset.  */
   splay_tree con_by_offset;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 143055)
+++ gcc/fortran/resolve.c	(working copy)
@@ -4300,7 +4300,12 @@
   int n;
   bool retval = e->expr_type == EXPR_FUNCTION;
 
-  if (e->symtree == NULL || e->symtree->n.sym == NULL)
+  /*  If the expression is the result of substitution in
+      interface.c(gfc_extend_expr) because there is no way in
+      which the host association can be wrong.  */
+  if (e->symtree == NULL
+	|| e->symtree->n.sym == NULL
+	|| e->user_operator)
     return retval;
 
   old_sym = e->symtree->n.sym;
@@ -4336,6 +4341,11 @@
 	      gfc_free (e->shape);
 	    }
 
+/* TODO - Replace this gfc_match_rvalue with a straight replacement of
+   actual arglists for function to function substitutions and with a
+   conversion of the reference list to an actual arglist in the case of
+   a variable to function replacement.  This should be quite easy since
+   only integers and vectors can be involved.  */	    
 	  gfc_match_rvalue (&expr);
 	  gfc_clear_error ();
 	  gfc_buffer_error (0);
Index: gcc/testsuite/gfortran.dg/host_assoc_function_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/host_assoc_function_5.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/host_assoc_function_5.f90	(revision 0)
@@ -0,0 +1,47 @@
+! { dg-do compile }
+!
+! PR fortran/38665, in which checking for host association
+! was wrongly trying to substitute mod_symmon(mult) with
+! mod_sympoly(mult) in the user operator expression on line
+! 43.
+!
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+module mod_symmon
+ implicit none
+
+ public :: t_symmon, operator(*)
+ private
+
+ type t_symmon
+   integer :: ierr = 0
+ end type t_symmon
+
+ interface operator(*)
+   module procedure mult
+ end interface
+
+contains
+ elemental function mult(m1,m2) result(m)
+  type(t_symmon), intent(in) :: m1, m2
+  type(t_symmon) :: m
+ end function mult
+end module mod_symmon
+
+module mod_sympoly
+ use mod_symmon
+ implicit none
+
+ type t_sympol
+   type(t_symmon), allocatable :: mons(:)
+ end type t_sympol
+contains
+
+ elemental function mult(p1,p2) result(p)
+  type(t_sympol), intent(in) :: p1,p2
+  type(t_sympol) :: p
+  type(t_symmon), allocatable :: mons(:)
+  mons(1) = p1%mons(1)*p2%mons(2)
+ end function
+end module
+! { dg-final { cleanup-modules "mod_symmon mod_sympoly" } }