X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Farray.c;h=a1449fd8c9e26631f03458eea14a72578b7ff2b9;hp=2cb349945624b7decacf7786398776c08b367702;hb=d480b22c79d1fb0ee6b6fdef9281446ef6391349;hpb=bd24f1786770f64eda7c2c6b60cdcf8a2e9d5e5f diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 2cb34994562..a1449fd8c9e 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1,12 +1,13 @@ /* Array things - Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later +Software Foundation; either version 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY @@ -15,28 +16,21 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA -02110-1301, USA. */ +along with GCC; see the file COPYING3. If not see +. */ #include "config.h" #include "system.h" #include "gfortran.h" #include "match.h" - -/* This parameter is the size of the largest array constructor that we - will expand to an array constructor without iterators. - Constructors larger than this will remain in the iterator form. */ - -#define GFC_MAX_AC_EXPAND 65535 - +#include "constructor.h" /**************** Array reference matching subroutines *****************/ /* Copy an array reference structure. */ gfc_array_ref * -gfc_copy_array_ref (gfc_array_ref * src) +gfc_copy_array_ref (gfc_array_ref *src) { gfc_array_ref *dest; int i; @@ -68,13 +62,15 @@ gfc_copy_array_ref (gfc_array_ref * src) expression. */ static match -match_subscript (gfc_array_ref * ar, int init) +match_subscript (gfc_array_ref *ar, int init, bool match_star) { - match m; + match m = MATCH_ERROR; + bool star = false; int i; - i = ar->dimen; + i = ar->dimen + ar->codimen; + gfc_gobble_whitespace (); ar->c_where[i] = gfc_current_locus; ar->start[i] = ar->end[i] = ar->stride[i] = NULL; @@ -88,25 +84,38 @@ match_subscript (gfc_array_ref * ar, int init) goto end_element; /* Get start element. */ - if (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + + if (!star && init) m = gfc_match_init_expr (&ar->start[i]); - else + else if (!star) m = gfc_match_expr (&ar->start[i]); - if (m == MATCH_NO) + if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES) + return MATCH_NO; + else if (m == MATCH_NO) gfc_error ("Expected array subscript at %C"); if (m != MATCH_YES) return MATCH_ERROR; if (gfc_match_char (':') == MATCH_NO) - return MATCH_YES; + goto matched; + + if (star) + { + gfc_error ("Unexpected '*' in coarray subscript at %C"); + return MATCH_ERROR; + } /* 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 (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + else if (init) m = gfc_match_init_expr (&ar->end[i]); else m = gfc_match_expr (&ar->end[i]); @@ -117,8 +126,14 @@ 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]); + : gfc_match_expr (&ar->stride[i]); if (m == MATCH_NO) gfc_error ("Expected array subscript stride at %C"); @@ -126,6 +141,10 @@ end_element: return MATCH_ERROR; } +matched: + if (star) + ar->dimen_type[i] = DIMEN_STAR; + return MATCH_YES; } @@ -135,14 +154,23 @@ end_element: to consist of init expressions. */ match -gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init) +gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, + int corank) { 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) { @@ -151,34 +179,95 @@ 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); + m = match_subscript (ar, init, false); if (m == MATCH_ERROR) - goto error; + return MATCH_ERROR; if (gfc_match_char (')') == MATCH_YES) - goto matched; + { + ar->dimen++; + goto coarray; + } if (gfc_match_char (',') != MATCH_YES) { gfc_error ("Invalid form of array reference at %C"); - goto error; + 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++; +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++; + if (ar->codimen < corank) + { + gfc_error ("Too few codimensions at %C, expected %d not %d", + corank, ar->codimen); + return MATCH_ERROR; + } + if (ar->codimen > corank) + { + gfc_error ("Too many codimensions at %C, expected %d not %d", + corank, ar->codimen); + return MATCH_ERROR; + } + return MATCH_YES; + } + + if (gfc_match_char (',') != MATCH_YES) + { + if (gfc_match_char ('*') == MATCH_YES) + gfc_error ("Unexpected '*' for codimension %d of %d at %C", + ar->codimen + 1, corank); + else + gfc_error ("Invalid form of coarray reference at %C"); + return MATCH_ERROR; + } + if (ar->codimen >= corank) + { + gfc_error ("Invalid codimension %d at %C, only %d codimensions exist", + ar->codimen + 1, corank); + return MATCH_ERROR; + } + } + + gfc_error ("Array reference at %C cannot have more than %d dimensions", + GFC_MAX_DIMENSIONS); + return MATCH_ERROR; - return MATCH_YES; } @@ -188,30 +277,29 @@ matched: specifications. */ void -gfc_free_array_spec (gfc_array_spec * as) +gfc_free_array_spec (gfc_array_spec *as) { int i; if (as == NULL) return; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { gfc_free_expr (as->lower[i]); gfc_free_expr (as->upper[i]); } - gfc_free (as); + free (as); } /* Take an array bound, resolves the expression, that make up the shape and check associated constraints. */ -static try -resolve_array_bound (gfc_expr * e, int check_constant) +static gfc_try +resolve_array_bound (gfc_expr *e, int check_constant) { - if (e == NULL) return SUCCESS; @@ -219,10 +307,14 @@ resolve_array_bound (gfc_expr * e, int check_constant) || gfc_specification_expr (e) == FAILURE) return FAILURE; - if (check_constant && gfc_is_constant_expr (e) == 0) + if (check_constant && !gfc_is_constant_expr (e)) { - gfc_error ("Variable '%s' at %L in this context must be constant", - e->symtree->n.sym->name, &e->where); + if (e->expr_type == EXPR_VARIABLE) + gfc_error ("Variable '%s' at %L in this context must be constant", + e->symtree->n.sym->name, &e->where); + else + gfc_error ("Expression at %L in this context must be constant", + &e->where); return FAILURE; } @@ -233,8 +325,8 @@ resolve_array_bound (gfc_expr * e, int check_constant) /* Takes an array specification, resolves the expressions that make up the shape and make sure everything is integral. */ -try -gfc_resolve_array_spec (gfc_array_spec * as, int check_constant) +gfc_try +gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) { gfc_expr *e; int i; @@ -242,7 +334,7 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant) if (as == NULL) return SUCCESS; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { e = as->lower[i]; if (resolve_array_bound (e, check_constant) == FAILURE) @@ -251,6 +343,21 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant) e = as->upper[i]; if (resolve_array_bound (e, check_constant) == FAILURE) return FAILURE; + + if ((as->lower[i] == NULL) || (as->upper[i] == NULL)) + continue; + + /* If the size is negative in this dimension, set it to zero. */ + if (as->lower[i]->expr_type == EXPR_CONSTANT + && as->upper[i]->expr_type == EXPR_CONSTANT + && mpz_cmp (as->upper[i]->value.integer, + as->lower[i]->value.integer) < 0) + { + gfc_free_expr (as->upper[i]); + as->upper[i] = gfc_copy_expr (as->lower[i]); + mpz_sub_ui (as->upper[i]->value.integer, + as->upper[i]->value.integer, 1); + } } return SUCCESS; @@ -263,14 +370,14 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant) individual specifications make sense as a whole. - Parsed Lower Upper Returned - ------------------------------------ - : NULL NULL AS_DEFERRED (*) - x 1 x AS_EXPLICIT - x: x NULL AS_ASSUMED_SHAPE - x:y x y AS_EXPLICIT - x:* x NULL AS_ASSUMED_SIZE - * 1 NULL AS_ASSUMED_SIZE + Parsed Lower Upper Returned + ------------------------------------ + : NULL NULL AS_DEFERRED (*) + x 1 x AS_EXPLICIT + x: x NULL AS_ASSUMED_SHAPE + x:y x y AS_EXPLICIT + x:* x NULL AS_ASSUMED_SIZE + * 1 NULL AS_ASSUMED_SIZE (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This is fixed during the resolution of formal interfaces. @@ -278,17 +385,17 @@ gfc_resolve_array_spec (gfc_array_spec * as, int check_constant) Anything else AS_UNKNOWN. */ static array_type -match_array_element_spec (gfc_array_spec * as) +match_array_element_spec (gfc_array_spec *as) { gfc_expr **upper, **lower; match m; - lower = &as->lower[as->rank - 1]; - upper = &as->upper[as->rank - 1]; + lower = &as->lower[as->rank + as->corank - 1]; + upper = &as->upper[as->rank + as->corank - 1]; if (gfc_match_char ('*') == MATCH_YES) { - *lower = gfc_int_expr (1); + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); return AS_ASSUMED_SIZE; } @@ -300,10 +407,12 @@ match_array_element_spec (gfc_array_spec * as) gfc_error ("Expected expression in array specification at %C"); if (m != MATCH_YES) return AS_UNKNOWN; + if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE) + return AS_UNKNOWN; if (gfc_match_char (':') == MATCH_NO) { - *lower = gfc_int_expr (1); + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); return AS_EXPLICIT; } @@ -318,41 +427,47 @@ match_array_element_spec (gfc_array_spec * as) return AS_UNKNOWN; if (m == MATCH_NO) return AS_ASSUMED_SHAPE; + if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE) + return AS_UNKNOWN; return AS_EXPLICIT; } /* Matches an array specification, incidentally figuring out what sort - it is. */ + it is. Match either a normal array specification, or a coarray spec + or both. Optionally allow [:] for coarrays. */ match -gfc_match_array_spec (gfc_array_spec ** asp) +gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) { array_type current_type; gfc_array_spec *as; int i; - if (gfc_match_char ('(') != MATCH_YES) - { - *asp = NULL; - return MATCH_NO; - } - as = gfc_get_array_spec (); - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + if (!match_dim) + goto coarray; + + if (gfc_match_char ('(') != MATCH_YES) { - as->lower[i] = NULL; - as->upper[i] = NULL; + if (!match_codim) + goto done; + goto coarray; } - as->rank = 1; - for (;;) { + as->rank++; current_type = match_array_element_spec (as); + /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size + and implied-shape specifications. If the rank is at least 2, we can + distinguish between them. But for rank 1, we currently return + ASSUMED_SIZE; this gets adjusted later when we know for sure + whether the symbol parsed is a PARAMETER or not. */ + if (as->rank == 1) { if (current_type == AS_UNKNOWN) @@ -361,10 +476,19 @@ gfc_match_array_spec (gfc_array_spec ** asp) } else switch (as->type) - { /* See how current spec meshes with the existing */ + { /* See how current spec meshes with the existing. */ case AS_UNKNOWN: goto cleanup; + case AS_IMPLIED_SHAPE: + if (current_type != AS_ASSUMED_SHAPE) + { + gfc_error ("Bad array specification for implied-shape" + " array at %C"); + goto cleanup; + } + break; + case AS_EXPLICIT: if (current_type == AS_ASSUMED_SIZE) { @@ -375,9 +499,8 @@ gfc_match_array_spec (gfc_array_spec ** asp) if (current_type == AS_EXPLICIT) break; - gfc_error - ("Bad array specification for an explicitly shaped array" - " at %C"); + gfc_error ("Bad array specification for an explicitly shaped " + "array at %C"); goto cleanup; @@ -386,8 +509,8 @@ gfc_match_array_spec (gfc_array_spec ** asp) || (current_type == AS_DEFERRED)) break; - gfc_error - ("Bad array specification for assumed shape array at %C"); + gfc_error ("Bad array specification for assumed shape " + "array at %C"); goto cleanup; case AS_DEFERRED: @@ -404,6 +527,12 @@ gfc_match_array_spec (gfc_array_spec ** asp) goto cleanup; case AS_ASSUMED_SIZE: + if (as->rank == 2 && current_type == AS_ASSUMED_SIZE) + { + as->type = AS_IMPLIED_SHAPE; + break; + } + gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; } @@ -417,26 +546,152 @@ gfc_match_array_spec (gfc_array_spec ** asp) goto cleanup; } - if (as->rank >= GFC_MAX_DIMENSIONS) + if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) { gfc_error ("Array specification at %C has more than %d dimensions", GFC_MAX_DIMENSIONS); goto cleanup; } - as->rank++; + if (as->corank + as->rank >= 7 + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array " + "specification at %C with more than 7 dimensions") + == FAILURE) + goto cleanup; + } + + if (!match_codim) + goto done; + +coarray: + if (gfc_match_char ('[') != MATCH_YES) + goto done; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C") + == FAILURE) + goto cleanup; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + goto cleanup; + } + + if (as->rank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d " + "dimensions", GFC_MAX_DIMENSIONS); + goto cleanup; + } + + for (;;) + { + as->corank++; + current_type = match_array_element_spec (as); + + if (current_type == AS_UNKNOWN) + goto cleanup; + + if (as->corank == 1) + as->cotype = current_type; + else + switch (as->cotype) + { /* See how current spec meshes with the existing. */ + case AS_IMPLIED_SHAPE: + case AS_UNKNOWN: + goto cleanup; + + case AS_EXPLICIT: + if (current_type == AS_ASSUMED_SIZE) + { + as->cotype = AS_ASSUMED_SIZE; + break; + } + + if (current_type == AS_EXPLICIT) + break; + + gfc_error ("Bad array specification for an explicitly " + "shaped array at %C"); + + goto cleanup; + + case AS_ASSUMED_SHAPE: + if ((current_type == AS_ASSUMED_SHAPE) + || (current_type == AS_DEFERRED)) + break; + + gfc_error ("Bad array specification for assumed shape " + "array at %C"); + goto cleanup; + + case AS_DEFERRED: + if (current_type == AS_DEFERRED) + break; + + if (current_type == AS_ASSUMED_SHAPE) + { + as->cotype = AS_ASSUMED_SHAPE; + break; + } + + gfc_error ("Bad specification for deferred shape array at %C"); + goto cleanup; + + case AS_ASSUMED_SIZE: + gfc_error ("Bad specification for assumed size array at %C"); + goto cleanup; + } + + if (gfc_match_char (']') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected another dimension in array declaration at %C"); + goto cleanup; + } + + if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d " + "dimensions", GFC_MAX_DIMENSIONS); + goto cleanup; + } + } + + if (current_type == AS_EXPLICIT) + { + gfc_error ("Upper bound of last coarray dimension must be '*' at %C"); + goto cleanup; + } + + if (as->cotype == AS_ASSUMED_SIZE) + as->cotype = AS_EXPLICIT; + + if (as->rank == 0) + as->type = as->cotype; + +done: + if (as->rank == 0 && as->corank == 0) + { + *asp = NULL; + gfc_free_array_spec (as); + return MATCH_NO; } /* If a lower bounds of an assumed shape array is blank, put in one. */ if (as->type == AS_ASSUMED_SHAPE) { - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { if (as->lower[i] == NULL) - as->lower[i] = gfc_int_expr (1); + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); } } + *asp = as; + return MATCH_YES; cleanup: @@ -450,18 +705,67 @@ cleanup: have that array specification. The error locus is needed in case something goes wrong. On failure, the caller must free the spec. */ -try -gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc) +gfc_try +gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) { + int i; if (as == NULL) return SUCCESS; - if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) + if (as->rank + && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) + return FAILURE; + + if (as->corank + && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE) return FAILURE; - sym->as = as; + if (sym->as == NULL) + { + sym->as = as; + return SUCCESS; + } + + if (as->corank) + { + /* The "sym" has no corank (checked via gfc_add_codimension). Thus + the codimension is simply added. */ + gcc_assert (as->rank == 0 && sym->as->corank == 0); + + sym->as->cotype = as->cotype; + sym->as->corank = as->corank; + for (i = 0; i < as->corank; i++) + { + sym->as->lower[sym->as->rank + i] = as->lower[i]; + sym->as->upper[sym->as->rank + i] = as->upper[i]; + } + } + else + { + /* The "sym" has no rank (checked via gfc_add_dimension). Thus + the dimension is added - but first the codimensions (if existing + need to be shifted to make space for the dimension. */ + gcc_assert (as->corank == 0 && sym->as->rank == 0); + + sym->as->rank = as->rank; + sym->as->type = as->type; + sym->as->cray_pointee = as->cray_pointee; + sym->as->cp_was_assumed = as->cp_was_assumed; + for (i = 0; i < sym->as->corank; i++) + { + sym->as->lower[as->rank + i] = sym->as->lower[i]; + sym->as->upper[as->rank + i] = sym->as->upper[i]; + } + for (i = 0; i < as->rank; i++) + { + sym->as->lower[i] = as->lower[i]; + sym->as->upper[i] = as->upper[i]; + } + } + + free (as); return SUCCESS; } @@ -469,7 +773,7 @@ gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc) /* Copy an array specification. */ gfc_array_spec * -gfc_copy_array_spec (gfc_array_spec * src) +gfc_copy_array_spec (gfc_array_spec *src) { gfc_array_spec *dest; int i; @@ -481,7 +785,7 @@ gfc_copy_array_spec (gfc_array_spec * src) *dest = *src; - for (i = 0; i < dest->rank; i++) + for (i = 0; i < dest->rank + dest->corank; i++) { dest->lower[i] = gfc_copy_expr (dest->lower[i]); dest->upper[i] = gfc_copy_expr (dest->upper[i]); @@ -490,11 +794,12 @@ gfc_copy_array_spec (gfc_array_spec * src) return dest; } + /* Returns nonzero if the two expressions are equal. Only handles integer constants. */ static int -compare_bounds (gfc_expr * bound1, gfc_expr * bound2) +compare_bounds (gfc_expr *bound1, gfc_expr *bound2) { if (bound1 == NULL || bound2 == NULL || bound1->expr_type != EXPR_CONSTANT @@ -509,11 +814,12 @@ compare_bounds (gfc_expr * bound1, gfc_expr * bound2) return 0; } + /* Compares two array specifications. They must be constant or deferred shape. */ int -gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2) +gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) { int i; @@ -526,6 +832,9 @@ gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2) if (as1->rank != as2->rank) return 0; + if (as1->corank != as2->corank) + return 0; + if (as1->rank == 0) return 1; @@ -533,7 +842,7 @@ gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2) return 0; if (as1->type == AS_EXPLICIT) - for (i = 0; i < as1->rank; i++) + for (i = 0; i < as1->rank + as1->corank; i++) { if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) return 0; @@ -548,150 +857,6 @@ 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) -{ - 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; - - if (new->ts.type != base->ts.type || new->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 = gfc_getmem (sizeof(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 @@ -699,11 +864,12 @@ gfc_free_constructor (gfc_constructor * p) duplicate was found. */ static int -check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master) +check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -716,9 +882,8 @@ check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master) if (c->iterator->var->symtree->n.sym == master) { - gfc_error - ("DO-iterator '%s' at %L is inside iterator of the same name", - master->name, &c->where); + gfc_error ("DO-iterator '%s' at %L is inside iterator of the " + "same name", master->name, &c->where); return 1; } @@ -729,14 +894,15 @@ check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master) /* Forward declaration because these functions are mutually recursive. */ -static match match_array_cons_element (gfc_constructor **); +static match match_array_cons_element (gfc_constructor_base *); /* Match a list of array elements. */ static match -match_array_list (gfc_constructor ** result) +match_array_list (gfc_constructor_base *result) { - gfc_constructor *p, *head, *tail, *new; + gfc_constructor_base head; + gfc_constructor *p; gfc_iterator iter; locus old_loc; gfc_expr *e; @@ -755,8 +921,6 @@ match_array_list (gfc_constructor ** result) if (m != MATCH_YES) goto cleanup; - tail = head; - if (gfc_match_char (',') != MATCH_YES) { m = MATCH_NO; @@ -771,7 +935,7 @@ match_array_list (gfc_constructor ** result) if (m == MATCH_ERROR) goto cleanup; - m = match_array_cons_element (&new); + m = match_array_cons_element (&head); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -782,9 +946,6 @@ match_array_list (gfc_constructor ** result) goto cleanup; /* Could be a complex constant */ } - tail->next = new; - tail = new; - if (gfc_match_char (',') != MATCH_YES) { if (n > 2) @@ -803,19 +964,13 @@ match_array_list (gfc_constructor ** result) goto cleanup; } - e = gfc_get_expr (); - e->expr_type = EXPR_ARRAY; - e->where = old_loc; + e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); e->value.constructor = head; - p = gfc_get_constructor (); - p->where = gfc_current_locus; + p = gfc_constructor_append_expr (result, e, &gfc_current_locus); p->iterator = gfc_get_iterator (); *p->iterator = iter; - p->expr = e; - *result = p; - return MATCH_YES; syntax: @@ -823,7 +978,7 @@ syntax: m = MATCH_ERROR; cleanup: - gfc_free_constructor (head); + gfc_constructor_free (head); gfc_free_iterator (&iter, 0); gfc_current_locus = old_loc; return m; @@ -834,9 +989,8 @@ cleanup: single expression or a list of elements. */ static match -match_array_cons_element (gfc_constructor ** result) +match_array_cons_element (gfc_constructor_base *result) { - gfc_constructor *p; gfc_expr *expr; match m; @@ -848,11 +1002,7 @@ match_array_cons_element (gfc_constructor ** result) if (m != MATCH_YES) return m; - p = gfc_get_constructor (); - p->where = gfc_current_locus; - p->expr = expr; - - *result = p; + gfc_constructor_append_expr (result, expr, &gfc_current_locus); return MATCH_YES; } @@ -860,53 +1010,77 @@ match_array_cons_element (gfc_constructor ** result) /* Match an array constructor. */ match -gfc_match_array_constructor (gfc_expr ** result) +gfc_match_array_constructor (gfc_expr **result) { - gfc_constructor *head, *tail, *new; + gfc_constructor_base head, new_cons; gfc_expr *expr; + gfc_typespec ts; locus where; match m; const char *end_delim; + bool seen_ts; if (gfc_match (" (/") == MATCH_NO) { if (gfc_match (" [") == MATCH_NO) - return MATCH_NO; + return MATCH_NO; else - { - if (gfc_notify_std (GFC_STD_F2003, "New in Fortran 2003: [...] " - "style array constructors at %C") == FAILURE) - return MATCH_ERROR; - end_delim = " ]"; - } + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] " + "style array constructors at %C") == FAILURE) + return MATCH_ERROR; + end_delim = " ]"; + } } else end_delim = " /)"; where = gfc_current_locus; - head = tail = NULL; + head = new_cons = NULL; + seen_ts = false; + + /* Try to match an optional "type-spec ::" */ + if (gfc_match_decl_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 (ts.deferred) + { + gfc_error ("Type-spec at %L cannot contain a deferred " + "type parameter", &where); + 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 (;;) { - m = match_array_cons_element (&new); + m = match_array_cons_element (&head); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; - if (head == NULL) - head = new; - else - tail->next = new; - - tail = new; - if (gfc_match_char (',') == MATCH_NO) break; } @@ -914,15 +1088,19 @@ gfc_match_array_constructor (gfc_expr ** result) if (gfc_match (end_delim) == MATCH_NO) goto syntax; - expr = gfc_get_expr (); - - expr->expr_type = EXPR_ARRAY; - - expr->value.constructor = head; +done: /* Size must be calculated at resolution time. */ + if (seen_ts) + { + expr = gfc_get_array_expr (ts.type, ts.kind, &where); + expr->ts = ts; + } + else + expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); - expr->where = where; - expr->rank = 1; + expr->value.constructor = head; + if (expr->ts.u.cl) + expr->ts.u.cl->length_from_typespec = seen_ts; *result = expr; return MATCH_YES; @@ -931,7 +1109,7 @@ syntax: gfc_error ("Syntax error in array constructor at %C"); cleanup: - gfc_free_constructor (head); + gfc_constructor_free (head); return MATCH_ERROR; } @@ -951,9 +1129,8 @@ 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 */ @@ -973,6 +1150,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)); @@ -984,24 +1164,25 @@ check_element_type (gfc_expr * expr) /* Recursive work function for gfc_check_constructor_type(). */ -static try -check_constructor_type (gfc_constructor * c) +static gfc_try +check_constructor_type (gfc_constructor_base base, bool convert) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { e = c->expr; 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; } @@ -1012,15 +1193,25 @@ check_constructor_type (gfc_constructor * c) /* Check that all elements of an array constructor are the same type. On FAILURE, an error has been generated. */ -try -gfc_check_constructor_type (gfc_expr * e) +gfc_try +gfc_check_constructor_type (gfc_expr *e) { - try t; + gfc_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; @@ -1038,21 +1229,20 @@ cons_stack; static cons_stack *base; -static try check_constructor (gfc_constructor *, try (*)(gfc_expr *)); +static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *)); /* Check an EXPR_VARIABLE expression in a constructor to make sure that that variable is an iteration variables. */ -try -gfc_check_iter_variable (gfc_expr * expr) +gfc_try +gfc_check_iter_variable (gfc_expr *expr) { - gfc_symbol *sym; cons_stack *c; sym = expr->symtree->n.sym; - for (c = base; c; c = c->previous) + for (c = base; c && c->iterator; c = c->previous) if (sym == c->iterator->var->symtree->n.sym) return SUCCESS; @@ -1064,14 +1254,15 @@ gfc_check_iter_variable (gfc_expr * expr) to calling the check function for each expression in the constructor, giving variables with the names of iterators a pass. */ -static try -check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *)) +static gfc_try +check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *)) { cons_stack element; gfc_expr *e; - try t; + gfc_try t; + gfc_constructor *c; - for (; c; c = c->next) + for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -1102,11 +1293,11 @@ check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *)) expression -- specification, restricted, or initialization as determined by the check_function. */ -try -gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *)) +gfc_try +gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *)) { cons_stack *base_save; - try t; + gfc_try t; base_save = base; base = NULL; @@ -1125,7 +1316,7 @@ iterator_stack *iter_stack; typedef struct { - gfc_constructor *new_head, *new_tail; + gfc_constructor_base base; int extract_count, extract_n; gfc_expr *extracted; mpz_t *count; @@ -1134,20 +1325,20 @@ typedef struct gfc_component *component; mpz_t *repeat; - try (*expand_work_function) (gfc_expr *); + gfc_try (*expand_work_function) (gfc_expr *); } expand_info; static expand_info current_expand; -static try expand_constructor (gfc_constructor *); +static gfc_try expand_constructor (gfc_constructor_base); /* Work function that counts the number of elements present in a constructor. */ -static try -count_elements (gfc_expr * e) +static gfc_try +count_elements (gfc_expr *e) { mpz_t result; @@ -1173,10 +1364,9 @@ count_elements (gfc_expr * e) /* Work function that extracts a particular element from an array constructor, freeing the rest. */ -static try -extract_element (gfc_expr * e) +static gfc_try +extract_element (gfc_expr *e) { - if (e->rank != 0) { /* Something unextractable */ gfc_free_expr (e); @@ -1189,6 +1379,7 @@ extract_element (gfc_expr * e) gfc_free_expr (e); current_expand.extract_count++; + return SUCCESS; } @@ -1196,25 +1387,13 @@ extract_element (gfc_expr * e) /* Work function that constructs a new constructor out of the old one, stringing new elements together. */ -static try -expand (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; - } - - 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); + c->n.component = current_expand.component; return SUCCESS; } @@ -1223,7 +1402,7 @@ expand (gfc_expr * e) substitute the current value of the iteration variable. */ void -gfc_simplify_iterator_var (gfc_expr * e) +gfc_simplify_iterator_var (gfc_expr *e) { iterator_stack *p; @@ -1234,7 +1413,7 @@ gfc_simplify_iterator_var (gfc_expr * e) if (p == NULL) return; /* Variable not found */ - gfc_replace_expr (e, gfc_int_expr (0)); + gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); mpz_set (e->value.integer, p->value); @@ -1245,10 +1424,9 @@ gfc_simplify_iterator_var (gfc_expr * e) /* Expand an expression with that is inside of a constructor, recursing into other constructors if present. */ -static try -expand_expr (gfc_expr * e) +static gfc_try +expand_expr (gfc_expr *e) { - if (e->expr_type == EXPR_ARRAY) return expand_constructor (e->value.constructor); @@ -1264,13 +1442,13 @@ expand_expr (gfc_expr * e) } -static try -expand_iterator (gfc_constructor * c) +static gfc_try +expand_iterator (gfc_constructor *c) { gfc_expr *start, *end, *step; iterator_stack frame; mpz_t trip; - try t; + gfc_try t; end = step = NULL; @@ -1278,6 +1456,7 @@ expand_iterator (gfc_constructor * c) mpz_init (trip); mpz_init (frame.value); + frame.prev = NULL; start = gfc_copy_expr (c->iterator->start); if (gfc_simplify_expr (start, 1) == FAILURE) @@ -1347,12 +1526,13 @@ cleanup: expressions. The work function needs to either save or free the passed expression. */ -static try -expand_constructor (gfc_constructor * c) +static gfc_try +expand_constructor (gfc_constructor_base base) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) { if (c->iterator != NULL) { @@ -1377,9 +1557,9 @@ expand_constructor (gfc_constructor * c) gfc_free_expr (e); return FAILURE; } - current_expand.offset = &c->n.offset; - current_expand.component = c->n.component; + current_expand.offset = &c->offset; current_expand.repeat = &c->repeat; + current_expand.component = c->n.component; if (current_expand.expand_work_function (e) == FAILURE) return FAILURE; } @@ -1387,25 +1567,70 @@ expand_constructor (gfc_constructor * c) } +/* 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. */ -try -gfc_expand_constructor (gfc_expr * e) +gfc_try +gfc_expand_constructor (gfc_expr *e, bool fatal) { expand_info expand_save; gfc_expr *f; - try rc; + gfc_try rc; - f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND); + /* 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) { gfc_free_expr (f); + if (fatal) + { + gfc_error ("The number of elements in the array constructor " + "at %L requires an increase of the allowed %d " + "upper limit. See -fmax-array-constructor " + "option", &e->where, + gfc_option.flag_max_array_constructor); + return FAILURE; + } 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.new_head = current_expand.new_tail = NULL; + current_expand.base = NULL; iter_stack = NULL; @@ -1413,13 +1638,13 @@ gfc_expand_constructor (gfc_expr * e) if (expand_constructor (e->value.constructor) == FAILURE) { - gfc_free_constructor (current_expand.new_head); + gfc_constructor_free (current_expand.base); rc = FAILURE; goto done; } - gfc_free_constructor (e->value.constructor); - e->value.constructor = current_expand.new_head; + gfc_constructor_free (e->value.constructor); + e->value.constructor = current_expand.base; rc = SUCCESS; @@ -1434,8 +1659,8 @@ done: constant, after removal of any iteration variables. We return FAILURE if not so. */ -static try -constant_element (gfc_expr * e) +static gfc_try +is_constant_element (gfc_expr *e) { int rv; @@ -1453,14 +1678,14 @@ constant_element (gfc_expr * e) function that traverses the expression tree. FIXME. */ int -gfc_constant_ac (gfc_expr * e) +gfc_constant_ac (gfc_expr *e) { expand_info expand_save; - try rc; + gfc_try rc; iter_stack = NULL; expand_save = current_expand; - current_expand.expand_work_function = constant_element; + current_expand.expand_work_function = is_constant_element; rc = expand_constructor (e->value.constructor); @@ -1476,13 +1701,14 @@ gfc_constant_ac (gfc_expr * e) expanded (no iterators) and zero if iterators are present. */ int -gfc_expanded_ac (gfc_expr * e) +gfc_expanded_ac (gfc_expr *e) { - gfc_constructor *p; + gfc_constructor *c; if (e->expr_type == EXPR_ARRAY) - for (p = e->value.constructor; p; p = p->next) - if (p->iterator != NULL || !gfc_expanded_ac (p->expr)) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->iterator != NULL || !gfc_expanded_ac (c->expr)) return 0; return 1; @@ -1494,81 +1720,176 @@ gfc_expanded_ac (gfc_expr * e) /* Recursive array list resolution function. All of the elements must be of the same type. */ -static try -resolve_array_list (gfc_constructor * p) +static gfc_try +resolve_array_list (gfc_constructor_base base) { - try t; + gfc_try t; + gfc_constructor *c; t = SUCCESS; - for (; p; p = p->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { - if (p->iterator != NULL - && gfc_resolve_iterator (p->iterator, false) == FAILURE) + if (c->iterator != NULL + && gfc_resolve_iterator (c->iterator, false) == FAILURE) t = FAILURE; - if (gfc_resolve_expr (p->expr) == FAILURE) + if (gfc_resolve_expr (c->expr) == FAILURE) t = FAILURE; } return t; } -/* 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. */ +/* Resolve character array constructor. If it has a specified constant character + length, pad/truncate the elements here; if the length is not specified and + all elements are of compile-time known length, emit an error as this is + invalid. */ -static void -resolve_character_array_constructor (gfc_expr * expr) +gfc_try +gfc_resolve_character_array_constructor (gfc_expr *expr) { - gfc_constructor * p; - int max_length; + gfc_constructor *p; + int found_length; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); - max_length = -1; - - if (expr->ts.cl == NULL) + if (expr->ts.u.cl == NULL) { - expr->ts.cl = gfc_get_charlen (); - expr->ts.cl->next = gfc_current_ns->cl_list; - gfc_current_ns->cl_list = expr->ts.cl; + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) + if (p->expr->ts.u.cl != NULL) + { + /* Ensure that if there is a char_len around that it is + used; otherwise the middle-end confuses them! */ + expr->ts.u.cl = p->expr->ts.u.cl; + goto got_charlen; + } + + expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); } - if (expr->ts.cl->length == NULL) +got_charlen: + + found_length = -1; + + if (expr->ts.u.cl->length == NULL) { - /* Find the maximum length of the elements. Do nothing for variable array - constructor. */ - for (p = expr->value.constructor; p; p = p->next) - if (p->expr->expr_type == EXPR_CONSTANT) - max_length = MAX (p->expr->value.character.length, max_length); - else - return; - - if (max_length != -1) + /* 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)) { - /* 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) - gfc_set_constant_character_len (max_length, p->expr); + int current_length = -1; + gfc_ref *ref; + for (ref = p->expr->ref; ref; ref = ref->next) + if (ref->type == REF_SUBSTRING + && ref->u.ss.start->expr_type == EXPR_CONSTANT + && ref->u.ss.end->expr_type == EXPR_CONSTANT) + break; + + if (p->expr->expr_type == EXPR_CONSTANT) + current_length = p->expr->value.character.length; + else if (ref) + { + long j; + j = mpz_get_ui (ref->u.ss.end->value.integer) + - mpz_get_ui (ref->u.ss.start->value.integer) + 1; + current_length = (int) j; + } + else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length + && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) + { + long j; + j = mpz_get_si (p->expr->ts.u.cl->length->value.integer); + current_length = (int) j; + } + else + return SUCCESS; + + gcc_assert (current_length != -1); + + if (found_length == -1) + found_length = current_length; + else if (found_length != current_length) + { + gfc_error ("Different CHARACTER lengths (%d/%d) in array" + " constructor at %L", found_length, current_length, + &p->expr->where); + return FAILURE; + } + + gcc_assert (found_length == current_length); } + + 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); + } + else + { + /* We've got a character length specified. It should be an integer, + otherwise an error is signalled elsewhere. */ + gcc_assert (expr->ts.u.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.u.cl->length, &found_length); + + /* Now pad/truncate the elements accordingly to the specified character + length. This is ok inside this conditional, as in the case above + (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)) + if (p->expr->expr_type == EXPR_CONSTANT) + { + gfc_expr *cl = NULL; + int current_length = -1; + bool has_ts; + + if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + { + cl = p->expr->ts.u.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. */ + + has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec); + + if (! cl + || (current_length != -1 && current_length != found_length)) + gfc_set_constant_character_len (found_length, p->expr, + has_ts ? -1 : found_length); + } } + + return SUCCESS; } + /* Resolve all of the expressions in an array list. */ -try -gfc_resolve_array_constructor (gfc_expr * expr) +gfc_try +gfc_resolve_array_constructor (gfc_expr *expr) { - try t; + gfc_try t; t = resolve_array_list (expr->value.constructor); if (t == SUCCESS) t = gfc_check_constructor_type (expr); - if (t == SUCCESS && expr->ts.type == BT_CHARACTER) - resolve_character_array_constructor (expr); + + /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after + the call to this function, so we don't need to call it here; if it was + called twice, an error message there would be duplicated. */ return t; } @@ -1576,8 +1897,8 @@ gfc_resolve_array_constructor (gfc_expr * expr) /* Copy an iterator structure. */ -static gfc_iterator * -copy_iterator (gfc_iterator * src) +gfc_iterator * +gfc_copy_iterator (gfc_iterator *src) { gfc_iterator *dest; @@ -1595,73 +1916,6 @@ 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; - 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 @@ -1672,10 +1926,9 @@ gfc_get_array_element (gfc_expr * array, int element) /* Get the size of single dimension of an array specification. The array is guaranteed to be one dimensional. */ -static try -spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result) +gfc_try +spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) { - if (as == NULL) return FAILURE; @@ -1684,7 +1937,9 @@ spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result) if (as->type != AS_EXPLICIT || as->lower[dimen]->expr_type != EXPR_CONSTANT - || as->upper[dimen]->expr_type != EXPR_CONSTANT) + || as->upper[dimen]->expr_type != EXPR_CONSTANT + || as->lower[dimen]->ts.type != BT_INTEGER + || as->upper[dimen]->ts.type != BT_INTEGER) return FAILURE; mpz_init (*result); @@ -1698,8 +1953,8 @@ spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result) } -try -spec_size (gfc_array_spec * as, mpz_t * result) +gfc_try +spec_size (gfc_array_spec *as, mpz_t *result) { mpz_t size; int d; @@ -1722,16 +1977,17 @@ spec_size (gfc_array_spec * as, mpz_t * result) } -/* Get the number of elements in an array section. */ +/* Get the number of elements in an array section. Optionally, also supply + the end value. */ -static try -ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result) +gfc_try +gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end) { mpz_t upper, lower, stride; - try t; + gfc_try t; if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1) - gfc_internal_error ("ref_dimen_size(): Bad dimension"); + gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension"); switch (ar->dimen_type[dimen]) { @@ -1798,6 +2054,15 @@ ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result) mpz_set_ui (*result, 0); t = SUCCESS; + if (end) + { + mpz_init (*end); + + mpz_sub_ui (*end, *result, 1UL); + mpz_mul (*end, *end, stride); + mpz_add (*end, *end, lower); + } + cleanup: mpz_clear (upper); mpz_clear (lower); @@ -1805,15 +2070,15 @@ ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result) return t; default: - gfc_internal_error ("ref_dimen_size(): Bad dimen_type"); + gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type"); } return t; } -static try -ref_size (gfc_array_ref * ar, mpz_t * result) +static gfc_try +ref_size (gfc_array_ref *ar, mpz_t *result) { mpz_t size; int d; @@ -1822,7 +2087,7 @@ ref_size (gfc_array_ref * ar, mpz_t * result) for (d = 0; d < ar->dimen; d++) { - if (ref_dimen_size (ar, d, &size) == FAILURE) + if (gfc_ref_dimen_size (ar, d, &size, NULL) == FAILURE) { mpz_clear (*result); return FAILURE; @@ -1841,8 +2106,8 @@ ref_size (gfc_array_ref * ar, mpz_t * result) able to return a result in the 'result' variable, FAILURE otherwise. */ -try -gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result) +gfc_try +gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) { gfc_ref *ref; int i; @@ -1868,7 +2133,7 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result) if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) dimen--; - return ref_dimen_size (&ref->u.ar, i - 1, result); + return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL); } } @@ -1878,7 +2143,15 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result) return SUCCESS; } - if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE) + if (array->symtree->n.sym->attr.generic + && array->value.function.esym != NULL) + { + if (spec_dimen_size (array->value.function.esym->as, dimen, result) + == FAILURE) + return FAILURE; + } + else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) + == FAILURE) return FAILURE; break; @@ -1909,19 +2182,18 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result) array. Returns SUCCESS if this is possible, and sets the 'result' variable. Otherwise returns FAILURE. */ -try -gfc_array_size (gfc_expr * array, mpz_t * result) +gfc_try +gfc_array_size (gfc_expr *array, mpz_t *result) { expand_info expand_save; gfc_ref *ref; - int i, flag; - try t; + int i; + gfc_try t; switch (array->expr_type) { case EXPR_ARRAY: - flag = gfc_suppress_error; - gfc_suppress_error = 1; + gfc_push_suppress_errors (); expand_save = current_expand; @@ -1932,7 +2204,8 @@ gfc_array_size (gfc_expr * array, mpz_t * result) iter_stack = NULL; t = expand_constructor (array->value.constructor); - gfc_suppress_error = flag; + + gfc_pop_suppress_errors (); if (t == FAILURE) mpz_clear (*result); @@ -1974,8 +2247,8 @@ gfc_array_size (gfc_expr * array, mpz_t * result) /* Given an array reference, return the shape of the reference in an array of mpz_t integers. */ -try -gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape) +gfc_try +gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) { int d; int i; @@ -1996,7 +2269,7 @@ gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape) { if (ar->dimen_type[i] != DIMEN_ELEMENT) { - if (ref_dimen_size (ar, i, &shape[d]) == FAILURE) + if (gfc_ref_dimen_size (ar, i, &shape[d], NULL) == FAILURE) goto cleanup; d++; } @@ -2009,9 +2282,7 @@ gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape) } cleanup: - for (d--; d >= 0; d--) - mpz_clear (shape[d]); - + gfc_clear_shape (shape, d); return FAILURE; } @@ -2020,14 +2291,13 @@ cleanup: characterizes the reference. */ gfc_array_ref * -gfc_find_array_ref (gfc_expr * e) +gfc_find_array_ref (gfc_expr *e) { gfc_ref *ref; 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_FULL || ref->u.ar.type == AR_SECTION)) break; if (ref == NULL)