re PR fortran/36703 (ICE (segfault) in reduce_binary0 (arith.c:1778))

2009-02-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/36703
	PR fortran/36528
	* trans-expr.c (gfc_conv_function_val): Stabilize Cray-pointer
	function references to ensure that a valid expression is used.
	(gfc_conv_function_call): Pass Cray pointers to procedures.

2009-02-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/36528
	* gfortran.dg/cray_pointers_8.f90: New test.

	PR fortran/36703
	* gfortran.dg/cray_pointers_9.f90: New test.

From-SVN: r145196

4 files changed, 145 insertions, 29 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 633775f..47ebdce 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,11 @@
 2009-03-28  Paul Thomas  <pault@gcc.gnu.org>
 
+        PR fortran/38538
+        * trans-array.c (get_elemental_fcn_charlen): Remove.
+	(get_array_charlen): New function to replace previous.
+
+2009-03-28  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/38765
 	* parse.c (parse_derived): Do not break on finding pointer,
 	allocatable or private components.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 56b4a68..e7b5232 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4703,47 +4703,102 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
 }
 
 
-/* gfc_conv_expr_descriptor needs the character length of elemental
-   functions before the function is called so that the size of the
-   temporary can be obtained.  The only way to do this is to convert
-   the expression, mapping onto the actual arguments.  */
+/* gfc_conv_expr_descriptor needs the string length an expression
+   so that the size of the temporary can be obtained.  This is done
+   by adding up the string lengths of all the elements in the
+   expression.  Function with non-constant expressions have their
+   string lengths mapped onto the actual arguments using the
+   interface mapping machinery in trans-expr.c.  */
 static void
-get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
+get_array_charlen (gfc_expr *expr, gfc_se *se)
 {
   gfc_interface_mapping mapping;
   gfc_formal_arglist *formal;
   gfc_actual_arglist *arg;
   gfc_se tse;
 
-  formal = expr->symtree->n.sym->formal;
-  arg = expr->value.function.actual;
-  gfc_init_interface_mapping (&mapping);
-
-  /* Set se = NULL in the calls to the interface mapping, to suppress any
-     backend stuff.  */
-  for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+  if (expr->ts.cl->length
+	&& gfc_is_constant_expr (expr->ts.cl->length))
     {
-      if (!arg->expr)
-	continue;
-      if (formal->sym)
-	gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+      if (!expr->ts.cl->backend_decl)
+	gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+      return;
     }
 
-  gfc_init_se (&tse, NULL);
+  switch (expr->expr_type)
+    {
+    case EXPR_OP:
+      get_array_charlen (expr->value.op.op1, se);
+
+      /* For parentheses the expression ts.cl is identical.  */
+      if (expr->value.op.op == INTRINSIC_PARENTHESES)
+	return;
+
+     expr->ts.cl->backend_decl =
+		gfc_create_var (gfc_charlen_type_node, "sln");
+
+      if (expr->value.op.op2)
+	{
+	  get_array_charlen (expr->value.op.op2, se);
+
+	  /* Add the string lengths and assign them to the expression
+	     string length backend declaration.  */
+	  gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
+			  fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
+				expr->value.op.op1->ts.cl->backend_decl,
+				expr->value.op.op2->ts.cl->backend_decl));
+	}
+      else
+	gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
+			expr->value.op.op1->ts.cl->backend_decl);
+      break;
+
+    case EXPR_FUNCTION:
+      if (expr->value.function.esym == NULL
+	    || expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+	{
+	  gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+	  break;
+	}
+
+      /* Map expressions involving the dummy arguments onto the actual
+	 argument expressions.  */
+      gfc_init_interface_mapping (&mapping);
+      formal = expr->symtree->n.sym->formal;
+      arg = expr->value.function.actual;
+
+      /* Set se = NULL in the calls to the interface mapping, to suppress any
+	 backend stuff.  */
+      for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+	{
+	  if (!arg->expr)
+	    continue;
+	  if (formal->sym)
+	  gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+	}
 
-  /* Build the expression for the character length and convert it.  */
-  gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+      gfc_init_se (&tse, NULL);
 
-  gfc_add_block_to_block (&se->pre, &tse.pre);
-  gfc_add_block_to_block (&se->post, &tse.post);
-  tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
-  tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
-			  build_int_cst (gfc_charlen_type_node, 0));
-  expr->ts.cl->backend_decl = tse.expr;
-  gfc_free_interface_mapping (&mapping);
+      /* Build the expression for the character length and convert it.  */
+      gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+
+      gfc_add_block_to_block (&se->pre, &tse.pre);
+      gfc_add_block_to_block (&se->post, &tse.post);
+      tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
+      tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
+			      build_int_cst (gfc_charlen_type_node, 0));
+      expr->ts.cl->backend_decl = tse.expr;
+      gfc_free_interface_mapping (&mapping);
+      break;
+
+    default:
+      gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+      break;
+    }
 }
 
 
