re PR fortran/28890 (ICE on write)

2006-09-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/28890
	trans-expr.c (gfc_conv_function_call): Obtain the string length
	of a dummy character(*) function from the symbol if it is not
	already translated.  For a call to a character(*) function, use
	the passed, hidden string length argument, which is available
	from the backend_decl of the formal argument.
	resolve.c (resolve_function): It is an error if a function call
	to a character(*) function is other than a dummy procedure or
	an intrinsic.

2006-09-11  Paul Thomas  <pault@gcc.gnu.org>

	PR libfortran/28890
	gfortran.dg/assumed_charlen_function_5.f90: New test.

From-SVN: r116839

gcc/fortran/ChangeLog

+2006-09-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28890
+	trans-expr.c (gfc_conv_function_call): Obtain the string length
+	of a dummy character(*) function from the symbol if it is not
+	already translated.  For a call to a character(*) function, use
+	the passed, hidden string length argument, which is available
+	from the backend_decl of the formal argument.
+	resolve.c (resolve_function): It is an error if a function call
+	to a character(*) function is other than a dummy procedure or
+	an intrinsic.
+
 2006-09-10  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/28959

gcc/fortran/resolve.c

@@ -1413,6 +1413,7 @@ resolve_function (gfc_expr * expr)
 	&& sym->ts.cl
 	&& sym->ts.cl->length == NULL
 	&& !sym->attr.dummy
+	&& expr->value.function.esym == NULL
 	&& !sym->attr.contained)
     {
       /* Internal procedures are taken care of in resolve_contained_fntype.  */

gcc/fortran/trans-expr.c

@@ -2030,6 +2030,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  gfc_add_expr_to_block (&se->pre, tmp);
 	}
 
+      if (fsym && fsym->ts.type == BT_CHARACTER
+	     && parmse.string_length == NULL_TREE
+	     && e->ts.type == BT_PROCEDURE
+	     && e->symtree->n.sym->ts.type == BT_CHARACTER
+	     && e->symtree->n.sym->ts.cl->length != NULL)
+	{
+	  gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
+	  parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
+	}
+
       /* Character strings are passed as two parameters, a length and a
          pointer.  */
       if (parmse.string_length != NULL_TREE)
@@ -2046,12 +2056,22 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	{
 	  /* Assumed character length results are not allowed by 5.1.1.5 of the
 	     standard and are trapped in resolve.c; except in the case of SPREAD
-	     (and other intrinsics?).  In this case, we take the character length
-	     of the first argument for the result.  */
-	  cl.backend_decl = TREE_VALUE (stringargs);
-	}
-      else
-	{
+	     (and other intrinsics?) and dummy functions.  In the case of SPREAD,
+	     we take the character length of the first argument for the result.
+	     For dummies, we have to look through the formal argument list for
+	     this function and use the character length found there.*/
+	  if (!sym->attr.dummy)
+	    cl.backend_decl = TREE_VALUE (stringargs);
+	  else
+	    {
+	      formal = sym->ns->proc_name->formal;
+	      for (; formal; formal = formal->next)
+		if (strcmp (formal->sym->name, sym->name) == 0)
+		  cl.backend_decl = formal->sym->ts.cl->backend_decl;
+	    }
+        }
+        else
+        {
 	  /* Calculate the length of the returned string.  */
 	  gfc_init_se (&parmse, NULL);
 	  if (need_interface_mapping)

gcc/testsuite/ChangeLog

+2006-09-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR libfortran/28890
+	gfortran.dg/assumed_charlen_function_5.f90: New test.
+
 2006-09-10  Mark Mitchell  <mark@codesourcery.com>
 
 	PR c++/28991

gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90

+! { dg-do compile }
+! Tests the patch for PR28890, in which a reference to a legal reference
+! to an assumed character length function, passed as a dummy, would
+! cause an ICE.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+character(*) function charrext (n)  ! { dg-warning "is obsolescent in fortran 95" }
+  character(26) :: alpha ="abcdefghijklmnopqrstuvwxyz"
+  charrext = alpha (1:n)
+end function charrext
+
+  character(26), external :: charrext
+  interface
+    integer(4) function test(charr, i)
+     character(*), external :: charr
+     integer :: i
+    end function test
+  end interface
+
+  do j = 1 , 26
+    m = test (charrext, j)
+    m = ctest (charrext, 27 - j)
+  end do
+contains
+  integer(4) function ctest(charr, i)  ! { dg-warning "is obsolescent in fortran 95" }
+    character(*) :: charr
+    integer :: i
+    print *, charr(i)
+    ctest = 1
+  end function ctest
+end
+
+integer(4) function test(charr, i)  ! { dg-warning "is obsolescent in fortran 95" }
+  character(*) :: charr
+  integer :: i
+  print *, charr(i)
+  test = 1
+end function test
\ No newline at end of file