re PR fortran/41777 (Wrong-code with POINTER-returning GENERIC function)

2009-10-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41777
        * trans-expr.c
        * (gfc_conv_procedure_call,gfc_conv_expr_reference):
        Use for generic EXPR_FUNCTION the attributes of the specific
        function.

2009-10-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41777
        gfortran.dg/associated_target_3.f90: New testcase.

From-SVN: r153706

gcc/fortran/ChangeLog

+2009-10-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41777
+	* trans-expr.c (gfc_conv_procedure_call,gfc_conv_expr_reference):
+	Use for generic EXPR_FUNCTION the attributes of the specific
+	function.
+
 2009-10-29  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	PR fortran/41860

gcc/fortran/check.c

@@ -599,10 +599,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
 
   where = &pointer->where;
 
-  if (pointer->expr_type == EXPR_VARIABLE)
-    attr1 = gfc_variable_attr (pointer, NULL);
-  else if (pointer->expr_type == EXPR_FUNCTION)
-    attr1 = pointer->symtree->n.sym->attr;
+  if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
+    attr1 = gfc_expr_attr (pointer);
   else if (pointer->expr_type == EXPR_NULL)
     goto null_arg;
   else
@@ -624,10 +622,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   if (target->expr_type == EXPR_NULL)
     goto null_arg;
 
-  if (target->expr_type == EXPR_VARIABLE)
-    attr2 = gfc_variable_attr (target, NULL);
-  else if (target->expr_type == EXPR_FUNCTION)
-    attr2 = target->symtree->n.sym->attr;
+  if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
+    attr2 = gfc_expr_attr (target);
   else
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "

gcc/fortran/trans-expr.c

@@ -2870,8 +2870,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		   through arg->name.  */
 		conv_arglist_function (&parmse, arg->expr, arg->name);
 	      else if ((e->expr_type == EXPR_FUNCTION)
-			  && e->symtree->n.sym->attr.pointer
-			  && fsym && fsym->attr.target)
+			&& ((e->value.function.esym
+			     && e->value.function.esym->result->attr.pointer)
+			    || (!e->value.function.esym
+				&& e->symtree->n.sym->attr.pointer))
+			&& fsym && fsym->attr.target)
 		{
 		  gfc_conv_expr (&parmse, e);
 		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
@@ -4368,8 +4371,12 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
     }
 
   if (expr->expr_type == EXPR_FUNCTION
-	&& expr->symtree->n.sym->attr.pointer
-	&& !expr->symtree->n.sym->attr.dimension)
+      && ((expr->value.function.esym
+	   && expr->value.function.esym->result->attr.pointer
+	   && !expr->value.function.esym->result->attr.dimension)
+	  || (!expr->value.function.esym
+	      && expr->symtree->n.sym->attr.pointer
+	      && !expr->symtree->n.sym->attr.dimension)))
     {
       se->want_pointer = 1;
       gfc_conv_expr (se, expr);

gcc/testsuite/ChangeLog

+2009-10-29  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41777
+	gfortran.dg/associated_target_3.f90: New testcase.
+
 2009-10-29  Rafael Avila de Espindola  <espindola@google.com>
 
 	* gfortran.dg/lto/pr41764_0.f: New.

gcc/testsuite/gfortran.dg/associated_target_3.f90

+! { dg-do run }
+!
+! PR fortran/41777
+!
+module m
+type t2
+ integer :: i
+end type t2
+interface f
+ module procedure f2
+end interface f
+contains
+function f2(a)
+  type(t2), pointer :: f2,a
+  f2 => a
+end function f2
+end module m
+
+use m
+implicit none
+type(t2), pointer :: a
+allocate(a)
+if (.not. associated(a,f(a))) call abort()
+call cmpPtr(a,f2(a))
+call cmpPtr(a,f(a))
+deallocate(a)
+contains
+  subroutine cmpPtr(a,b)
+    type(t2), pointer :: a,b
+!    print *, associated(a,b)
+    if (.not. associated (a, b)) call abort()
+  end subroutine cmpPtr
+end
+
+! { dg-final { cleanup-modules "m" } }