X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Farray.c;h=4282fd1d8e975040335d446b677af17951b5cd4d;hb=ea721ea5667586067a5bf88325d28a91241e492c;hp=5487be7aa4fd589efaac32cc7a07591e9683724c;hpb=a250d5604c330534faa5c2c410c33db5d8253768;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 5487be7aa4f..4282fd1d8e9 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -23,7 +23,6 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "gfortran.h" #include "match.h" -#include "constructor.h" /**************** Array reference matching subroutines *****************/ @@ -62,13 +61,12 @@ gfc_copy_array_ref (gfc_array_ref *src) expression. */ static match -match_subscript (gfc_array_ref *ar, int init, bool match_star) +match_subscript (gfc_array_ref *ar, int init) { match m; - bool star = false; int i; - i = ar->dimen + ar->codimen; + i = ar->dimen; ar->c_where[i] = gfc_current_locus; ar->start[i] = ar->end[i] = ar->stride[i] = NULL; @@ -83,12 +81,9 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star) goto end_element; /* Get start element. */ - if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) - star = true; - - if (!star && init) + if (init) m = gfc_match_init_expr (&ar->start[i]); - else if (!star) + else m = gfc_match_expr (&ar->start[i]); if (m == MATCH_NO) @@ -97,22 +92,14 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star) return MATCH_ERROR; if (gfc_match_char (':') == MATCH_NO) - goto matched; - - if (star) - { - gfc_error ("Unexpected '*' in coarray subscript at %C"); - return MATCH_ERROR; - } + return MATCH_YES; /* Get an optional end element. Because we've seen the colon, we definitely have a range along this dimension. */ end_element: ar->dimen_type[i] = DIMEN_RANGE; - if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) - star = true; - else if (init) + if (init) m = gfc_match_init_expr (&ar->end[i]); else m = gfc_match_expr (&ar->end[i]); @@ -123,12 +110,6 @@ end_element: /* See if we have an optional stride. */ if (gfc_match_char (':') == MATCH_YES) { - if (star) - { - gfc_error ("Strides not allowed in coarray subscript at %C"); - return MATCH_ERROR; - } - m = init ? gfc_match_init_expr (&ar->stride[i]) : gfc_match_expr (&ar->stride[i]); @@ -138,10 +119,6 @@ end_element: return MATCH_ERROR; } -matched: - if (star) - ar->dimen_type[i] = DIMEN_STAR; - return MATCH_YES; } @@ -151,23 +128,14 @@ matched: to consist of init expressions. */ match -gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, - int corank) +gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) { match m; - bool matched_bracket = false; memset (ar, '\0', sizeof (ar)); ar->where = gfc_current_locus; ar->as = as; - ar->type = AR_UNKNOWN; - - if (gfc_match_char ('[') == MATCH_YES) - { - matched_bracket = true; - goto coarray; - } if (gfc_match_char ('(') != MATCH_YES) { @@ -176,73 +144,34 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, return MATCH_YES; } + ar->type = AR_UNKNOWN; + for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) { - m = match_subscript (ar, init, false); + m = match_subscript (ar, init); if (m == MATCH_ERROR) - return MATCH_ERROR; + goto error; if (gfc_match_char (')') == MATCH_YES) - { - ar->dimen++; - goto coarray; - } + goto matched; if (gfc_match_char (',') != MATCH_YES) { gfc_error ("Invalid form of array reference at %C"); - return MATCH_ERROR; + goto error; } } gfc_error ("Array reference at %C cannot have more than %d dimensions", GFC_MAX_DIMENSIONS); - return MATCH_ERROR; - -coarray: - if (!matched_bracket && gfc_match_char ('[') != MATCH_YES) - { - if (ar->dimen > 0) - return MATCH_YES; - else - return MATCH_ERROR; - } - - if (gfc_option.coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return MATCH_ERROR; - } - - if (corank == 0) - { - gfc_error ("Unexpected coarray designator at %C"); - return MATCH_ERROR; - } - - for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) - { - m = match_subscript (ar, init, ar->codimen == (corank - 1)); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match_char (']') == MATCH_YES) - { - ar->codimen++; - return MATCH_YES; - } - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Invalid form of coarray reference at %C"); - return MATCH_ERROR; - } - } - gfc_error ("Array reference at %C cannot have more than %d dimensions", - GFC_MAX_DIMENSIONS); +error: return MATCH_ERROR; +matched: + ar->dimen++; + + return MATCH_YES; } @@ -366,7 +295,7 @@ match_array_element_spec (gfc_array_spec *as) if (gfc_match_char ('*') == MATCH_YES) { - *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + *lower = gfc_int_expr (1); return AS_ASSUMED_SIZE; } @@ -383,7 +312,7 @@ match_array_element_spec (gfc_array_spec *as) if (gfc_match_char (':') == MATCH_NO) { - *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + *lower = gfc_int_expr (1); return AS_EXPLICIT; } @@ -531,8 +460,8 @@ coarray: if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - goto cleanup; + gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + goto cleanup; } for (;;) @@ -636,7 +565,7 @@ done: for (i = 0; i < as->rank + as->corank; i++) { if (as->lower[i] == NULL) - as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + as->lower[i] = gfc_int_expr (1); } } @@ -807,6 +736,151 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) /****************** Array constructor functions ******************/ +/* Start an array constructor. The constructor starts with zero + elements and should be appended to by gfc_append_constructor(). */ + +gfc_expr * +gfc_start_constructor (bt type, int kind, locus *where) +{ + gfc_expr *result; + + result = gfc_get_expr (); + + result->expr_type = EXPR_ARRAY; + result->rank = 1; + + result->ts.type = type; + result->ts.kind = kind; + result->where = *where; + return result; +} + + +/* Given an array constructor expression, append the new expression + node onto the constructor. */ + +void +gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr) +{ + gfc_constructor *c; + + if (base->value.constructor == NULL) + base->value.constructor = c = gfc_get_constructor (); + else + { + c = base->value.constructor; + while (c->next) + c = c->next; + + c->next = gfc_get_constructor (); + c = c->next; + } + + c->expr = new_expr; + + if (new_expr + && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)) + gfc_internal_error ("gfc_append_constructor(): New node has wrong kind"); +} + + +/* Given an array constructor expression, insert the new expression's + constructor onto the base's one according to the offset. */ + +void +gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1) +{ + gfc_constructor *c, *pre; + expr_t type; + int t; + + type = base->expr_type; + + if (base->value.constructor == NULL) + base->value.constructor = c1; + else + { + c = pre = base->value.constructor; + while (c) + { + if (type == EXPR_ARRAY) + { + t = mpz_cmp (c->n.offset, c1->n.offset); + if (t < 0) + { + pre = c; + c = c->next; + } + else if (t == 0) + { + gfc_error ("duplicated initializer"); + break; + } + else + break; + } + else + { + pre = c; + c = c->next; + } + } + + if (pre != c) + { + pre->next = c1; + c1->next = c; + } + else + { + c1->next = c; + base->value.constructor = c1; + } + } +} + + +/* Get a new constructor. */ + +gfc_constructor * +gfc_get_constructor (void) +{ + gfc_constructor *c; + + c = XCNEW (gfc_constructor); + c->expr = NULL; + c->iterator = NULL; + c->next = NULL; + mpz_init_set_si (c->n.offset, 0); + mpz_init_set_si (c->repeat, 0); + return c; +} + + +/* Free chains of gfc_constructor structures. */ + +void +gfc_free_constructor (gfc_constructor *p) +{ + gfc_constructor *next; + + if (p == NULL) + return; + + for (; p; p = next) + { + next = p->next; + + if (p->expr) + gfc_free_expr (p->expr); + if (p->iterator != NULL) + gfc_free_iterator (p->iterator, 1); + mpz_clear (p->n.offset); + mpz_clear (p->repeat); + gfc_free (p); + } +} + /* Given an expression node that might be an array constructor and a symbol, make sure that no iterators in this or child constructors @@ -814,12 +888,11 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) duplicate was found. */ static int -check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) +check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master) { - gfc_constructor *c; gfc_expr *e; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + for (; c; c = c->next) { e = c->expr; @@ -844,15 +917,14 @@ check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) /* Forward declaration because these functions are mutually recursive. */ -static match match_array_cons_element (gfc_constructor_base *); +static match match_array_cons_element (gfc_constructor **); /* Match a list of array elements. */ static match -match_array_list (gfc_constructor_base *result) +match_array_list (gfc_constructor **result) { - gfc_constructor_base head; - gfc_constructor *p; + gfc_constructor *p, *head, *tail, *new_cons; gfc_iterator iter; locus old_loc; gfc_expr *e; @@ -871,6 +943,8 @@ match_array_list (gfc_constructor_base *result) if (m != MATCH_YES) goto cleanup; + tail = head; + if (gfc_match_char (',') != MATCH_YES) { m = MATCH_NO; @@ -885,7 +959,7 @@ match_array_list (gfc_constructor_base *result) if (m == MATCH_ERROR) goto cleanup; - m = match_array_cons_element (&head); + m = match_array_cons_element (&new_cons); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -896,6 +970,9 @@ match_array_list (gfc_constructor_base *result) goto cleanup; /* Could be a complex constant */ } + tail->next = new_cons; + tail = new_cons; + if (gfc_match_char (',') != MATCH_YES) { if (n > 2) @@ -914,13 +991,19 @@ match_array_list (gfc_constructor_base *result) goto cleanup; } - e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->where = old_loc; e->value.constructor = head; - p = gfc_constructor_append_expr (result, e, &gfc_current_locus); + p = gfc_get_constructor (); + p->where = gfc_current_locus; p->iterator = gfc_get_iterator (); *p->iterator = iter; + p->expr = e; + *result = p; + return MATCH_YES; syntax: @@ -928,7 +1011,7 @@ syntax: m = MATCH_ERROR; cleanup: - gfc_constructor_free (head); + gfc_free_constructor (head); gfc_free_iterator (&iter, 0); gfc_current_locus = old_loc; return m; @@ -939,8 +1022,9 @@ cleanup: single expression or a list of elements. */ static match -match_array_cons_element (gfc_constructor_base *result) +match_array_cons_element (gfc_constructor **result) { + gfc_constructor *p; gfc_expr *expr; match m; @@ -952,7 +1036,11 @@ match_array_cons_element (gfc_constructor_base *result) if (m != MATCH_YES) return m; - gfc_constructor_append_expr (result, expr, &gfc_current_locus); + p = gfc_get_constructor (); + p->where = gfc_current_locus; + p->expr = expr; + + *result = p; return MATCH_YES; } @@ -962,7 +1050,7 @@ match_array_cons_element (gfc_constructor_base *result) match gfc_match_array_constructor (gfc_expr **result) { - gfc_constructor_base head, new_cons; + gfc_constructor *head, *tail, *new_cons; gfc_expr *expr; gfc_typespec ts; locus where; @@ -986,7 +1074,7 @@ gfc_match_array_constructor (gfc_expr **result) end_delim = " /)"; where = gfc_current_locus; - head = new_cons = NULL; + head = tail = NULL; seen_ts = false; /* Try to match an optional "type-spec ::" */ @@ -1018,12 +1106,19 @@ gfc_match_array_constructor (gfc_expr **result) for (;;) { - m = match_array_cons_element (&head); + m = match_array_cons_element (&new_cons); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; + if (head == NULL) + head = new_cons; + else + tail->next = new_cons; + + tail = new_cons; + if (gfc_match_char (',') == MATCH_NO) break; } @@ -1032,19 +1127,24 @@ gfc_match_array_constructor (gfc_expr **result) goto syntax; done: + expr = gfc_get_expr (); + + expr->expr_type = EXPR_ARRAY; + + expr->value.constructor = head; /* Size must be calculated at resolution time. */ + if (seen_ts) - { - expr = gfc_get_array_expr (ts.type, ts.kind, &where); - expr->ts = ts; - } + expr->ts = ts; else - expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); - - expr->value.constructor = head; + expr->ts.type = BT_UNKNOWN; + if (expr->ts.u.cl) expr->ts.u.cl->length_from_typespec = seen_ts; + expr->where = where; + expr->rank = 1; + *result = expr; return MATCH_YES; @@ -1052,7 +1152,7 @@ syntax: gfc_error ("Syntax error in array constructor at %C"); cleanup: - gfc_constructor_free (head); + gfc_free_constructor (head); return MATCH_ERROR; } @@ -1108,12 +1208,11 @@ check_element_type (gfc_expr *expr, bool convert) /* Recursive work function for gfc_check_constructor_type(). */ static gfc_try -check_constructor_type (gfc_constructor_base base, bool convert) +check_constructor_type (gfc_constructor *c, bool convert) { - gfc_constructor *c; gfc_expr *e; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + for (; c; c = c->next) { e = c->expr; @@ -1172,7 +1271,7 @@ cons_stack; static cons_stack *base; -static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *)); +static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *)); /* Check an EXPR_VARIABLE expression in a constructor to make sure that that variable is an iteration variables. */ @@ -1198,14 +1297,13 @@ gfc_check_iter_variable (gfc_expr *expr) constructor, giving variables with the names of iterators a pass. */ static gfc_try -check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *)) +check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *)) { cons_stack element; gfc_expr *e; gfc_try t; - gfc_constructor *c; - for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) + for (; c; c = c->next) { e = c->expr; @@ -1259,7 +1357,7 @@ iterator_stack *iter_stack; typedef struct { - gfc_constructor_base base; + gfc_constructor *new_head, *new_tail; int extract_count, extract_n; gfc_expr *extracted; mpz_t *count; @@ -1274,7 +1372,7 @@ expand_info; static expand_info current_expand; -static gfc_try expand_constructor (gfc_constructor_base); +static gfc_try expand_constructor (gfc_constructor *); /* Work function that counts the number of elements present in a @@ -1333,10 +1431,21 @@ extract_element (gfc_expr *e) static gfc_try expand (gfc_expr *e) { - gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base, - e, &e->where); + if (current_expand.new_head == NULL) + current_expand.new_head = current_expand.new_tail = + gfc_get_constructor (); + else + { + current_expand.new_tail->next = gfc_get_constructor (); + current_expand.new_tail = current_expand.new_tail->next; + } - c->n.component = current_expand.component; + current_expand.new_tail->where = e->where; + current_expand.new_tail->expr = e; + + mpz_set (current_expand.new_tail->n.offset, *current_expand.offset); + current_expand.new_tail->n.component = current_expand.component; + mpz_set (current_expand.new_tail->repeat, *current_expand.repeat); return SUCCESS; } @@ -1356,7 +1465,7 @@ gfc_simplify_iterator_var (gfc_expr *e) if (p == NULL) return; /* Variable not found */ - gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); + gfc_replace_expr (e, gfc_int_expr (0)); mpz_set (e->value.integer, p->value); @@ -1470,12 +1579,11 @@ cleanup: passed expression. */ static gfc_try -expand_constructor (gfc_constructor_base base) +expand_constructor (gfc_constructor *c) { - gfc_constructor *c; gfc_expr *e; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) + for (; c; c = c->next) { if (c->iterator != NULL) { @@ -1500,9 +1608,9 @@ expand_constructor (gfc_constructor_base base) gfc_free_expr (e); return FAILURE; } - current_expand.offset = &c->offset; - current_expand.repeat = &c->repeat; + current_expand.offset = &c->n.offset; current_expand.component = c->n.component; + current_expand.repeat = &c->repeat; if (current_expand.expand_work_function (e) == FAILURE) return FAILURE; } @@ -1510,39 +1618,6 @@ expand_constructor (gfc_constructor_base base) } -/* Given an array expression and an element number (starting at zero), - return a pointer to the array element. NULL is returned if the - size of the array has been exceeded. The expression node returned - remains a part of the array and should not be freed. Access is not - efficient at all, but this is another place where things do not - have to be particularly fast. */ - -static gfc_expr * -gfc_get_array_element (gfc_expr *array, int element) -{ - expand_info expand_save; - gfc_expr *e; - gfc_try rc; - - expand_save = current_expand; - current_expand.extract_n = element; - current_expand.expand_work_function = extract_element; - current_expand.extracted = NULL; - current_expand.extract_count = 0; - - iter_stack = NULL; - - rc = expand_constructor (array->value.constructor); - e = current_expand.extracted; - current_expand = expand_save; - - if (rc == FAILURE) - return NULL; - - return e; -} - - /* Top level subroutine for expanding constructors. We only expand constructor if they are small enough. */ @@ -1553,8 +1628,6 @@ gfc_expand_constructor (gfc_expr *e) gfc_expr *f; gfc_try rc; - /* If we can successfully get an array element at the max array size then - the array is too big to expand, so we just return. */ f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor); if (f != NULL) { @@ -1562,9 +1635,8 @@ gfc_expand_constructor (gfc_expr *e) return SUCCESS; } - /* We now know the array is not too big so go ahead and try to expand it. */ expand_save = current_expand; - current_expand.base = NULL; + current_expand.new_head = current_expand.new_tail = NULL; iter_stack = NULL; @@ -1572,13 +1644,13 @@ gfc_expand_constructor (gfc_expr *e) if (expand_constructor (e->value.constructor) == FAILURE) { - gfc_constructor_free (current_expand.base); + gfc_free_constructor (current_expand.new_head); rc = FAILURE; goto done; } - gfc_constructor_free (e->value.constructor); - e->value.constructor = current_expand.base; + gfc_free_constructor (e->value.constructor); + e->value.constructor = current_expand.new_head; rc = SUCCESS; @@ -1616,14 +1688,37 @@ gfc_constant_ac (gfc_expr *e) { expand_info expand_save; gfc_try rc; + gfc_constructor * con; + + rc = SUCCESS; - iter_stack = NULL; - expand_save = current_expand; - current_expand.expand_work_function = is_constant_element; + if (e->value.constructor + && e->value.constructor->expr->expr_type == EXPR_ARRAY) + { + /* Expand the constructor. */ + iter_stack = NULL; + expand_save = current_expand; + current_expand.expand_work_function = is_constant_element; - rc = expand_constructor (e->value.constructor); + rc = expand_constructor (e->value.constructor); + + current_expand = expand_save; + } + else + { + /* No need to expand this further. */ + for (con = e->value.constructor; con; con = con->next) + { + if (con->expr->expr_type == EXPR_CONSTANT) + continue; + else + { + if (!gfc_is_constant_expr (con->expr)) + rc = FAILURE; + } + } + } - current_expand = expand_save; if (rc == FAILURE) return 0; @@ -1637,12 +1732,11 @@ gfc_constant_ac (gfc_expr *e) int gfc_expanded_ac (gfc_expr *e) { - gfc_constructor *c; + gfc_constructor *p; if (e->expr_type == EXPR_ARRAY) - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - if (c->iterator != NULL || !gfc_expanded_ac (c->expr)) + for (p = e->value.constructor; p; p = p->next) + if (p->iterator != NULL || !gfc_expanded_ac (p->expr)) return 0; return 1; @@ -1655,20 +1749,19 @@ gfc_expanded_ac (gfc_expr *e) be of the same type. */ static gfc_try -resolve_array_list (gfc_constructor_base base) +resolve_array_list (gfc_constructor *p) { gfc_try t; - gfc_constructor *c; t = SUCCESS; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + for (; p; p = p->next) { - if (c->iterator != NULL - && gfc_resolve_iterator (c->iterator, false) == FAILURE) + if (p->iterator != NULL + && gfc_resolve_iterator (p->iterator, false) == FAILURE) t = FAILURE; - if (gfc_resolve_expr (c->expr) == FAILURE) + if (gfc_resolve_expr (p->expr) == FAILURE) t = FAILURE; } @@ -1691,8 +1784,7 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) if (expr->ts.u.cl == NULL) { - for (p = gfc_constructor_first (expr->value.constructor); - p; p = gfc_constructor_next (p)) + for (p = expr->value.constructor; p; p = p->next) if (p->expr->ts.u.cl != NULL) { /* Ensure that if there is a char_len around that it is @@ -1713,8 +1805,7 @@ got_charlen: /* Check that all constant string elements have the same length until we reach the end or find a variable-length one. */ - for (p = gfc_constructor_first (expr->value.constructor); - p; p = gfc_constructor_next (p)) + for (p = expr->value.constructor; p; p = p->next) { int current_length = -1; gfc_ref *ref; @@ -1761,8 +1852,7 @@ got_charlen: gcc_assert (found_length != -1); /* Update the character length of the array constructor. */ - expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, - NULL, found_length); + expr->ts.u.cl->length = gfc_int_expr (found_length); } else { @@ -1780,8 +1870,7 @@ got_charlen: (without typespec) all elements are verified to have the same length anyway. */ if (found_length != -1) - for (p = gfc_constructor_first (expr->value.constructor); - p; p = gfc_constructor_next (p)) + for (p = expr->value.constructor; p; p = p->next) if (p->expr->expr_type == EXPR_CONSTANT) { gfc_expr *cl = NULL; @@ -1831,8 +1920,8 @@ gfc_resolve_array_constructor (gfc_expr *expr) /* Copy an iterator structure. */ -gfc_iterator * -gfc_copy_iterator (gfc_iterator *src) +static gfc_iterator * +copy_iterator (gfc_iterator *src) { gfc_iterator *dest; @@ -1850,6 +1939,73 @@ gfc_copy_iterator (gfc_iterator *src) } +/* Copy a constructor structure. */ + +gfc_constructor * +gfc_copy_constructor (gfc_constructor *src) +{ + gfc_constructor *dest; + gfc_constructor *tail; + + if (src == NULL) + return NULL; + + dest = tail = NULL; + while (src) + { + if (dest == NULL) + dest = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + tail->where = src->where; + tail->expr = gfc_copy_expr (src->expr); + tail->iterator = copy_iterator (src->iterator); + mpz_set (tail->n.offset, src->n.offset); + tail->n.component = src->n.component; + mpz_set (tail->repeat, src->repeat); + src = src->next; + } + + return dest; +} + + +/* Given an array expression and an element number (starting at zero), + return a pointer to the array element. NULL is returned if the + size of the array has been exceeded. The expression node returned + remains a part of the array and should not be freed. Access is not + efficient at all, but this is another place where things do not + have to be particularly fast. */ + +gfc_expr * +gfc_get_array_element (gfc_expr *array, int element) +{ + expand_info expand_save; + gfc_expr *e; + gfc_try rc; + + expand_save = current_expand; + current_expand.extract_n = element; + current_expand.expand_work_function = extract_element; + current_expand.extracted = NULL; + current_expand.extract_count = 0; + + iter_stack = NULL; + + rc = expand_constructor (array->value.constructor); + e = current_expand.extracted; + current_expand = expand_save; + + if (rc == FAILURE) + return NULL; + + return e; +} + + /********* Subroutines for determining the size of an array *********/ /* These are needed just to accommodate RESHAPE(). There are no @@ -2223,8 +2379,7 @@ gfc_find_array_ref (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY - && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION - || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0))) + && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) break; if (ref == NULL)