re PR fortran/31215 (ICE on valid code with gfortran)

2007-03-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31215
	* trans-expr.c (gfc_apply_interface_mapping_to_expr): Return
	int result that is non-zero if the expression is the function
	result.  Only the characteristics of the result expression
	can be used in a procedure interface, so simplify LEN in situ
	using its character length.

	PR fortran/31219
	PR fortran/31200
	* trans-expr.c (gfc_conv_function_call): Do not use
	gfc_conv_expr_reference for actual pointer function with formal
	target because a temporary is created that does not transfer
	the reference correctly.  Do not indirect formal pointer
	functions since it is the function reference that is needed.

2007-03-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31219
	* gfortran.dg/pointer_function_actual_1.f90: New test.

	PR fortran/31200
	* gfortran.dg/pointer_function_actual_2.f90: New test.

	PR fortran/31215
	* gfortran.dg/result_in_spec_1.f90: New test.

From-SVN: r123183

gcc/fortran/ChangeLog

@@ -1,3 +1,20 @@
+2007-03-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31215
+	* trans-expr.c (gfc_apply_interface_mapping_to_expr): Return
+	int result that is non-zero if the expression is the function
+	result.  Only the characteristics of the result expression
+	can be used in a procedure interface, so simplify LEN in situ
+	using its character length.
+
+	PR fortran/31219
+	PR fortran/31200
+	* trans-expr.c (gfc_conv_function_call): Do not use
+	gfc_conv_expr_reference for actual pointer function with formal
+	target because a temporary is created that does not transfer
+	the reference correctly.  Do not indirect formal pointer
+	functions since it is the function reference that is needed.
+
 2007-03-24  Brooks Moses  <brooks.moses@codesourcery.com>
 
 	* gfortran.h: Edit comments on GFC_STD_*.

gcc/fortran/trans-expr.c

@@ -43,7 +43,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "dependency.h"
 
 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
-static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
 						 gfc_expr *);
 
 /* Copy the scalarization loop variables.  */
@@ -1601,15 +1601,16 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
    dummy arguments that MAPPING maps to actual arguments.  Replace each such
    reference with a reference to the associated actual argument.  */
 
-static void
+static int
 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
 				     gfc_expr * expr)
 {
   gfc_interface_sym_mapping *sym;
   gfc_actual_arglist *actual;
+  int seen_result = 0;
 
   if (!expr)
-    return;
+    return 0;
 
   /* Copying an expression does not copy its length, so do that here.  */
   if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
@@ -1631,6 +1632,8 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
   switch (expr->expr_type)
     {
     case EXPR_VARIABLE:
+      if (expr->symtree->n.sym->attr.result)
+	seen_result = 1;
     case EXPR_CONSTANT:
     case EXPR_NULL:
     case EXPR_SUBSTRING:
@@ -1642,6 +1645,21 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
       break;
 
     case EXPR_FUNCTION:
+      if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
+	    && gfc_apply_interface_mapping_to_expr (mapping,
+			expr->value.function.actual->expr)
+	    && expr->value.function.esym == NULL
+	    && expr->value.function.isym != NULL
+	    && expr->value.function.isym->generic_id == GFC_ISYM_LEN)
+	{
+	  gfc_expr *new_expr;
+	  new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
+	  *expr = *new_expr;
+	  gfc_free (new_expr);
+	  gfc_apply_interface_mapping_to_expr (mapping, expr);
+	  break;
+	}
+
       for (sym = mapping->syms; sym; sym = sym->next)
 	if (sym->old == expr->value.function.esym)
 	  expr->value.function.esym = sym->new->n.sym;
@@ -1655,6 +1673,7 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
       gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
       break;
     }
+  return seen_result;
 }
 
 
