diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 13 | ||||
| -rw-r--r-- | gcc/fortran/data.c | 180 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 4 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 64 |
5 files changed, 240 insertions, 25 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 623a8d0916b..a7535db9cce 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2004-08-22 Richard Henderson <rth@redhat.com> + + PR 13465 + * data.c (find_con_by_offset): Search ordered list; handle + elements with repeat counts. + (gfc_assign_data_value_range): New. + * gfortran.h (struct gfc_data_value): Make repeat unsigned. + (gfc_assign_data_value_range): Declare. + * match.c (top_val_list): Extract repeat count into a temporary. + * resolve.c (values): Make left unsigned. + (next_data_value): Don't decrement left. + (check_data_variable): Use gfc_assign_data_value_range. + 2004-08-22 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de> * trans-const.c, trans-decl.c, trans-expr.c: Spelling fixes. diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 4ebacd34578..2999af2a860 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -82,12 +82,40 @@ get_array_index (gfc_array_ref * ar, mpz_t * offset) static gfc_constructor * find_con_by_offset (mpz_t offset, gfc_constructor *con) { + mpz_t tmp; + gfc_constructor *ret = NULL; + + mpz_init (tmp); + for (; con; con = con->next) { - if (mpz_cmp (offset, con->n.offset) == 0) - return con; + int cmp = mpz_cmp (offset, con->n.offset); + + /* We retain a sorted list, so if we're too large, we're done. */ + if (cmp < 0) + break; + + /* Yaye for exact matches. */ + if (cmp == 0) + { + ret = con; + break; + } + + /* If the constructor element is a range, match any element. */ + if (mpz_cmp_ui (con->repeat, 1) > 0) + { + mpz_add (tmp, con->n.offset, con->repeat); + if (mpz_cmp (offset, tmp) < 0) + { + ret = con; + break; + } + } } - return NULL; + + mpz_clear (tmp); + return ret; } @@ -236,7 +264,7 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) if (con == NULL) { /* Create a new constructor. */ - con = gfc_get_constructor(); + con = gfc_get_constructor (); mpz_set (con->n.offset, offset); gfc_insert_constructor (expr, con); } @@ -272,7 +300,6 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) abort (); } - if (init == NULL) { /* Point the container at the new expression. */ @@ -295,7 +322,6 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) expr = gfc_copy_expr (rvalue); if (!gfc_compare_types (&lvalue->ts, &expr->ts)) gfc_convert_type (expr, &lvalue->ts, 0); - } if (last_con == NULL) @@ -304,6 +330,148 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) last_con->expr = expr; } +/* Similarly, but initialize REPEAT consectutive values in LVALUE the same + value in RVALUE. For the nonce, LVALUE must refer to a full array, not + an array section. */ + +void +gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue, + mpz_t index, mpz_t repeat) +{ + gfc_ref *ref; + gfc_expr *init, *expr; + gfc_constructor *con, *last_con; + gfc_symbol *symbol; + gfc_typespec *last_ts; + mpz_t offset; + + symbol = lvalue->symtree->n.sym; + init = symbol->value; + last_ts = &symbol->ts; + last_con = NULL; + mpz_init_set_si (offset, 0); + + /* Find/create the parent expressions for subobject references. */ + for (ref = lvalue->ref; ref; ref = ref->next) + { + /* Use the existing initializer expression if it exists. + Otherwise create a new one. */ + if (init == NULL) + expr = gfc_get_expr (); + else + expr = init; + + /* Find or create this element. */ + switch (ref->type) + { + case REF_ARRAY: + if (init == NULL) + { + /* The element typespec will be the same as the array + typespec. */ + expr->ts = *last_ts; + /* Setup the expression to hold the constructor. */ + expr->expr_type = EXPR_ARRAY; + expr->rank = ref->u.ar.as->rank; + } + else + assert (expr->expr_type == EXPR_ARRAY); + + if (ref->u.ar.type == AR_ELEMENT) + { + get_array_index (&ref->u.ar, &offset); + + /* This had better not be the bottom of the reference. + We can still get to a full array via a component. */ + assert (ref->next != NULL); + } + else + { + mpz_set (offset, index); + + /* We're at a full array or an array section. This means + that we've better have found a full array, and that we're + at the bottom of the reference. */ + assert (ref->u.ar.type == AR_FULL); + assert (ref->next == NULL); + } + + /* Find the same element in the existing constructor. */ + con = expr->value.constructor; + con = find_con_by_offset (offset, con); + + /* Create a new constructor. */ + if (con == NULL) + { + con = gfc_get_constructor (); + mpz_set (con->n.offset, offset); + if (ref->next == NULL) + mpz_set (con->repeat, repeat); + gfc_insert_constructor (expr, con); + } + else + assert (ref->next != NULL); + break; + + case REF_COMPONENT: + if (init == NULL) + { + /* Setup the expression to hold the constructor. */ + expr->expr_type = EXPR_STRUCTURE; + expr->ts.type = BT_DERIVED; + expr->ts.derived = ref->u.c.sym; + } + else + assert (expr->expr_type == EXPR_STRUCTURE); + last_ts = &ref->u.c.component->ts; + + /* Find the same element in the existing constructor. */ + con = expr->value.constructor; + con = find_con_by_component (ref->u.c.component, con); + + if (con == NULL) + { + /* Create a new constructor. */ + con = gfc_get_constructor (); + con->n.component = ref->u.c.component; + con->next = expr->value.constructor; + expr->value.constructor = con; + } + + /* Since we're only intending to initialize arrays here, + there better be an inner reference. */ + assert (ref->next != NULL); + break; + + case REF_SUBSTRING: + default: + abort (); + } + + if (init == NULL) + { + /* Point the container at the new expression. */ + if (last_con == NULL) + symbol->value = expr; + else + last_con->expr = expr; + } + init = con->expr; + last_con = con; + } + + /* We should never be overwriting an existing initializer. */ + assert (!init); + + expr = gfc_copy_expr (rvalue); + if (!gfc_compare_types (&lvalue->ts, &expr->ts)) + gfc_convert_type (expr, &lvalue->ts, 0); + + if (last_con == NULL) + symbol->value = expr; + else + last_con->expr = expr; +} /* Modify the index of array section and re-calculate the array offset. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 697f662bc1a..e33a0aac710 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1304,9 +1304,8 @@ gfc_data_variable; typedef struct gfc_data_value { - int repeat; + unsigned int repeat; gfc_expr *expr; - struct gfc_data_value *next; } gfc_data_value; @@ -1402,6 +1401,7 @@ extern iterator_stack *iter_stack; void gfc_formalize_init_value (gfc_symbol *); void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *); void gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t); +void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t); void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *); /* scanner.c */ diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 65af46ad779..a42fd7f66ab 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2894,13 +2894,15 @@ top_val_list (gfc_data * data) } else { - msg = gfc_extract_int (expr, &tail->repeat); + signed int tmp; + msg = gfc_extract_int (expr, &tmp); gfc_free_expr (expr); if (msg != NULL) { gfc_error (msg); return MATCH_ERROR; } + tail->repeat = tmp; m = match_data_constant (&tail->expr); if (m == MATCH_NO) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1dc4db8a35d..dfca4abff01 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4037,7 +4037,7 @@ resolve_symbol (gfc_symbol * sym) static struct { gfc_data_value *vnode; - int left; + unsigned int left; } values; @@ -4047,7 +4047,6 @@ values; static try next_data_value (void) { - while (values.left == 0) { if (values.vnode->next == NULL) @@ -4057,7 +4056,6 @@ next_data_value (void) values.left = values.vnode->repeat; } - values.left--; return SUCCESS; } @@ -4086,7 +4084,10 @@ check_data_variable (gfc_data_variable * var, locus * where) gfc_internal_error ("check_data_variable(): Bad expression"); if (e->rank == 0) - mpz_init_set_ui (size, 1); + { + mpz_init_set_ui (size, 1); + ref = NULL; + } else { ref = e->ref; @@ -4145,19 +4146,54 @@ check_data_variable (gfc_data_variable * var, locus * where) if (t == FAILURE) break; + /* If we have more than one element left in the repeat count, + and we have more than one element left in the target variable, + then create a range assignment. */ + /* ??? Only done for full arrays for now, since array sections + seem tricky. */ + if (mark == AR_FULL && ref && ref->next == NULL + && values.left > 1 && mpz_cmp_ui (size, 1) > 0) + { + mpz_t range; + + if (mpz_cmp_ui (size, values.left) >= 0) + { + mpz_init_set_ui (range, values.left); + mpz_sub_ui (size, size, values.left); + values.left = 0; + } + else + { + mpz_init_set (range, size); + values.left -= mpz_get_ui (size); + mpz_set_ui (size, 0); + } + + gfc_assign_data_value_range (var->expr, values.vnode->expr, + offset, range); + + mpz_add (offset, offset, range); + mpz_clear (range); + } + /* Assign initial value to symbol. */ - gfc_assign_data_value (var->expr, values.vnode->expr, offset); + else + { + values.left -= 1; + mpz_sub_ui (size, size, 1); - if (mark == AR_FULL) - mpz_add_ui (offset, offset, 1); + gfc_assign_data_value (var->expr, values.vnode->expr, offset); - /* Modify the array section indexes and recalculate the offset for - next element. */ - else if (mark == AR_SECTION) - gfc_advance_section (section_index, ar, &offset); + if (mark == AR_FULL) + mpz_add_ui (offset, offset, 1); - mpz_sub_ui (size, size, 1); + /* Modify the array section indexes and recalculate the offset + for next element. */ + else if (mark == AR_SECTION) + gfc_advance_section (section_index, ar, &offset); + } } + if (mark == AR_SECTION) { for (i = 0; i < ar->dimen; i++) @@ -4253,7 +4289,6 @@ traverse_data_var (gfc_data_variable * var, locus * where) static try resolve_data_variables (gfc_data_variable * d) { - for (; d; d = d->next) { if (d->list == NULL) @@ -4287,7 +4322,6 @@ resolve_data_variables (gfc_data_variable * d) static void resolve_data (gfc_data * d) { - if (resolve_data_variables (d->var) == FAILURE) return; @@ -4312,7 +4346,6 @@ resolve_data (gfc_data * d) int gfc_impure_variable (gfc_symbol * sym) { - if (sym->attr.use_assoc || sym->attr.in_common) return 1; @@ -4606,4 +4639,3 @@ gfc_resolve (gfc_namespace * ns) gfc_current_ns = old_ns; } - |