From: Paul Thomas Date: Sat, 20 Oct 2007 09:27:09 +0000 (+0000) Subject: re PR fortran/31608 (wrong types in character array/scalar binop) X-Git-Tag: releases/gcc-4.3.0~1914 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=6f535271b7ddae27e177a1ba1cb091872aeea04e;p=thirdparty%2Fgcc.git re PR fortran/31608 (wrong types in character array/scalar binop) 2007-10-20 Paul Thomas FX Coudert 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 FX Coudert PR fortran/31608 * gfortran.dg/char_cast_1.f90: New test. Co-Authored-By: Francois-Xavier Coudert From-SVN: r129505 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ff09b4798f6e..14e65ca582ab 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2007-10-20 Paul Thomas + FX Coudert + + 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 PR fortran/33544 diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 3205bebccab6..6de83ee9dc25 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,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) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c598d25ac1e1..680d3b4b4ace 100644 --- a/gcc/fortran/trans-array.c +++ b/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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8b7bb130f583..65ec81916571 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-10-20 Paul Thomas + FX Coudert + + PR fortran/31608 + * gfortran.dg/char_cast_1.f90: New test. + 2007-10-19 Steven G. Kargl * gfortran.dg/default_format_denormal_2.f90: xfail on FreeBSD. diff --git a/gcc/testsuite/gfortran.dg/char_cast_1.f90 b/gcc/testsuite/gfortran.dg/char_cast_1.f90 new file mode 100644 index 000000000000..08458b752199 --- /dev/null +++ b/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 +! + 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" } }