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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@116839 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 159b4d1..b89e0c7 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b62a041..c9475cc 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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.  */

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 37bf782..dc5ac27 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 55c511e..d0f76e0 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90
new file mode 100644 (file)
index 0000000..f8efc0a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_charlen_function_5.f90
@@ -0,0 +1,39 @@
+! { 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