+
 /* Convert an array for passing as an actual argument.  Expressions and
    vector subscripts are evaluated and stored in a temporary, which is then
    passed.  For whole arrays the descriptor is passed.  For array sections
@@ -4879,7 +4934,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  need_tmp = 1;
 	  if (expr->ts.type == BT_CHARACTER
 		&& expr->ts.cl->length->expr_type != EXPR_CONSTANT)
-	    get_elemental_fcn_charlen (expr, se);
+	    get_array_charlen (expr, se);
 
 	  info = NULL;
 	}
@@ -4939,8 +4994,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       loop.temp_ss->type = GFC_SS_TEMP;
       loop.temp_ss->next = gfc_ss_terminator;
 
-      if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
-	gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+      if (expr->ts.type == BT_CHARACTER
+	    && !expr->ts.cl->backend_decl)
+	get_array_charlen (expr, se);
 
       loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c5018d7..961d0d6 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-03-28  Paul Thomas  <pault@gcc.gnu.org
+
+        PR fortran/38538
+        * gfortran.dg/char_result_13.f90: New test.
+
 2009-03-28  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/38765
diff --git a/gcc/testsuite/gfortran.dg/char_result_13.f90 b/gcc/testsuite/gfortran.dg/char_result_13.f90
new file mode 100644
index 0000000..741d55f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_result_13.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+! Tests the fix for PR38538, where the character length for the
+! argument of 'func' was not calculated.
+!
+! Contributed by Vivek Rao <vivekrao4@yahoo.com>
+!
+module abc
+  implicit none
+contains
+  subroutine xmain (i, j)
+    integer i, j
+    call foo (func ("_"//bar (i)//"x"//bar (j)//"x"), "_abcxabx")  ! original was elemental
+    call foo (nfunc("_"//bar (j)//"x"//bar (i)//"x"), "_abxabcx")
+  end subroutine xmain
+!
+  function bar (i) result(yy)
+    integer i, j, k
+    character (len = i) :: yy(2)
+    do j = 1, size (yy, 1)
+      do k = 1, i
+        yy(j)(k:k) = char (96+k)
+      end do
+    end do
+  end function bar
+!
+  elemental function func (yy) result(xy)
+    character (len = *), intent(in) :: yy
+    character (len = len (yy)) :: xy
+    xy = yy
+  end function func
+!
+  function nfunc (yy) result(xy)
+    character (len = *), intent(in) :: yy(:)
+    character (len = len (yy)) :: xy(size (yy))
+    xy = yy
+  end function nfunc
+!
+  subroutine foo(cc, teststr)
+    character (len=*), intent(in) :: cc(:)
+    character (len=*), intent(in) :: teststr
+    if (any (cc .ne. teststr)) call abort
+  end subroutine foo
+end module abc
+
+  use abc
+  call xmain(3, 2)
+end
+! { dg-final { cleanup-modules "abc" } }
+