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
+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
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. */
}
-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)
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;
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");
}
/* 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)
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);
+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.
--- /dev/null
+! { 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" } }