diff options
Diffstat (limited to 'gcc/fortran/array.c')
| -rw-r--r-- | gcc/fortran/array.c | 111 |
1 files changed, 97 insertions, 14 deletions
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index adc3f3f..71c8b5d 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -877,9 +877,11 @@ gfc_match_array_constructor (gfc_expr **result) { gfc_constructor *head, *tail, *new; gfc_expr *expr; + gfc_typespec ts; locus where; match m; const char *end_delim; + bool seen_ts; if (gfc_match (" (/") == MATCH_NO) { @@ -898,11 +900,33 @@ gfc_match_array_constructor (gfc_expr **result) where = gfc_current_locus; head = tail = NULL; + seen_ts = false; + + /* Try to match an optional "type-spec ::" */ + if (gfc_match_type_spec (&ts, 0) == MATCH_YES) + { + seen_ts = (gfc_match (" ::") == MATCH_YES); + + if (seen_ts) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor " + "including type specification at %C") == FAILURE) + goto cleanup; + } + } + + if (! seen_ts) + gfc_current_locus = where; if (gfc_match (end_delim) == MATCH_YES) { - gfc_error ("Empty array constructor at %C is not allowed"); - goto cleanup; + if (seen_ts) + goto done; + else + { + gfc_error ("Empty array constructor at %C is not allowed"); + goto cleanup; + } } for (;;) @@ -927,6 +951,7 @@ gfc_match_array_constructor (gfc_expr **result) if (gfc_match (end_delim) == MATCH_NO) goto syntax; +done: expr = gfc_get_expr (); expr->expr_type = EXPR_ARRAY; @@ -934,6 +959,14 @@ gfc_match_array_constructor (gfc_expr **result) expr->value.constructor = head; /* Size must be calculated at resolution time. */ + if (seen_ts) + expr->ts = ts; + else + expr->ts.type = BT_UNKNOWN; + + if (expr->ts.cl) + expr->ts.cl->length_from_typespec = seen_ts; + expr->where = where; expr->rank = 1; @@ -964,7 +997,7 @@ static enum cons_state; static int -check_element_type (gfc_expr *expr) +check_element_type (gfc_expr *expr, bool convert) { if (cons_state == CONS_BAD) return 0; /* Suppress further errors */ @@ -985,6 +1018,9 @@ check_element_type (gfc_expr *expr) if (gfc_compare_types (&constructor_ts, &expr->ts)) return 0; + if (convert) + return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1; + gfc_error ("Element in %s array constructor at %L is %s", gfc_typename (&constructor_ts), &expr->where, gfc_typename (&expr->ts)); @@ -997,7 +1033,7 @@ check_element_type (gfc_expr *expr) /* Recursive work function for gfc_check_constructor_type(). */ static try -check_constructor_type (gfc_constructor *c) +check_constructor_type (gfc_constructor *c, bool convert) { gfc_expr *e; @@ -1007,13 +1043,13 @@ check_constructor_type (gfc_constructor *c) if (e->expr_type == EXPR_ARRAY) { - if (check_constructor_type (e->value.constructor) == FAILURE) + if (check_constructor_type (e->value.constructor, convert) == FAILURE) return FAILURE; continue; } - if (check_element_type (e)) + if (check_element_type (e, convert)) return FAILURE; } @@ -1029,10 +1065,20 @@ gfc_check_constructor_type (gfc_expr *e) { try t; - cons_state = CONS_START; - gfc_clear_ts (&constructor_ts); + if (e->ts.type != BT_UNKNOWN) + { + cons_state = CONS_GOOD; + constructor_ts = e->ts; + } + else + { + cons_state = CONS_START; + gfc_clear_ts (&constructor_ts); + } - t = check_constructor_type (e->value.constructor); + /* If e->ts.type != BT_UNKNOWN, the array constructor included a + typespec, and we will now convert the values on the fly. */ + t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN); if (t == SUCCESS && e->ts.type == BT_UNKNOWN) e->ts = constructor_ts; @@ -1526,13 +1572,15 @@ resolve_array_list (gfc_constructor *p) /* Resolve character array constructor. If it is a constant character array and not specified character length, update character length to the maximum of - its element constructors' length. */ + its element constructors' length. For arrays with fixed length, pad the + elements as necessary with needed_length. */ void gfc_resolve_character_array_constructor (gfc_expr *expr) { gfc_constructor *p; int max_length; + bool generated_length; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); @@ -1557,6 +1605,7 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) got_charlen: + generated_length = false; if (expr->ts.cl->length == NULL) { /* Find the maximum length of the elements. Do nothing for variable @@ -1596,12 +1645,46 @@ got_charlen: { /* Update the character length of the array constructor. */ expr->ts.cl->length = gfc_int_expr (max_length); - /* Update the element constructors. */ - for (p = expr->value.constructor; p; p = p->next) - if (p->expr->expr_type == EXPR_CONSTANT) - gfc_set_constant_character_len (max_length, p->expr, true); + generated_length = true; + /* Real update follows below. */ } } + else + { + /* We've got a character length specified. It should be an integer, + otherwise an error is signalled elsewhere. */ + gcc_assert (expr->ts.cl->length); + + /* If we've got a constant character length, pad according to this. + gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets + max_length only if they pass. */ + gfc_extract_int (expr->ts.cl->length, &max_length); + } + + /* Found a length to update to, do it for all element strings shorter than + the target length. */ + if (max_length != -1) + { + for (p = expr->value.constructor; p; p = p->next) + if (p->expr->expr_type == EXPR_CONSTANT) + { + gfc_expr *cl = NULL; + int current_length = -1; + + if (p->expr->ts.cl && p->expr->ts.cl->length) + { + cl = p->expr->ts.cl->length; + gfc_extract_int (cl, ¤t_length); + } + + /* If gfc_extract_int above set current_length, we implicitly + know the type is BT_INTEGER and it's EXPR_CONSTANT. */ + + if (generated_length || ! cl + || (current_length != -1 && current_length < max_length)) + gfc_set_constant_character_len (max_length, p->expr, true); + } + } } |