diff options
Diffstat (limited to 'gcc/fortran/trans-array.c')
| -rw-r--r-- | gcc/fortran/trans-array.c | 80 |
1 files changed, 62 insertions, 18 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6c7ea6c5439..efff3fd655d 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1366,11 +1366,54 @@ get_array_ctor_var_strlen (gfc_expr * expr, tree * len) } +/* A catch-all to obtain the string length for anything that is not a + constant, array or variable. */ +static void +get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) +{ + gfc_se se; + gfc_ss *ss; + + /* Don't bother if we already know the length is a constant. */ + if (*len && INTEGER_CST_P (*len)) + return; + + if (!e->ref && e->ts.cl->length + && e->ts.cl->length->expr_type == EXPR_CONSTANT) + { + /* This is easy. */ + gfc_conv_const_charlen (e->ts.cl); + *len = e->ts.cl->backend_decl; + } + else + { + /* Otherwise, be brutal even if inefficient. */ + ss = gfc_walk_expr (e); + gfc_init_se (&se, NULL); + + /* No function call, in case of side effects. */ + se.no_function_call = 1; + if (ss == gfc_ss_terminator) + gfc_conv_expr (&se, e); + else + gfc_conv_expr_descriptor (&se, e, ss); + + /* Fix the value. */ + *len = gfc_evaluate_now (se.string_length, &se.pre); + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (block, &se.post); + + e->ts.cl->backend_decl = *len; + } +} + + /* Figure out the string length of a character array constructor. Returns TRUE if all elements are character constants. */ bool -get_array_ctor_strlen (gfc_constructor * c, tree * len) +get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) { bool is_const; @@ -1386,7 +1429,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len) break; case EXPR_ARRAY: - if (!get_array_ctor_strlen (c->expr->value.constructor, len)) + if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) is_const = false; break; @@ -1397,16 +1440,7 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len) default: is_const = false; - - /* Hope that whatever we have possesses a constant character - length! */ - if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl) - { - gfc_conv_const_charlen (c->expr->ts.cl); - *len = c->expr->ts.cl->backend_decl; - } - /* TODO: For now we just ignore anything we don't know how to - handle, and hope we can figure it out a different way. */ + get_array_ctor_all_strlen (block, c->expr, len); break; } } @@ -1597,10 +1631,13 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss) c = ss->expr->value.constructor; if (ss->expr->ts.type == BT_CHARACTER) { - bool const_string = get_array_ctor_strlen (c, &ss->string_length); + bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length); if (!ss->string_length) gfc_todo_error ("complex character array constructors"); + ss->expr->ts.cl->backend_decl = ss->string_length; + + type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length); if (const_string) type = build_pointer_type (type); @@ -2699,7 +2736,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) /* As usual, lbound and ubound are exceptions!. */ case GFC_SS_INTRINSIC: - switch (ss->expr->value.function.isym->generic_id) + switch (ss->expr->value.function.isym->id) { case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: @@ -2735,7 +2772,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) break; case GFC_SS_INTRINSIC: - switch (ss->expr->value.function.isym->generic_id) + switch (ss->expr->value.function.isym->id) { /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: @@ -4277,16 +4314,16 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) This function is also used for array pointer assignments, and there are three cases: - - want_pointer && !se->direct_byref + - se->want_pointer && !se->direct_byref EXPR is an actual argument. On exit, se->expr contains a pointer to the array descriptor. - - !want_pointer && !se->direct_byref + - !se->want_pointer && !se->direct_byref EXPR is an actual argument to an intrinsic function or the left-hand side of a pointer assignment. On exit, se->expr contains the descriptor for EXPR. - - !want_pointer && se->direct_byref + - !se->want_pointer && se->direct_byref EXPR is the right-hand side of a pointer assignment and se->expr is the descriptor for the previously-evaluated left-hand side. The function creates an assignment from @@ -4782,6 +4819,13 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) && expr->ref->u.ar.type == AR_FULL); sym = full_array_var ? expr->symtree->n.sym : NULL; + if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) + { + get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); + expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre); + se->string_length = expr->ts.cl->backend_decl; + } + /* Is this the result of the enclosing procedure? */ this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); if (this_array_result |