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.



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

1 files changed, 26 insertions, 10 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 3205bebccab..6de83ee9dc2 100644
--- a/gcc/fortran/iresolve.c
+++ b/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,13 +154,20 @@ 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)
 {
   f->ts = x->ts;
@@ -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)