From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 12724 invoked by alias); 10 Oct 2007 15:45:14 -0000 Received: (qmail 12452 invoked by uid 48); 10 Oct 2007 15:45:00 -0000 Date: Wed, 10 Oct 2007 15:45:00 -0000 Message-ID: <20071010154500.12451.qmail@sourceware.org> X-Bugzilla-Reason: CC References: Subject: [Bug fortran/31608] wrong types in character array/scalar binop In-Reply-To: Reply-To: gcc-bugzilla@gcc.gnu.org To: gcc-bugs@gcc.gnu.org From: "pault at gcc dot gnu dot org" Mailing-List: contact gcc-bugs-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-bugs-owner@gcc.gnu.org X-SW-Source: 2007-10/txt/msg01005.txt.bz2 ------- Comment #28 from pault at gcc dot gnu dot org 2007-10-10 15:44 ------- The patch below fixes the lot. It was not necessary in the end to touch trans-intrinsic.c. Once the appropriate, offending bit of trans-array.c was fixed, all the casting occurred correctly. The fixes to iresolve.c deal with the various ICEing testcases in the comments below and are partially based on FX's input. This now compiles an runs correctly. 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 and the code in achar, which Richard flagged up has become: char char.6; char.6 = (*(char[0:][1:1] *) atmp.3.data)[S.5][1]{lb: 1 sz: 1}; (*(char[0:][1:1] *) atmp.4.data)[S.5][1]{lb: 1 sz: 1} = char.6; The patch even regtests but I will check tonto and cp2k before submitting. Cheers Paul Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (révision 129121) --- gcc/fortran/trans-array.c (copie de travail) *************** gfc_conv_expr_descriptor (gfc_se * se, g *** 4711,4717 **** 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); /* Finish the copying loops. */ gfc_trans_scalarizing_loops (&loop, &block); --- 4711,4725 ---- gfc_add_block_to_block (&block, &rse.pre); gfc_add_block_to_block (&block, &lse.pre); ! 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); Index: gcc/fortran/iresolve.c =================================================================== *** gcc/fortran/iresolve.c (révision 129121) --- gcc/fortran/iresolve.c (copie de travail) *************** gfc_get_string (const char *format, ...) *** 62,75 **** static void check_charlen_present (gfc_expr *source) { ! if (source->expr_type == EXPR_CONSTANT && 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; source->ts.cl->length = gfc_int_expr (source->value.character.length); source->rank = 0; } } /* Helper function for resolving the "mask" argument. */ --- 62,85 ---- static void check_charlen_present (gfc_expr *source) { ! 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. */ *************** gfc_resolve_access (gfc_expr *f, gfc_exp *** 132,139 **** } ! void ! gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind) { f->ts.type = BT_CHARACTER; f->ts.kind = (kind == NULL) --- 142,150 ---- } ! 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_resolve_achar (gfc_expr *f, gfc_expr *** 143,155 **** 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, gfc_type_letter (x->ts.type), x->ts.kind); } void gfc_resolve_acos (gfc_expr *f, gfc_expr *x) { f->ts = x->ts; --- 154,173 ---- gfc_current_ns->cl_list = f->ts.cl; f->ts.cl->length = gfc_int_expr (1); ! 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; *************** gfc_resolve_ceiling (gfc_expr *f, gfc_ex *** 379,390 **** 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); } --- 397,403 ---- void gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind) { ! gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d"); } *************** gfc_resolve_transfer (gfc_expr *f, gfc_e *** 2269,2274 **** --- 2282,2290 ---- { /* 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; -- pault at gcc dot gnu dot org changed: What |Removed |Added ---------------------------------------------------------------------------- AssignedTo|unassigned at gcc dot gnu |pault at gcc dot gnu dot org |dot org | Status|NEW |ASSIGNED Last reconfirmed|2007-10-05 17:41:43 |2007-10-10 15:45:00 date| | http://gcc.gnu.org/bugzilla/show_bug.cgi?id=31608