------- Comment #3 from pault at gcc dot gnu dot org 2007-05-16 20:55 -------
This fixes it and much more besides. It needs commenting and tidying up.
Paul
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (révision 124762)
--- gcc/fortran/trans-array.c (copie de travail)
*************** gfc_trans_dummy_array_bias (gfc_symbol *
*** 4243,4248 ****
--- 4243,4315 ----
}
+ static void
+ gfc_fixup_missing_charlen (gfc_se *se, gfc_expr *expr)
+ {
+ tree tmp;
+ gfc_ref *char_ref = expr->ref;
+
+ expr->ts.cl = gfc_get_charlen ();
+ expr->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = expr->ts.cl;
+ expr->ts.cl->backend_decl
+ = gfc_create_var (gfc_charlen_type_node, "cl");
+
+ for (; char_ref; char_ref = char_ref->next)
+ if (char_ref->type == REF_SUBSTRING)
+ {
+ mpz_t char_len;
+
+ mpz_init_set_ui (char_len, 1);
+ mpz_add (char_len, char_len,
+ char_ref->u.ss.end->value.integer);
+ mpz_sub (char_len, char_len,
+ char_ref->u.ss.start->value.integer);
+ tmp = gfc_conv_mpz_to_tree (char_len,
+ gfc_default_character_kind);
+ /* Cast is necessary for *-charlen refs. */
+ tmp = convert (gfc_charlen_type_node, tmp);
+
+ gfc_add_modify_expr (&se->pre, expr->ts.cl->backend_decl, tmp);
+ mpz_clear (char_len);
+ break;
+ }
+
+ if (char_ref == NULL)
+ {
+ mpz_t length;
+ tmp = NULL_TREE;
+
+ if (expr->expr_type == EXPR_CONSTANT)
+ mpz_init_set_si (length, expr->value.character.length);
+ else if (expr->expr_type == EXPR_ARRAY)
+ mpz_init_set_si (length,
+ expr->value.constructor->expr->value.character.length);
+ else if (expr->expr_type == EXPR_OP)
+ {
+ if (!expr->value.op.op1->ts.cl)
+ gfc_fixup_missing_charlen (se, expr->value.op.op1);
+ if (!expr->value.op.op2->ts.cl)
+ gfc_fixup_missing_charlen (se, expr->value.op.op2);
+ tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
+ expr->value.op.op1->ts.cl->backend_decl,
+ expr->value.op.op2->ts.cl->backend_decl);
+ }
+ else
+ mpz_init_set_ui (length, 0);
+
+ if (!tmp)
+ {
+ tmp = gfc_conv_mpz_to_tree (length,
+ gfc_default_character_kind);
+ tmp = convert (gfc_charlen_type_node, tmp);
+ }
+
+ gfc_add_modify_expr (&se->pre, expr->ts.cl->backend_decl, tmp);
+ }
+ }
+
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4430,4463 ****
{
if (expr->ts.cl == NULL)
{
! /* This had better be a substring reference! */
! gfc_ref *char_ref = expr->ref;
! for (; char_ref; char_ref = char_ref->next)
! if (char_ref->type == REF_SUBSTRING)
! {
! mpz_t char_len;
! 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);
! mpz_sub (char_len, char_len,
! char_ref->u.ss.start->value.integer);
! expr->ts.cl->backend_decl
! = gfc_conv_mpz_to_tree (char_len,
! gfc_default_character_kind);
! /* Cast is necessary for *-charlen refs. */
! expr->ts.cl->backend_decl
! = convert (gfc_charlen_type_node,
! expr->ts.cl->backend_decl);
! mpz_clear (char_len);
! break;
! }
! gcc_assert (char_ref != NULL);
loop.temp_ss->data.temp.type
! = gfc_typenode_for_spec (&expr->ts);
loop.temp_ss->string_length = expr->ts.cl->backend_decl;
}
else if (expr->ts.cl->length
--- 4497,4505 ----
{
if (expr->ts.cl == NULL)
{
! gfc_fixup_missing_charlen (se, expr);
loop.temp_ss->data.temp.type
! = gfc_typenode_for_spec (&expr->ts);
loop.temp_ss->string_length = expr->ts.cl->backend_decl;
}
else if (expr->ts.cl->length
--
pault at gcc dot gnu dot org changed:
What |Removed |Added
----------------------------------------------------------------------------
AssignedTo|unassigned at gcc dot gnu |pault at gcc dot gnu dot org
|dot org |
Status|NEW |ASSIGNED
Last reconfirmed|2007-05-09 22:53:25 |2007-05-16 20:55:31
date| |
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=31879
