From: domob Date: Sun, 21 Sep 2008 15:33:37 +0000 (+0000) Subject: 2008-09-21 Daniel Kraft X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=d778204af61952efdd7cbe4c21b546667c9cb893 2008-09-21 Daniel Kraft PR fortran/35846 * trans.h (gfc_conv_string_length): New argument `expr'. * trans-expr.c (flatten_array_ctors_without_strlen): New method. (gfc_conv_string_length): New argument `expr' that is used in a new special case handling if cl->length is NULL. (gfc_conv_subref_array_arg): Pass expr to gfc_conv_string_length. * trans-array.c (gfc_conv_expr_descriptor): Ditto. (gfc_trans_auto_array_allocation): Pass NULL as new expr. (gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto. (gfc_trans_deferred_array): Ditto. (gfc_trans_array_constructor): Save and restore old values of globals used for bounds checking. * trans-decl.c (gfc_trans_dummy_character): Ditto. (gfc_trans_auto_character_variable): Ditto. 2008-09-21 Daniel Kraft PR fortran/35846 * gfortran.dg/nested_array_constructor_1.f90: New test. * gfortran.dg/nested_array_constructor_2.f90: New test. * gfortran.dg/nested_array_constructor_3.f90: New test. * gfortran.dg/nested_array_constructor_4.f90: New test. * gfortran.dg/nested_array_constructor_5.f90: New test. * gfortran.dg/nested_array_constructor_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@140529 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 312e72d34c1..6b466ed9382 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,22 @@ 2008-09-21 Daniel Kraft + PR fortran/35846 + * trans.h (gfc_conv_string_length): New argument `expr'. + * trans-expr.c (flatten_array_ctors_without_strlen): New method. + (gfc_conv_string_length): New argument `expr' that is used in a new + special case handling if cl->length is NULL. + (gfc_conv_subref_array_arg): Pass expr to gfc_conv_string_length. + * trans-array.c (gfc_conv_expr_descriptor): Ditto. + (gfc_trans_auto_array_allocation): Pass NULL as new expr. + (gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto. + (gfc_trans_deferred_array): Ditto. + (gfc_trans_array_constructor): Save and restore old values of globals + used for bounds checking. + * trans-decl.c (gfc_trans_dummy_character): Ditto. + (gfc_trans_auto_character_variable): Ditto. + +2008-09-21 Daniel Kraft + * decl.c (match_procedure_in_type): Changed misleading error message for not yet implemented PROCEDURE(interface) syntax. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f4af4f25da1..42b9967764f 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1694,6 +1694,13 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) tree type; tree loopfrom; bool dynamic; + bool old_first_len, old_typespec_chararray_ctor; + tree old_first_len_val; + + /* Save the old values for nested checking. */ + old_first_len = first_len; + old_first_len_val = first_len_val; + old_typespec_chararray_ctor = typespec_chararray_ctor; /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no typespec was given for the array constructor. */ @@ -1792,7 +1799,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) if (size && compare_tree_int (size, nelem) == 0) { gfc_trans_constant_array_constructor (loop, ss, type); - return; + goto finish; } } } @@ -1849,6 +1856,12 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) gcc_unreachable (); } #endif + +finish: + /* Restore old values of globals. */ + first_len = old_first_len; + first_len_val = old_first_len_val; + typespec_chararray_ctor = old_typespec_chararray_ctor; } @@ -4080,7 +4093,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) if (sym->ts.type == BT_CHARACTER && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.cl, &block); + gfc_conv_string_length (sym->ts.cl, NULL, &block); gfc_trans_vla_type_sizes (sym, &block); @@ -4104,7 +4117,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.cl->backend_decl)) - gfc_conv_string_length (sym->ts.cl, &block); + gfc_conv_string_length (sym->ts.cl, NULL, &block); size = gfc_trans_array_bounds (type, sym, &offset, &block); @@ -4170,7 +4183,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.cl, &block); + gfc_conv_string_length (sym->ts.cl, NULL, &block); /* Evaluate the bounds of the array. */ gfc_trans_array_bounds (type, sym, &offset, &block); @@ -4262,7 +4275,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.cl, &block); + gfc_conv_string_length (sym->ts.cl, NULL, &block); checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check); @@ -4848,7 +4861,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) break; } - gfc_init_loopinfo (&loop); /* Associate the SS with the loop. */ @@ -4872,7 +4884,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) loop.temp_ss->next = gfc_ss_terminator; if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl) - gfc_conv_string_length (expr->ts.cl, &se->pre); + gfc_conv_string_length (expr->ts.cl, expr, &se->pre); loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts); @@ -5672,7 +5684,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.cl, &fnblock); + gfc_conv_string_length (sym->ts.cl, NULL, &fnblock); gfc_trans_vla_type_sizes (sym, &fnblock); } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ec00ee2ee8f..20253e668ca 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2583,7 +2583,7 @@ gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody) gfc_start_block (&body); /* Evaluate the string length expression. */ - gfc_conv_string_length (cl, &body); + gfc_conv_string_length (cl, NULL, &body); gfc_trans_vla_type_sizes (sym, &body); @@ -2607,7 +2607,7 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody) gfc_start_block (&body); /* Evaluate the string length expression. */ - gfc_conv_string_length (sym->ts.cl, &body); + gfc_conv_string_length (sym->ts.cl, NULL, &body); gfc_trans_vla_type_sizes (sym, &body); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 216b3df1c96..e0f2f77cd59 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -241,17 +241,102 @@ gfc_get_expr_charlen (gfc_expr *e) return length; } - + +/* For each character array constructor subexpression without a ts.cl->length, + replace it by its first element (if there aren't any elements, the length + should already be set to zero). */ + +static void +flatten_array_ctors_without_strlen (gfc_expr* e) +{ + gfc_actual_arglist* arg; + gfc_constructor* c; + + if (!e) + return; + + switch (e->expr_type) + { + + case EXPR_OP: + flatten_array_ctors_without_strlen (e->value.op.op1); + flatten_array_ctors_without_strlen (e->value.op.op2); + break; + + case EXPR_COMPCALL: + /* TODO: Implement as with EXPR_FUNCTION when needed. */ + gcc_unreachable (); + + case EXPR_FUNCTION: + for (arg = e->value.function.actual; arg; arg = arg->next) + flatten_array_ctors_without_strlen (arg->expr); + break; + + case EXPR_ARRAY: + + /* We've found what we're looking for. */ + if (e->ts.type == BT_CHARACTER && !e->ts.cl->length) + { + gfc_expr* new_expr; + gcc_assert (e->value.constructor); + + new_expr = e->value.constructor->expr; + e->value.constructor->expr = NULL; + + flatten_array_ctors_without_strlen (new_expr); + gfc_replace_expr (e, new_expr); + break; + } + + /* Otherwise, fall through to handle constructor elements. */ + case EXPR_STRUCTURE: + for (c = e->value.constructor; c; c = c->next) + flatten_array_ctors_without_strlen (c->expr); + break; + + default: + break; + + } +} + /* Generate code to initialize a string length variable. Returns the - value. */ + value. For array constructors, cl->length might be NULL and in this case, + the first element of the constructor is needed. expr is the original + expression so we can access it but can be NULL if this is not needed. */ void -gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock) +gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) { gfc_se se; gfc_init_se (&se, NULL); + + /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but + "flatten" array constructors by taking their first element; all elements + should be the same length or a cl->length should be present. */ + if (!cl->length) + { + gfc_expr* expr_flat; + gcc_assert (expr); + + expr_flat = gfc_copy_expr (expr); + flatten_array_ctors_without_strlen (expr_flat); + gfc_resolve_expr (expr_flat); + + gfc_conv_expr (&se, expr_flat); + gfc_add_block_to_block (pblock, &se.pre); + cl->backend_decl = convert (gfc_charlen_type_node, se.string_length); + + gfc_free_expr (expr_flat); + return; + } + + /* Convert cl->length. */ + + gcc_assert (cl->length); + gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr, build_int_cst (gfc_charlen_type_node, 0)); @@ -2092,7 +2177,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, /* Build an ss for the temporary. */ if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl) - gfc_conv_string_length (expr->ts.cl, &parmse->pre); + gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre); base_type = gfc_typenode_for_spec (&expr->ts); if (GFC_ARRAY_TYPE_P (base_type) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 36553ea255b..b3a0368160f 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -340,7 +340,7 @@ tree gfc_conv_string_tmp (gfc_se *, tree, tree); /* Get the string length variable belonging to an expression. */ tree gfc_get_expr_charlen (gfc_expr *); /* Initialize a string length variable. */ -void gfc_conv_string_length (gfc_charlen *, stmtblock_t *); +void gfc_conv_string_length (gfc_charlen *, gfc_expr *, stmtblock_t *); /* Ensure type sizes can be gimplified. */ void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7498f6eaa60..7ffa03a4d38 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,15 @@ 2008-09-21 Daniel Kraft + PR fortran/35846 + * gfortran.dg/nested_array_constructor_1.f90: New test. + * gfortran.dg/nested_array_constructor_2.f90: New test. + * gfortran.dg/nested_array_constructor_3.f90: New test. + * gfortran.dg/nested_array_constructor_4.f90: New test. + * gfortran.dg/nested_array_constructor_5.f90: New test. + * gfortran.dg/nested_array_constructor_6.f90: New test. + +2008-09-21 Daniel Kraft + * gfortran.dg/typebound_proc_4.f03: Changed expected error for not yet implemented PROCEDURE(interface). diff --git a/gcc/testsuite/gfortran.dg/nested_array_constructor_1.f90 b/gcc/testsuite/gfortran.dg/nested_array_constructor_1.f90 new file mode 100644 index 00000000000..54417a0dedd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/nested_array_constructor_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! This test is run with result-checking and -fbounds-check as +! nested_array_constructor_2.f90 + +! PR fortran/35846 +! This used to ICE because the charlength of the trim-expression was +! NULL. + +! Contributed by Tobias Burnus + +implicit none +character(len=2) :: c(3) + +c = 'a' +c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /) + +print *, c + +end diff --git a/gcc/testsuite/gfortran.dg/nested_array_constructor_2.f90 b/gcc/testsuite/gfortran.dg/nested_array_constructor_2.f90 new file mode 100644 index 00000000000..28c2b49e816 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/nested_array_constructor_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + +! PR fortran/35846 +! This used to ICE because the charlength of the trim-expression was +! NULL. + +! Contributed by Tobias Burnus + +implicit none +character(len=2) :: c(3) + +c = 'a' +c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /) + +print *, c + +if (c(1) /= 'ac' .or. c(2) /= 'ac' .or. c(3) /= 'cd') then + call abort () +end if + +end diff --git a/gcc/testsuite/gfortran.dg/nested_array_constructor_3.f90 b/gcc/testsuite/gfortran.dg/nested_array_constructor_3.f90 new file mode 100644 index 00000000000..dd10e5fafc9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/nested_array_constructor_3.f90 @@ -0,0 +1,22 @@ +! { dg-do run } + +! PR fortran/35846 +! Alternate test that also produced an ICE because of a missing length. + +PROGRAM test + IMPLICIT NONE + CHARACTER(LEN=2) :: x + + x = 'a' + CALL sub ( (/ TRIM(x), 'a' /) // 'c') +END PROGRAM + +SUBROUTINE sub(str) + IMPLICIT NONE + CHARACTER(LEN=*) :: str(2) + WRITE (*,*) str + + IF (str(1) /= 'ac' .OR. str(2) /= 'ac') THEN + CALL abort () + END IF +END SUBROUTINE sub diff --git a/gcc/testsuite/gfortran.dg/nested_array_constructor_4.f90 b/gcc/testsuite/gfortran.dg/nested_array_constructor_4.f90 new file mode 100644 index 00000000000..cb113e9c9ae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/nested_array_constructor_4.f90 @@ -0,0 +1,17 @@ +! { dg-do run } + +! PR fortran/35846 +! Alternate test that also produced an ICE because of a missing length. + +PROGRAM test + IMPLICIT NONE + CHARACTER(LEN=2) :: x + INTEGER :: length + + x = 'a' + length = LEN ( (/ TRIM(x), 'a' /) // 'c') + + IF (length /= 2) THEN + CALL abort () + END IF +END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/nested_array_constructor_5.f90 b/gcc/testsuite/gfortran.dg/nested_array_constructor_5.f90 new file mode 100644 index 00000000000..7744f1ffe94 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/nested_array_constructor_5.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +! PR fortran/35846 +! This used to ICE because the charlength of the trim-expression was +! NULL, but it is switched around to test for the right operand of // being +! not a constant, too. + +implicit none +character(len=2) :: c(2) + +c = 'a' +c = (/ (/ trim(c(1)), 'a' /) // (/ trim(c(1)), 'a' /) /) + +print *, c + +end diff --git a/gcc/testsuite/gfortran.dg/nested_array_constructor_6.f90 b/gcc/testsuite/gfortran.dg/nested_array_constructor_6.f90 new file mode 100644 index 00000000000..6eee6d0b32e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/nested_array_constructor_6.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + +! PR fortran/35846 +! Nested three levels deep. + +! Contributed by Tobias Burnus + +implicit none +character(len=3) :: c(3) +c = 'a' +c = (/ (/ 'A'//(/ trim(c(1)), 'a' /)/)//'c', 'dcd' /) +print *, c(1) +print *, c(2) +print *, c(3) +end