@@ -2087,11 +2106,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		/* Argument list functions %VAL, %LOC and %REF are signalled
 		   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)
+		{
+		  gfc_conv_expr (&parmse, e);
+		  parmse.expr = build_fold_addr_expr (parmse.expr);
+		}
 	      else
 		{
 		  gfc_conv_expr_reference (&parmse, e);
 		  if (fsym && fsym->attr.pointer
-			&& e->expr_type != EXPR_NULL)
+		      && fsym->attr.flavor != FL_PROCEDURE
+		      && e->expr_type != EXPR_NULL)
 		    {
 		      /* Scalar pointer dummy args require an extra level of
 			 indirection. The null pointer already contains

gcc/testsuite/ChangeLog

@@ -1,3 +1,14 @@
+2007-03-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/31219
+	* gfortran.dg/pointer_function_actual_1.f90: New test.
+
+	PR fortran/31200
+	* gfortran.dg/pointer_function_actual_2.f90: New test.
+
+	PR fortran/31215
+	* gfortran.dg/result_in_spec_1.f90: New test.
+
 2007-03-23  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	PR fortran/30834

gcc/testsuite/gfortran.dg/pointer_function_actual_1.f90

@@ -0,0 +1,51 @@
+! { dg-do run }
+! Tests the fix for PR31219, in which an ICE would result because
+! the reference to the pointer function f would be indirected, as
+! if it were the result that is being passed.
+!
+! COntributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+FUNCTION F() RESULT(RES)
+ INTEGER, POINTER :: RES
+ ALLOCATE(RES)
+ RES=2
+END FUNCTION F
+
+SUBROUTINE S1(f,*,*)
+ INTERFACE
+  FUNCTION F() RESULT(RES)
+   INTEGER, POINTER :: RES
+  END FUNCTION F
+ END INTERFACE
+ RETURN F()
+END SUBROUTINE
+
+PROGRAM TEST
+   INTERFACE
+    FUNCTION F() RESULT(RES)
+     INTEGER, POINTER :: RES
+    END FUNCTION F
+   END INTERFACE
+
+
+   INTERFACE
+    SUBROUTINE S1(f,*,*)
+      INTERFACE
+       FUNCTION F() RESULT(RES)
+        INTEGER, POINTER :: RES
+       END FUNCTION F
+      END INTERFACE
+     END SUBROUTINE
+   END INTERFACE
+
+   CALL S1(F,*1,*2)
+
+   1 CONTINUE
+   CALL ABORT()
+
+   GOTO 3
+   2 CONTINUE
+
+   3 CONTINUE
+END
+

gcc/testsuite/gfortran.dg/pointer_function_actual_2.f90

@@ -0,0 +1,22 @@
+! { dg-do run }
+! Tests the fix for PR31200, in which the target x would
+! not be associated with p
+!
+! COntributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+  REAL,TARGET :: x
+  CALL s3(f(x))
+CONTAINS
+  FUNCTION f(a)
+    REAL,POINTER :: f
+    REAL,TARGET :: a
+    f => a
+  END FUNCTION
+  SUBROUTINE s3(targ)
+    REAL,TARGET :: targ
+    REAL,POINTER :: p
+    p => targ
+    IF (.NOT. ASSOCIATED(p,x)) CALL ABORT()
+  END SUBROUTINE
+END
+

gcc/testsuite/gfortran.dg/result_in_spec_1.f90

@@ -0,0 +1,52 @@
+! { dg-do run }
+! Tests the check for PR31215, in which actual/formal interface 
+! was not being correctly handled for the size of 'r' because
+! it is a result.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+module test1
+  implicit none
+contains
+  character(f(x)) function test2(x) result(r)
+    implicit integer (x)
+    dimension r(len(r)+1)
+    integer, intent(in) :: x
+    interface
+      pure function f(x)
+        integer, intent(in) :: x
+        integer f
+      end function f
+    end interface
+    integer i
+    do i = 1, len(r)
+      r(:)(i:i) = achar(mod(i,32)+iachar('@'))
+    end do
+  end function test2
+end module test1
+
+program test
+  use test1
+  implicit none
+! Original problem
+  if (len(test2(10)) .ne. 21) call abort ()
+! Check non-intrinsic calls are OK and check that fix does
+! not confuse result variables.
+  if (any (myfunc (test2(1)) .ne. "ABC")) call abort ()
+contains
+  function myfunc (ch) result (chr)
+    character(len(ch)) :: chr(2)
+    character (*) :: ch(:)
+    if (len (ch) .ne. 3) call abort ()
+    if (any (ch .ne. "ABC")) call abort ()
+    chr = test2 (1)
+    if (len(test2(len(chr))) .ne. 7) call abort ()
+  end function myfunc
+end program test
+
+pure function f(x)
+  integer, intent(in) :: x
+  integer f
+  f = 2*x+1
+end function f
+! { dg-final { cleanup-modules "test1" } }