From 0ee8e25059355c772a3e7c7eb88d502496bc7922 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 26 May 2007 11:25:36 +0000 Subject: [PATCH] re PR fortran/31219 (ICE on array of character function results) 2007-05-26 Paul Thomas PR fortran/31219 * trans.h : Add no_function_call bitfield to gfc_se structure. Add stmtblock_t argument to prototype of get_array_ctor_strlen. * trans-array.c (get_array_ctor_all_strlen): New function. (get_array_ctor_strlen): Add new stmtblock_t argument and call new function for character elements that are not constants, arrays or variables. (gfc_conv_array_parameter): Call get_array_ctor_strlen to get good string length. * trans-intrinsic (gfc_conv_intrinsic_len): Add new argument to call of get_array_ctor_strlen. 2007-05-26 Paul Thomas PR fortran/31219 * gfortran.dg/array_constructor_17.f90: New test. From-SVN: r125088 --- gcc/fortran/ChangeLog | 14 ++++ gcc/fortran/trans-array.c | 70 +++++++++++++++---- gcc/fortran/trans-intrinsic.c | 2 +- gcc/fortran/trans.h | 5 +- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/array_constructor_17.f90 | 40 +++++++++++ 6 files changed, 121 insertions(+), 15 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/array_constructor_17.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index dfc1174ddf7..0d4a8773e5c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2007-05-26 Paul Thomas + + PR fortran/31219 + * trans.h : Add no_function_call bitfield to gfc_se structure. + Add stmtblock_t argument to prototype of get_array_ctor_strlen. + * trans-array.c (get_array_ctor_all_strlen): New function. + (get_array_ctor_strlen): Add new stmtblock_t argument and call + new function for character elements that are not constants, + arrays or variables. + (gfc_conv_array_parameter): Call get_array_ctor_strlen to get + good string length. + * trans-intrinsic (gfc_conv_intrinsic_len): Add new argument + to call of get_array_ctor_strlen. + 2007-05-25 Kazu Hirata * intrinsic.texi: Fix typos. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6c7ea6c5439..cda9f9317e1 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1366,11 +1366,54 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len) } +/* A catch-all to obtain the string length for anything that is not a + constant, array or variable. */ +static void +get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) +{ + gfc_se se; + gfc_ss *ss; + + /* Don't bother if we already know the length is a constant. */ + if (*len && INTEGER_CST_P (*len)) + return; + + if (!e->ref && e->ts.cl->length + && e->ts.cl->length->expr_type == EXPR_CONSTANT) + { + /* This is easy. */ + gfc_conv_const_charlen (e->ts.cl); + *len = e->ts.cl->backend_decl; + } + else + { + /* Otherwise, be brutal even if inefficient. */ + ss = gfc_walk_expr (e); + gfc_init_se (&se, NULL); + + /* No function call, in case of side effects. */ + se.no_function_call = 1; + if (ss == gfc_ss_terminator) + gfc_conv_expr (&se, e); + else + gfc_conv_expr_descriptor (&se, e, ss); + + /* Fix the value. */ + *len = gfc_evaluate_now (se.string_length, &se.pre); + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (block, &se.post); + + e->ts.cl->backend_decl = *len; + } +} + + /* Figure out the string length of a character array constructor. Returns TRUE if all elements are character constants. */ bool -get_array_ctor_strlen (gfc_constructor * c, tree * len) +get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) { bool is_const; @@ -1386,7 +1429,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len) break; case EXPR_ARRAY: - if (!get_array_ctor_strlen (c->expr->value.constructor, len)) + if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) is_const = false; break; @@ -1397,16 +1440,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len) default: is_const = false; - - /* Hope that whatever we have possesses a constant character - length! */ - if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl) - { - gfc_conv_const_charlen (c->expr->ts.cl); - *len = c->expr->ts.cl->backend_decl; - } - /* TODO: For now we just ignore anything we don't know how to - handle, and hope we can figure it out a different way. */ + get_array_ctor_all_strlen (block, c->expr, len); break; } } @@ -1597,10 +1631,13 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss) c = ss->expr->value.constructor; if (ss->expr->ts.type == BT_CHARACTER) { - bool const_string = get_array_ctor_strlen (c, &ss->string_length); + bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length); if (!ss->string_length) gfc_todo_error ("complex character array constructors"); + ss->expr->ts.cl->backend_decl = ss->string_length; + + type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length); if (const_string) type = build_pointer_type (type); @@ -4782,6 +4819,13 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) && expr->ref->u.ar.type == AR_FULL); sym = full_array_var ? expr->symtree->n.sym : NULL; + if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) + { + get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); + expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre); + se->string_length = expr->ts.cl->backend_decl; + } + /* Is this the result of the enclosing procedure? */ this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); if (this_array_result diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 75b5a4cffc5..d814b28a21a 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2537,7 +2537,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) /* Obtain the string length from the function used by trans-array.c(gfc_trans_array_constructor). */ len = NULL_TREE; - get_array_ctor_strlen (arg->value.constructor, &len); + get_array_ctor_strlen (&se->pre, arg->value.constructor, &len); break; case EXPR_VARIABLE: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index da4b0c10352..f2a5d440b1d 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -72,6 +72,9 @@ typedef struct gfc_se are NULL. Used by intrinsic size. */ unsigned data_not_needed:1; + /* If set, gfc_conv_function_call does not put byref calls into se->pre. */ + unsigned no_function_call:1; + /* Scalarization parameters. */ struct gfc_se *parent; struct gfc_ss *ss; @@ -434,7 +437,7 @@ extern GTY(()) tree gfc_static_ctors; void gfc_generate_constructors (void); /* Get the string length of an array constructor. */ -bool get_array_ctor_strlen (gfc_constructor *, tree *); +bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *); /* Generate a runtime error check. */ void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 66ba361ccc3..0c99b3c956e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-05-26 Paul Thomas + + PR fortran/31219 + * gfortran.dg/array_constructor_17.f90: New test. + 2007-05-25 Andrew Pinski PR tree-opt/32090 diff --git a/gcc/testsuite/gfortran.dg/array_constructor_17.f90 b/gcc/testsuite/gfortran.dg/array_constructor_17.f90 new file mode 100644 index 00000000000..3ce7a91835d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_constructor_17.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Tests the fix for PR31219, in which the character length of +! the functions in the array constructor was not being obtained +! correctly and this caused an ICE. +! +! Contributed by Joost VandeVondele +! + INTEGER :: J + CHARACTER(LEN = 8) :: str + J = 3 + write (str,'(2A4)') (/( F(I, J), I = 1, 2)/) + IF (str .NE. " ODD EVE") call abort () + +! Comment #1 from F-X Coudert (noted by T. Burnus) that +! actually exercises a different part of the bug. + call gee( (/g (3)/) ) + +CONTAINS + FUNCTION F (K,J) RESULT(I) + INTEGER :: K, J + CHARACTER(LEN = J) :: I + IF (MODULO (K, 2) .EQ. 0) THEN + I = "EVEN" + ELSE + I = "ODD" + ENDIF + END FUNCTION + + function g(k) result(i) + integer :: k + character(len = k) :: i + i = '1234' + end function + subroutine gee(a) + character(*),dimension(1) :: a + if(len (a) /= 3) call abort () + if(a(1) /= '123') call abort () + end subroutine gee + +END