From 1855915abe6888b17861d36e8174bf954eb8ed86 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 4 Jul 2006 20:15:52 +0000 Subject: [PATCH] re PR fortran/28174 (Corruption of multiple character arrays when passing array sections) 2006-07-04 Paul Thomas PR fortran/28174 * trans-array.c (gfc_conv_expr_descriptor): When building temp, ensure that the substring reference uses a new charlen. * trans-expr.c (gfc_conv_aliased_arg): Add the formal intent to the argument list, lift the treatment of missing string lengths from the above and implement the use of the intent. (gfc_conv_function_call): Add the extra argument to the call to the above. PR fortran/28167 * trans-array.c (get_array_ctor_var_strlen): Treat a constant substring reference. * array.c (gfc_resolve_character_array_constructor): Remove static attribute and add the gfc_ prefix, make use of element charlens for the expression and pick up constant string lengths for expressions that are not themselves constant. * gfortran.h : resolve_character_array_constructor prototype added. * resolve.c (gfc_resolve_expr): Call resolve_character_array_ constructor again after expanding the constructor, to ensure that the character length is passed to the expression. 2006-07-04 Paul Thomas PR fortran/28174 * gfortran.dg/actual_array_substr_2.f90: New test. PR fortran/28167 * gfortran.dg/actual_array_constructor_2.f90: New test. From-SVN: r115182 --- gcc/fortran/ChangeLog | 24 +++++++ gcc/fortran/array.c | 52 ++++++++++++--- gcc/fortran/gfortran.h | 1 + gcc/fortran/resolve.c | 5 ++ gcc/fortran/trans-array.c | 19 +++++- gcc/fortran/trans-expr.c | 63 +++++++++++++++---- .../actual_array_constructor_2.f90 | 34 ++++++++++ .../gfortran.dg/actual_array_substr_2.f90 | 44 +++++++++++++ 8 files changed, 219 insertions(+), 23 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/actual_array_substr_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6deaea58aca..efa31400c5d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2006-07-04 Paul Thomas + + PR fortran/28174 + * trans-array.c (gfc_conv_expr_descriptor): When building temp, + ensure that the substring reference uses a new charlen. + * trans-expr.c (gfc_conv_aliased_arg): Add the formal intent to + the argument list, lift the treatment of missing string lengths + from the above and implement the use of the intent. + (gfc_conv_function_call): Add the extra argument to the call to + the above. + + PR fortran/28167 + * trans-array.c (get_array_ctor_var_strlen): Treat a constant + substring reference. + * array.c (gfc_resolve_character_array_constructor): Remove + static attribute and add the gfc_ prefix, make use of element + charlens for the expression and pick up constant string lengths + for expressions that are not themselves constant. + * gfortran.h : resolve_character_array_constructor prototype + added. + * resolve.c (gfc_resolve_expr): Call resolve_character_array_ + constructor again after expanding the constructor, to ensure + that the character length is passed to the expression. + 2006-07-04 Francois-Xavier Coudert Daniel Franke diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 2cb34994562..fa38ab9c956 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1518,8 +1518,8 @@ resolve_array_list (gfc_constructor * p) not specified character length, update character length to the maximum of its element constructors' length. */ -static void -resolve_character_array_constructor (gfc_expr * expr) +void +gfc_resolve_character_array_constructor (gfc_expr * expr) { gfc_constructor * p; int max_length; @@ -1531,20 +1531,53 @@ resolve_character_array_constructor (gfc_expr * expr) if (expr->ts.cl == NULL) { + for (p = expr->value.constructor; p; p = p->next) + if (p->expr->ts.cl != NULL) + { + /* Ensure that if there is a char_len around that it is + used; otherwise the middle-end confuses them! */ + expr->ts.cl = p->expr->ts.cl; + goto got_charlen; + } + expr->ts.cl = gfc_get_charlen (); expr->ts.cl->next = gfc_current_ns->cl_list; gfc_current_ns->cl_list = expr->ts.cl; } +got_charlen: + if (expr->ts.cl->length == NULL) { /* Find the maximum length of the elements. Do nothing for variable array - constructor. */ + constructor, unless the character length is constant or there is a + constant substring reference. */ + for (p = expr->value.constructor; p; p = p->next) - if (p->expr->expr_type == EXPR_CONSTANT) - max_length = MAX (p->expr->value.character.length, max_length); - else - return; + { + gfc_ref *ref; + for (ref = p->expr->ref; ref; ref = ref->next) + if (ref->type == REF_SUBSTRING + && ref->u.ss.start->expr_type == EXPR_CONSTANT + && ref->u.ss.end->expr_type == EXPR_CONSTANT) + break; + + if (p->expr->expr_type == EXPR_CONSTANT) + max_length = MAX (p->expr->value.character.length, max_length); + + else if (ref) + max_length = MAX ((int)(mpz_get_ui (ref->u.ss.end->value.integer) + - mpz_get_ui (ref->u.ss.start->value.integer)) + + 1, max_length); + + else if (p->expr->ts.cl && p->expr->ts.cl->length + && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT) + max_length = MAX ((int)mpz_get_si (p->expr->ts.cl->length->value.integer), + max_length); + + else + return; + } if (max_length != -1) { @@ -1552,7 +1585,8 @@ resolve_character_array_constructor (gfc_expr * expr) expr->ts.cl->length = gfc_int_expr (max_length); /* Update the element constructors. */ for (p = expr->value.constructor; p; p = p->next) - gfc_set_constant_character_len (max_length, p->expr); + if (p->expr->expr_type == EXPR_CONSTANT) + gfc_set_constant_character_len (max_length, p->expr); } } } @@ -1568,7 +1602,7 @@ gfc_resolve_array_constructor (gfc_expr * expr) if (t == SUCCESS) t = gfc_check_constructor_type (expr); if (t == SUCCESS && expr->ts.type == BT_CHARACTER) - resolve_character_array_constructor (expr); + gfc_resolve_character_array_constructor (expr); return t; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 834d23f9134..21b0d09b066 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2028,6 +2028,7 @@ void gfc_simplify_iterator_var (gfc_expr *); try gfc_expand_constructor (gfc_expr *); int gfc_constant_ac (gfc_expr *); int gfc_expanded_ac (gfc_expr *); +void gfc_resolve_character_array_constructor (gfc_expr *); try gfc_resolve_array_constructor (gfc_expr *); try gfc_check_constructor_type (gfc_expr *); try gfc_check_iter_variable (gfc_expr *); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0e9916a1282..c3aaf87c0c9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2942,6 +2942,11 @@ gfc_resolve_expr (gfc_expr * e) gfc_expand_constructor (e); } + /* This provides the opportunity for the length of constructors with character + valued function elements to propogate the string length to the expression. */ + if (e->ts.type == BT_CHARACTER) + gfc_resolve_character_array_constructor (e); + break; case EXPR_STRUCTURE: diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6a2c2de3275..01c78d40496 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1341,6 +1341,7 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len) { gfc_ref *ref; gfc_typespec *ts; + mpz_t char_len; /* Don't bother if we already know the length is a constant. */ if (*len && INTEGER_CST_P (*len)) @@ -1360,6 +1361,19 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len) ts = &ref->u.c.component->ts; break; + case REF_SUBSTRING: + if (ref->u.ss.start->expr_type != EXPR_CONSTANT + || ref->u.ss.start->expr_type != EXPR_CONSTANT) + break; + mpz_init_set_ui (char_len, 1); + mpz_add (char_len, char_len, ref->u.ss.end->value.integer); + mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); + *len = gfc_conv_mpz_to_tree (char_len, + gfc_default_character_kind); + *len = convert (gfc_charlen_type_node, *len); + mpz_clear (char_len); + return; + default: /* TODO: Substrings are tricky because we can't evaluate the expression more than once. For now we just give up, and hope @@ -4192,7 +4206,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (char_ref->type == REF_SUBSTRING) { mpz_t char_len; - expr->ts.cl = char_ref->u.ss.length; + expr->ts.cl = gfc_get_charlen (); + expr->ts.cl->next = char_ref->u.ss.length->next; + char_ref->u.ss.length->next = expr->ts.cl; + mpz_init_set_ui (char_len, 1); mpz_add (char_len, char_len, char_ref->u.ss.end->value.integer); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1d429c98ec3..30cf80a4390 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1591,7 +1591,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping, handling aliased arrays. */ static void -gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77) +gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, + int g77, sym_intent intent) { gfc_se lse; gfc_se rse; @@ -1635,7 +1636,37 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77) loop.temp_ss->data.temp.type = base_type; if (expr->ts.type == BT_CHARACTER) - loop.temp_ss->string_length = expr->ts.cl->backend_decl; + { + gfc_ref *char_ref = expr->ref; + + for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next) + if (char_ref->type == REF_SUBSTRING) + { + gfc_se tmp_se; + + expr->ts.cl = gfc_get_charlen (); + expr->ts.cl->next = char_ref->u.ss.length->next; + char_ref->u.ss.length->next = expr->ts.cl; + + gfc_init_se (&tmp_se, NULL); + gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end, + gfc_array_index_type); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp_se.expr, gfc_index_one_node); + tmp = gfc_evaluate_now (tmp, &parmse->pre); + gfc_init_se (&tmp_se, NULL); + gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start, + gfc_array_index_type); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp, tmp_se.expr); + expr->ts.cl->backend_decl = tmp; + + break; + } + loop.temp_ss->data.temp.type + = gfc_typenode_for_spec (&expr->ts); + loop.temp_ss->string_length = expr->ts.cl->backend_decl; + } loop.temp_ss->data.temp.dimen = loop.dimen; loop.temp_ss->next = gfc_ss_terminator; @@ -1668,12 +1699,13 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77) gfc_conv_tmp_array_ref (&lse); gfc_advance_se_ss_chain (&lse); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); - gfc_add_expr_to_block (&body, tmp); - - gcc_assert (rse.ss == gfc_ss_terminator); - - gfc_trans_scalarizing_loops (&loop, &body); + if (intent != INTENT_OUT) + { + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + gfc_add_expr_to_block (&body, tmp); + gcc_assert (rse.ss == gfc_ss_terminator); + gfc_trans_scalarizing_loops (&loop, &body); + } /* Add the post block after the second loop, so that any freeing of allocated memory is done at the right time. */ @@ -1761,10 +1793,13 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77) gfc_trans_scalarizing_loops (&loop2, &body); /* Wrap the whole thing up by adding the second loop to the post-block - and following it by the post-block of the fist loop. In this way, + and following it by the post-block of the first loop. In this way, if the temporary needs freeing, it is done after use! */ - gfc_add_block_to_block (&parmse->post, &loop2.pre); - gfc_add_block_to_block (&parmse->post, &loop2.post); + if (intent != INTENT_IN) + { + gfc_add_block_to_block (&parmse->post, &loop2.pre); + gfc_add_block_to_block (&parmse->post, &loop2.post); + } gfc_add_block_to_block (&parmse->post, &loop.post); @@ -1799,7 +1834,8 @@ is_aliased_array (gfc_expr * e) if (ref->type == REF_ARRAY) seen_array = true; - if (ref->next == NULL && ref->type == REF_COMPONENT) + if (ref->next == NULL + && ref->type != REF_ARRAY) return seen_array; } return false; @@ -1937,13 +1973,14 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, && !(fsym->attr.pointer || fsym->attr.allocatable) && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; + if (e->expr_type == EXPR_VARIABLE && is_aliased_array (e)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ - gfc_conv_aliased_arg (&parmse, e, f); + gfc_conv_aliased_arg (&parmse, e, f, fsym->attr.intent); else gfc_conv_array_parameter (&parmse, e, argss, f); diff --git a/gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90 b/gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90 new file mode 100644 index 00000000000..0a86b70d7bf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! Tests the fix for pr28167, in which character array constructors +! with an implied do loop would cause an ICE, when used as actual +! arguments. +! +! Based on the testscase by Harald Anlauf +! + character(4), dimension(4) :: c1, c2 + integer m + m = 4 +! Test the original problem + call foo ((/( 'abcd',i=1,m )/), c2) + if (any(c2(:) .ne. (/'abcd','abcd', & + 'abcd','abcd'/))) call abort () + +! Now get a bit smarter + call foo ((/"abcd", "efgh", "ijkl", "mnop"/), c1) ! worked previously + call foo ((/(c1(i), i = m,1,-1)/), c2) ! was broken + if (any(c2(4:1:-1) .ne. c1)) call abort () + +! gfc_todo: Not Implemented: complex character array constructors + call foo ((/(c1(i)(i/2+1:i/2+2), i = 1,4)/), c2) ! Ha! take that..! + if (any (c2 .ne. (/"ab ","fg ","jk ","op "/))) call abort () + +! Check functions in the constructor + call foo ((/(achar(64+i)//achar(68+i)//achar(72+i)// & + achar(76+i),i=1,4 )/), c1) ! was broken + if (any (c1 .ne. (/"AEIM","BFJN","CGKO","DHLP"/))) call abort () +contains + subroutine foo (chr1, chr2) + character(*), dimension(:) :: chr1, chr2 + chr2 = chr1 + end subroutine foo +end \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/actual_array_substr_2.f90 b/gcc/testsuite/gfortran.dg/actual_array_substr_2.f90 new file mode 100644 index 00000000000..365557d6f57 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/actual_array_substr_2.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! Tests the fix for pr28174, in which the fix for pr28118 was +! corrupting the character lengths of arrays that shared a +! character length structure. In addition, in developing the +! fix, it was noted that intent(out/inout) arguments were not +! getting written back to the calling scope. +! +! Based on the testscase by Harald Anlauf +! +program pr28174 + implicit none + character(len=12) :: teststring(2) = (/ "abc def ghij", & + "klm nop qrst" /) + character(len=12) :: a(2), b(2), c(2), d(2) + integer :: m = 7, n + a = teststring + b = a + c = a + d = a + n = m - 4 + +! Make sure that variable substring references work. + call foo (a(:)(m:m+5), c(:)(n:m+2), d(:)(5:9)) + if (any (a .ne. teststring)) call abort () + if (any (b .ne. teststring)) call abort () + if (any (c .ne. (/"ab456789#hij", & + "kl7654321rst"/))) call abort () + if (any (d .ne. (/"abc 23456hij", & + "klm 98765rst"/))) call abort () +contains + subroutine foo (w, x, y) + character(len=*), intent(in) :: w(:) + character(len=*), intent(inOUT) :: x(:) + character(len=*), intent(OUT) :: y(:) + character(len=12) :: foostring(2) = (/"0123456789#$" , & + "$#9876543210"/) +! This next is not required by the standard but tests the +! functioning of the gfortran implementation. +! if (all (x(:)(3:7) .eq. y)) call abort () + x = foostring (:)(5 : 4 + len (x)) + y = foostring (:)(3 : 2 + len (y)) + end subroutine foo +end program pr28174 +