re PR fortran/31608 (wrong types in character array/scalar binop)

2007-10-20  Paul Thomas  <pault@gcc.gnu.org>
	    FX Coudert <fxcoudert@gcc.gnu.org>

	PR fortran/31608
	* trans-array.c (gfc_conv_expr_descriptor): For all except
	indirect references, use gfc_trans_scalar_assign instead of
	gfc_add_modify_expr.
	* iresolve.c (check_charlen_present): Separate creation of cl
	if necessary and add code to treat an EXPR_ARRAY.
	(gfc_resolve_char_achar): New function.
	(gfc_resolve_achar, gfc_resolve_char): Call it.
	(gfc_resolve_transfer): If the MOLD expression does not have a
	character length expression, get it from a constant length.

2007-10-20  Paul Thomas  <pault@gcc.gnu.org>
	    FX Coudert <fxcoudert@gcc.gnu.org>

	PR fortran/31608
	* gfortran.dg/char_cast_1.f90: New test.


Co-Authored-By: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

From-SVN: r129505

gcc/fortran/ChangeLog

@@ -1,3 +1,17 @@
+2007-10-20  Paul Thomas  <pault@gcc.gnu.org>
+	    FX Coudert <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31608
+	* trans-array.c (gfc_conv_expr_descriptor): For all except
+	indirect references, use gfc_trans_scalar_assign instead of
+	gfc_add_modify_expr.
+	* iresolve.c (check_charlen_present): Separate creation of cl
+	if necessary and add code to treat an EXPR_ARRAY.
+	(gfc_resolve_char_achar): New function.
+	(gfc_resolve_achar, gfc_resolve_char): Call it.
+	(gfc_resolve_transfer): If the MOLD expression does not have a
+	character length expression, get it from a constant length.
+
 2007-10-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/33544

gcc/fortran/iresolve.c

@@ -62,14 +62,24 @@ gfc_get_string (const char *format, ...)
 static void
 check_charlen_present (gfc_expr *source)
 {
-  if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
+  if (source->ts.cl == NULL)
     {
       source->ts.cl = gfc_get_charlen ();
       source->ts.cl->next = gfc_current_ns->cl_list;
       gfc_current_ns->cl_list = source->ts.cl;
+    }
+
+  if (source->expr_type == EXPR_CONSTANT)
+    {
       source->ts.cl->length = gfc_int_expr (source->value.character.length);
       source->rank = 0;
     }
+  else if (source->expr_type == EXPR_ARRAY)
+    {
+      source->ts.cl->length =
+	gfc_int_expr (source->value.constructor->expr->value.character.length);
+      source->rank = 1;
+    }
 }
 
 /* Helper function for resolving the "mask" argument.  */
@@ -132,8 +142,9 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 }
 
 
-void
-gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+static void
+gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
+			const char *name)
 {
   f->ts.type = BT_CHARACTER;
   f->ts.kind = (kind == NULL)
@@ -143,12 +154,19 @@ gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
   gfc_current_ns->cl_list = f->ts.cl;
   f->ts.cl->length = gfc_int_expr (1);
 
-  f->value.function.name = gfc_get_string ("__achar_%d_%c%d", f->ts.kind,
+  f->value.function.name = gfc_get_string (name, f->ts.kind,
 					   gfc_type_letter (x->ts.type),
 					   x->ts.kind);
 }
 
 
+void
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+{
+  gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
+}
+
+
 void
 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
 {
@@ -379,12 +397,7 @@ gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 void
 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
-  f->ts.type = BT_CHARACTER;
-  f->ts.kind = (kind == NULL)
-	     ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
-  f->value.function.name
-    = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
-		      gfc_type_letter (a->ts.type), a->ts.kind);
+  gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
 }
 
 
@@ -2270,6 +2283,9 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
   /* TODO: Make this do something meaningful.  */
   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
 
+  if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length)
+    mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
+
   f->ts = mold->ts;
 
   if (size == NULL && mold->rank == 0)

gcc/fortran/trans-array.c

@@ -4727,7 +4727,15 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       gfc_add_block_to_block (&block, &rse.pre);
       gfc_add_block_to_block (&block, &lse.pre);
 
-      gfc_add_modify_expr (&block, lse.expr, rse.expr);
+      if (TREE_CODE (rse.expr) != INDIRECT_REF)
+	{
+	  lse.string_length = rse.string_length;
+	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
+				  expr->expr_type == EXPR_VARIABLE);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      else
+	gfc_add_modify_expr (&block, lse.expr, rse.expr);
 
       /* Finish the copying loops.  */
       gfc_trans_scalarizing_loops (&loop, &block);

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2007-10-20  Paul Thomas  <pault@gcc.gnu.org>
+	    FX Coudert <fxcoudert@gcc.gnu.org>
+
+	PR fortran/31608
+	* gfortran.dg/char_cast_1.f90: New test.
+
 2007-10-19  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* gfortran.dg/default_format_denormal_2.f90: xfail on FreeBSD.

gcc/testsuite/gfortran.dg/char_cast_1.f90

@@ -0,0 +1,31 @@
+! { dg-do compile }
+! { dg-options "-O2 -fdump-tree-original" }
+!
+! Check the fix for PR31608 in all it's various manifestations:)
+! Contributed by Richard Guenther <rguenth@gcc.gnu.org>
+!
+  character(len=1) :: string = "z"
+  integer :: i(1) = (/100/)
+  print *, Up("abc")
+  print *, transfer(((transfer(string,"x",1))), "x",1)
+  print *, transfer(char(i), "x")
+  print *, Upper ("abcdefg")
+ contains
+  Character (len=20) Function Up (string)
+    Character(len=*) string
+    character(1) :: chr
+    Up = transfer(achar(iachar(transfer(string,chr,1))), "x")
+    return
+  end function Up
+  Character (len=20) Function Upper (string)
+    Character(len=*) string
+    Upper =                                                                &
+     transfer(merge(transfer(string,"x",len(string)),    &
+       string, .true.), "x")
+    return
+  end function Upper
+end
+! The sign that all is well is that [S.5][1] appears twice.
+! { dg-final { scan-tree-dump-times "\\\[S\.5\\\]\\\[1\\\]" 2 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+! { dg-final { cleanup-tree-dump "original" } }