+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>
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;
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)
{
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);
}
}
}
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;
}
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 *);
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:
{
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))
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
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);
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;
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;
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. */
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);
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;
&& !(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);
--- /dev/null
+! { dg-do run }
+! Tests the fix for pr28167, in which character array constructors\r
+! with an implied do loop would cause an ICE, when used as actual\r
+! arguments.
+!
+! Based on the testscase by Harald Anlauf <anlauf@gmx.de>
+!
+ character(4), dimension(4) :: c1, c2\r
+ integer m\r
+ m = 4\r
+! Test the original problem\r
+ call foo ((/( 'abcd',i=1,m )/), c2)\r
+ if (any(c2(:) .ne. (/'abcd','abcd', &\r
+ 'abcd','abcd'/))) call abort ()\r
+\r
+! Now get a bit smarter\r
+ call foo ((/"abcd", "efgh", "ijkl", "mnop"/), c1) ! worked previously\r
+ call foo ((/(c1(i), i = m,1,-1)/), c2) ! was broken\r
+ if (any(c2(4:1:-1) .ne. c1)) call abort ()\r
+\r
+! gfc_todo: Not Implemented: complex character array constructors\r
+ 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 ()
+\r
+! Check functions in the constructor\r
+ call foo ((/(achar(64+i)//achar(68+i)//achar(72+i)// &\r
+ achar(76+i),i=1,4 )/), c1) ! was broken\r
+ if (any (c1 .ne. (/"AEIM","BFJN","CGKO","DHLP"/))) call abort ()\r
+contains\r
+ subroutine foo (chr1, chr2)\r
+ character(*), dimension(:) :: chr1, chr2\r
+ chr2 = chr1\r
+ end subroutine foo\r
+end
\ No newline at end of file
--- /dev/null
+! { 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\r
+ implicit none\r
+ character(len=12) :: teststring(2) = (/ "abc def ghij", &
+ "klm nop qrst" /)\r
+ character(len=12) :: a(2), b(2), c(2), d(2)
+ integer :: m = 7, n\r
+ a = teststring\r
+ b = a\r
+ c = a\r
+ d = a
+ n = m - 4
+
+! Make sure that variable substring references work.\r
+ call foo (a(:)(m:m+5), c(:)(n:m+2), d(:)(5:9))\r
+ 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 ()\r
+contains\r
+ subroutine foo (w, x, y)\r
+ character(len=*), intent(in) :: w(:)\r
+ character(len=*), intent(inOUT) :: x(:)\r
+ 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.\r
+! if (all (x(:)(3:7) .eq. y)) call abort ()
+ x = foostring (:)(5 : 4 + len (x))
+ y = foostring (:)(3 : 2 + len (y))
+ end subroutine foo\r
+end program pr28174\r
+\r
projects / thirdparty / gcc.git / commitdiff
