mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-16 02:10:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/28174 (Corruption of multiple character arrays when passing array sections)

Browse Source 
2006-07-04  Paul Thomas  <pault@gcc.gnu.org>

	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  <pault@gcc.gnu.org>

	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
This commit is contained in:
Paul Thomas 2006-07-04 20:15:52 +00:00
parent 6215885d43
commit 1855915abe
8 changed files with 219 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/fortran/ChangeLog
View File

@ -1,3 +1,27 @@
2006-07-04 Paul Thomas <pault@gcc.gnu.org>
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 <coudert@clipper.ens.fr>
Daniel Franke <franke.daniel@gmail.com>

52
gcc/fortran/array.c
View File

@ -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;
}

1
gcc/fortran/gfortran.h
View File

@ -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 *);

5
gcc/fortran/resolve.c
View File

@ -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:

19
gcc/fortran/trans-array.c
View File

@ -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);

63
gcc/fortran/trans-expr.c
View File

@ -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);

34
gcc/testsuite/gfortran.dg/actual_array_constructor_2.f90 Normal file
View File

@ -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 <anlauf@gmx.de>
!
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

44
gcc/testsuite/gfortran.dg/actual_array_substr_2.f90 Normal file
View File

@ -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 <anlauf@gmx.de>
!
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