diff options
Diffstat (limited to 'gcc/fortran/array.c')
| -rw-r--r-- | gcc/fortran/array.c | 2785 |
1 files changed, 0 insertions, 2785 deletions
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c deleted file mode 100644 index 4723043..0000000 --- a/gcc/fortran/array.c +++ /dev/null @@ -1,2785 +0,0 @@ -/* Array things - Copyright (C) 2000-2022 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 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -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 COPYING3. If not see -<http://www.gnu.org/licenses/>. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "parse.h" -#include "match.h" -#include "constructor.h" - -/**************** Array reference matching subroutines *****************/ - -/* Copy an array reference structure. */ - -gfc_array_ref * -gfc_copy_array_ref (gfc_array_ref *src) -{ - gfc_array_ref *dest; - int i; - - if (src == NULL) - return NULL; - - dest = gfc_get_array_ref (); - - *dest = *src; - - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) - { - dest->start[i] = gfc_copy_expr (src->start[i]); - dest->end[i] = gfc_copy_expr (src->end[i]); - dest->stride[i] = gfc_copy_expr (src->stride[i]); - } - - return dest; -} - - -/* Match a single dimension of an array reference. This can be a - single element or an array section. Any modifications we've made - to the ar structure are cleaned up by the caller. If the init - is set, we require the subscript to be a valid initialization - expression. */ - -static match -match_subscript (gfc_array_ref *ar, int init, bool match_star) -{ - match m = MATCH_ERROR; - bool star = false; - int i; - bool saw_boz = false; - - 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; - - /* We can't be sure of the difference between DIMEN_ELEMENT and - DIMEN_VECTOR until we know the type of the element itself at - resolution time. */ - - ar->dimen_type[i] = DIMEN_UNKNOWN; - - if (gfc_match_char (':') == MATCH_YES) - goto end_element; - - /* Get start element. */ - if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) - star = true; - - if (!star && init) - m = gfc_match_init_expr (&ar->start[i]); - else if (!star) - m = gfc_match_expr (&ar->start[i]); - - if (ar->start[i] && ar->start[i]->ts.type == BT_BOZ) - { - gfc_error ("Invalid BOZ literal constant used in subscript at %C"); - saw_boz = true; - } - - if (m == MATCH_NO) - gfc_error ("Expected array subscript at %C"); - if (m != MATCH_YES) - return MATCH_ERROR; - - if (gfc_match_char (':') == MATCH_NO) - 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 (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]); - - if (ar->end[i] && ar->end[i]->ts.type == BT_BOZ) - { - gfc_error ("Invalid BOZ literal constant used in subscript at %C"); - saw_boz = true; - } - - if (m == MATCH_ERROR) - return MATCH_ERROR; - - /* 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]); - - if (ar->stride[i] && ar->stride[i]->ts.type == BT_BOZ) - { - gfc_error ("Invalid BOZ literal constant used in subscript at %C"); - saw_boz = true; - } - - if (m == MATCH_NO) - gfc_error ("Expected array subscript stride at %C"); - if (m != MATCH_YES) - return MATCH_ERROR; - } - -matched: - if (star) - ar->dimen_type[i] = DIMEN_STAR; - - return (saw_boz ? MATCH_ERROR : MATCH_YES); -} - - -/* Match an array reference, whether it is the whole array or particular - elements or a section. If init is set, the reference has to consist - of init expressions. */ - -match -gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, - int corank) -{ - match m; - bool matched_bracket = false; - gfc_expr *tmp; - bool stat_just_seen = false; - bool team_just_seen = 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) - { - ar->type = AR_FULL; - ar->dimen = 0; - return MATCH_YES; - } - - for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) - { - m = match_subscript (ar, init, false); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match_char (')') == MATCH_YES) - { - ar->dimen++; - goto coarray; - } - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Invalid form of array reference at %C"); - return MATCH_ERROR; - } - } - - if (ar->dimen >= 7 - && !gfc_notify_std (GFC_STD_F2008, - "Array reference at %C has more than 7 dimensions")) - return MATCH_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 (flag_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; - } - - ar->stat = NULL; - - for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) - { - m = match_subscript (ar, init, true); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - team_just_seen = false; - stat_just_seen = false; - if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL) - { - ar->team = tmp; - team_just_seen = true; - } - - if (ar->team && !team_just_seen) - { - gfc_error ("TEAM= attribute in %C misplaced"); - return MATCH_ERROR; - } - - if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL) - { - ar->stat = tmp; - stat_just_seen = true; - } - - if (ar->stat && !stat_just_seen) - { - gfc_error ("STAT= attribute in %C misplaced"); - 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; - } - else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR) - { - gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", - ar->codimen + 1, corank); - 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; - -} - - -/************** Array specification matching subroutines ***************/ - -/* Free all of the expressions associated with array bounds - specifications. */ - -void -gfc_free_array_spec (gfc_array_spec *as) -{ - int i; - - if (as == NULL) - return; - - if (as->corank == 0) - { - for (i = 0; i < as->rank; i++) - { - gfc_free_expr (as->lower[i]); - gfc_free_expr (as->upper[i]); - } - } - else - { - int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0); - for (i = 0; i < n; i++) - { - gfc_free_expr (as->lower[i]); - gfc_free_expr (as->upper[i]); - } - } - - free (as); -} - - -/* Take an array bound, resolves the expression, that make up the - shape and check associated constraints. */ - -static bool -resolve_array_bound (gfc_expr *e, int check_constant) -{ - if (e == NULL) - return true; - - if (!gfc_resolve_expr (e) - || !gfc_specification_expr (e)) - return false; - - if (check_constant && !gfc_is_constant_expr (e)) - { - if (e->expr_type == EXPR_VARIABLE) - gfc_error ("Variable %qs 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 false; - } - - return true; -} - - -/* Takes an array specification, resolves the expressions that make up - the shape and make sure everything is integral. */ - -bool -gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) -{ - gfc_expr *e; - int i; - - if (as == NULL) - return true; - - if (as->resolved) - return true; - - for (i = 0; i < as->rank + as->corank; i++) - { - if (i == GFC_MAX_DIMENSIONS) - return false; - - e = as->lower[i]; - if (!resolve_array_bound (e, check_constant)) - return false; - - e = as->upper[i]; - if (!resolve_array_bound (e, check_constant)) - return false; - - 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); - } - } - - as->resolved = true; - - return true; -} - - -/* Match a single array element specification. The return values as - well as the upper and lower bounds of the array spec are filled - in according to what we see on the input. The caller makes sure - 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 - - (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This - is fixed during the resolution of formal interfaces. - - Anything else AS_UNKNOWN. */ - -static array_type -match_array_element_spec (gfc_array_spec *as) -{ - gfc_expr **upper, **lower; - match m; - int rank; - - rank = as->rank == -1 ? 0 : as->rank; - lower = &as->lower[rank + as->corank - 1]; - upper = &as->upper[rank + as->corank - 1]; - - if (gfc_match_char ('*') == MATCH_YES) - { - *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - return AS_ASSUMED_SIZE; - } - - if (gfc_match_char (':') == MATCH_YES) - return AS_DEFERRED; - - m = gfc_match_expr (upper); - if (m == MATCH_NO) - 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)) - return AS_UNKNOWN; - - gfc_try_simplify_expr (*upper, 0); - - if (((*upper)->expr_type == EXPR_CONSTANT - && (*upper)->ts.type != BT_INTEGER) || - ((*upper)->expr_type == EXPR_FUNCTION - && (*upper)->ts.type == BT_UNKNOWN - && (*upper)->symtree - && strcmp ((*upper)->symtree->name, "null") == 0)) - { - gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", - gfc_basic_typename ((*upper)->ts.type)); - return AS_UNKNOWN; - } - - if (gfc_match_char (':') == MATCH_NO) - { - *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - return AS_EXPLICIT; - } - - *lower = *upper; - *upper = NULL; - - if (gfc_match_char ('*') == MATCH_YES) - return AS_ASSUMED_SIZE; - - m = gfc_match_expr (upper); - if (m == MATCH_ERROR) - return AS_UNKNOWN; - if (m == MATCH_NO) - return AS_ASSUMED_SHAPE; - if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) - return AS_UNKNOWN; - - gfc_try_simplify_expr (*upper, 0); - - if (((*upper)->expr_type == EXPR_CONSTANT - && (*upper)->ts.type != BT_INTEGER) || - ((*upper)->expr_type == EXPR_FUNCTION - && (*upper)->ts.type == BT_UNKNOWN - && (*upper)->symtree - && strcmp ((*upper)->symtree->name, "null") == 0)) - { - gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", - gfc_basic_typename ((*upper)->ts.type)); - return AS_UNKNOWN; - } - - return AS_EXPLICIT; -} - - -/* Matches an array specification, incidentally figuring out what sort - 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, bool match_dim, bool match_codim) -{ - array_type current_type; - gfc_array_spec *as; - int i; - - as = gfc_get_array_spec (); - - if (!match_dim) - goto coarray; - - if (gfc_match_char ('(') != MATCH_YES) - { - if (!match_codim) - goto done; - goto coarray; - } - - if (gfc_match (" .. )") == MATCH_YES) - { - as->type = AS_ASSUMED_RANK; - as->rank = -1; - - if (!gfc_notify_std (GFC_STD_F2018, "Assumed-rank array at %C")) - goto cleanup; - - if (!match_codim) - goto done; - goto coarray; - } - - 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) - goto cleanup; - as->type = current_type; - } - else - switch (as->type) - { /* See how current spec meshes with the existing. */ - case AS_UNKNOWN: - goto cleanup; - - case AS_IMPLIED_SHAPE: - if (current_type != AS_ASSUMED_SIZE) - { - gfc_error ("Bad array specification for implied-shape" - " array at %C"); - goto cleanup; - } - break; - - case AS_EXPLICIT: - if (current_type == AS_ASSUMED_SIZE) - { - as->type = 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->type = AS_ASSUMED_SHAPE; - break; - } - - gfc_error ("Bad specification for deferred shape array at %C"); - 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; - - case AS_ASSUMED_RANK: - gcc_unreachable (); - } - - 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 (as->corank + as->rank >= 7 - && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C " - "with more than 7 dimensions")) - goto cleanup; - } - - if (!match_codim) - goto done; - -coarray: - if (gfc_match_char ('[') != MATCH_YES) - goto done; - - if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C")) - goto cleanup; - - if (flag_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; - - case AS_ASSUMED_RANK: - gcc_unreachable (); - } - - 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 + as->corank; i++) - { - if (as->lower[i] == NULL) - as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - } - } - - *asp = as; - - return MATCH_YES; - -cleanup: - /* Something went wrong. */ - gfc_free_array_spec (as); - return MATCH_ERROR; -} - -/* Given a symbol and an array specification, modify the symbol to - have that array specification. The error locus is needed in case - something goes wrong. On failure, the caller must free the spec. */ - -bool -gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) -{ - int i; - symbol_attribute *attr; - - if (as == NULL) - return true; - - /* If the symbol corresponds to a submodule module procedure the array spec is - already set, so do not attempt to set it again here. */ - attr = &sym->attr; - if (gfc_submodule_procedure(attr)) - return true; - - if (as->rank - && !gfc_add_dimension (&sym->attr, sym->name, error_loc)) - return false; - - if (as->corank - && !gfc_add_codimension (&sym->attr, sym->name, error_loc)) - return false; - - if (sym->as == NULL) - { - sym->as = as; - return true; - } - - if ((sym->as->type == AS_ASSUMED_RANK && as->corank) - || (as->type == AS_ASSUMED_RANK && sym->as->corank)) - { - gfc_error ("The assumed-rank array %qs at %L shall not have a " - "codimension", sym->name, error_loc); - return false; - } - - /* Check F2018:C822. */ - if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) - goto too_many; - - if (as->corank) - { - sym->as->cotype = as->cotype; - sym->as->corank = as->corank; - /* Check F2018:C822. */ - if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) - goto too_many; - - 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; - - /* Check F2018:C822. */ - if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) - goto too_many; - - for (i = sym->as->corank - 1; i >= 0; 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 true; - -too_many: - - gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name, - GFC_MAX_DIMENSIONS); - return false; -} - - -/* Copy an array specification. */ - -gfc_array_spec * -gfc_copy_array_spec (gfc_array_spec *src) -{ - gfc_array_spec *dest; - int i; - - if (src == NULL) - return NULL; - - dest = gfc_get_array_spec (); - - *dest = *src; - - 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]); - } - - return dest; -} - - -/* Returns nonzero if the two expressions are equal. Only handles integer - constants. */ - -static int -compare_bounds (gfc_expr *bound1, gfc_expr *bound2) -{ - if (bound1 == NULL || bound2 == NULL - || bound1->expr_type != EXPR_CONSTANT - || bound2->expr_type != EXPR_CONSTANT - || bound1->ts.type != BT_INTEGER - || bound2->ts.type != BT_INTEGER) - gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered"); - - if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0) - return 1; - else - 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) -{ - int i; - - if (as1 == NULL && as2 == NULL) - return 1; - - if (as1 == NULL || as2 == NULL) - return 0; - - if (as1->rank != as2->rank) - return 0; - - if (as1->corank != as2->corank) - return 0; - - if (as1->rank == 0) - return 1; - - if (as1->type != as2->type) - return 0; - - if (as1->type == AS_EXPLICIT) - for (i = 0; i < as1->rank + as1->corank; i++) - { - if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) - return 0; - - if (compare_bounds (as1->upper[i], as2->upper[i]) == 0) - return 0; - } - - return 1; -} - - -/****************** Array constructor functions ******************/ - - -/* Given an expression node that might be an array constructor and a - symbol, make sure that no iterators in this or child constructors - use the symbol as an implied-DO iterator. Returns nonzero if a - duplicate was found. */ - -static int -check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) -{ - gfc_constructor *c; - gfc_expr *e; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - e = c->expr; - - if (e->expr_type == EXPR_ARRAY - && check_duplicate_iterator (e->value.constructor, master)) - return 1; - - if (c->iterator == NULL) - continue; - - if (c->iterator->var->symtree->n.sym == master) - { - gfc_error ("DO-iterator %qs at %L is inside iterator of the " - "same name", master->name, &c->where); - - return 1; - } - } - - return 0; -} - - -/* Forward declaration because these functions are mutually recursive. */ -static match match_array_cons_element (gfc_constructor_base *); - -/* Match a list of array elements. */ - -static match -match_array_list (gfc_constructor_base *result) -{ - gfc_constructor_base head; - gfc_constructor *p; - gfc_iterator iter; - locus old_loc; - gfc_expr *e; - match m; - int n; - - old_loc = gfc_current_locus; - - if (gfc_match_char ('(') == MATCH_NO) - return MATCH_NO; - - memset (&iter, '\0', sizeof (gfc_iterator)); - head = NULL; - - m = match_array_cons_element (&head); - if (m != MATCH_YES) - goto cleanup; - - if (gfc_match_char (',') != MATCH_YES) - { - m = MATCH_NO; - goto cleanup; - } - - for (n = 1;; n++) - { - m = gfc_match_iterator (&iter, 0); - if (m == MATCH_YES) - break; - if (m == MATCH_ERROR) - goto cleanup; - - m = match_array_cons_element (&head); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - if (n > 2) - goto syntax; - m = MATCH_NO; - goto cleanup; /* Could be a complex constant */ - } - - if (gfc_match_char (',') != MATCH_YES) - { - if (n > 2) - goto syntax; - m = MATCH_NO; - goto cleanup; - } - } - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - if (check_duplicate_iterator (head, iter.var->symtree->n.sym)) - { - m = MATCH_ERROR; - goto cleanup; - } - - e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); - e->value.constructor = head; - - p = gfc_constructor_append_expr (result, e, &gfc_current_locus); - p->iterator = gfc_get_iterator (); - *p->iterator = iter; - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in array constructor at %C"); - m = MATCH_ERROR; - -cleanup: - gfc_constructor_free (head); - gfc_free_iterator (&iter, 0); - gfc_current_locus = old_loc; - return m; -} - - -/* Match a single element of an array constructor, which can be a - single expression or a list of elements. */ - -static match -match_array_cons_element (gfc_constructor_base *result) -{ - gfc_expr *expr; - match m; - - m = match_array_list (result); - if (m != MATCH_NO) - return m; - - m = gfc_match_expr (&expr); - if (m != MATCH_YES) - return m; - - if (expr->ts.type == BT_BOZ) - { - gfc_error ("BOZ literal constant at %L cannot appear in an " - "array constructor", &expr->where); - goto done; - } - - if (expr->expr_type == EXPR_FUNCTION - && expr->ts.type == BT_UNKNOWN - && strcmp(expr->symtree->name, "null") == 0) - { - gfc_error ("NULL() at %C cannot appear in an array constructor"); - goto done; - } - - gfc_constructor_append_expr (result, expr, &gfc_current_locus); - return MATCH_YES; - -done: - gfc_free_expr (expr); - return MATCH_ERROR; -} - - -/* Convert components of an array constructor to the type in ts. */ - -static match -walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head) -{ - gfc_constructor *c; - gfc_expr *e; - match m; - - for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) - { - e = c->expr; - if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_UNKNOWN - && !e->ref && e->value.constructor) - { - m = walk_array_constructor (ts, e->value.constructor); - if (m == MATCH_ERROR) - return m; - } - else if (!gfc_convert_type_warn (e, ts, 1, 1, true) - && e->ts.type != BT_UNKNOWN) - return MATCH_ERROR; - } - return MATCH_YES; -} - -/* Match an array constructor. */ - -match -gfc_match_array_constructor (gfc_expr **result) -{ - gfc_constructor *c; - gfc_constructor_base head; - gfc_expr *expr; - gfc_typespec ts; - locus where; - match m; - const char *end_delim; - bool seen_ts; - - head = NULL; - seen_ts = false; - - if (gfc_match (" (/") == MATCH_NO) - { - if (gfc_match (" [") == MATCH_NO) - return MATCH_NO; - else - { - if (!gfc_notify_std (GFC_STD_F2003, "[...] " - "style array constructors at %C")) - return MATCH_ERROR; - end_delim = " ]"; - } - } - else - end_delim = " /)"; - - where = gfc_current_locus; - - /* Try to match an optional "type-spec ::" */ - gfc_clear_ts (&ts); - m = gfc_match_type_spec (&ts); - if (m == MATCH_YES) - { - seen_ts = (gfc_match (" ::") == MATCH_YES); - - if (seen_ts) - { - if (!gfc_notify_std (GFC_STD_F2003, "Array constructor " - "including type specification at %C")) - goto cleanup; - - if (ts.deferred) - { - gfc_error ("Type-spec at %L cannot contain a deferred " - "type parameter", &where); - goto cleanup; - } - - if (ts.type == BT_CHARACTER - && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec) - { - gfc_error ("Type-spec at %L cannot contain an asterisk for a " - "type parameter", &where); - goto cleanup; - } - } - } - else if (m == MATCH_ERROR) - goto cleanup; - - if (!seen_ts) - gfc_current_locus = where; - - if (gfc_match (end_delim) == MATCH_YES) - { - if (seen_ts) - goto done; - else - { - gfc_error ("Empty array constructor at %C is not allowed"); - goto cleanup; - } - } - - for (;;) - { - m = match_array_cons_element (&head); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (gfc_match_char (',') == MATCH_NO) - break; - } - - if (gfc_match (end_delim) == MATCH_NO) - goto syntax; - -done: - /* Size must be calculated at resolution time. */ - if (seen_ts) - { - expr = gfc_get_array_expr (ts.type, ts.kind, &where); - expr->ts = ts; - - /* If the typespec is CHARACTER, check that array elements can - be converted. See PR fortran/67803. */ - if (ts.type == BT_CHARACTER) - { - c = gfc_constructor_first (head); - for (; c; c = gfc_constructor_next (c)) - { - if (gfc_numeric_ts (&c->expr->ts) - || c->expr->ts.type == BT_LOGICAL) - { - gfc_error ("Incompatible typespec for array element at %L", - &c->expr->where); - return MATCH_ERROR; - } - - /* Special case null(). */ - if (c->expr->expr_type == EXPR_FUNCTION - && c->expr->ts.type == BT_UNKNOWN - && strcmp (c->expr->symtree->name, "null") == 0) - { - gfc_error ("Incompatible typespec for array element at %L", - &c->expr->where); - return MATCH_ERROR; - } - } - } - - /* Walk the constructor, and if possible, do type conversion for - numeric types. */ - if (gfc_numeric_ts (&ts)) - { - m = walk_array_constructor (&ts, head); - if (m == MATCH_ERROR) - return m; - } - } - else - expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); - - expr->value.constructor = head; - if (expr->ts.u.cl) - expr->ts.u.cl->length_from_typespec = seen_ts; - - *result = expr; - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in array constructor at %C"); - -cleanup: - gfc_constructor_free (head); - return MATCH_ERROR; -} - - - -/************** Check array constructors for correctness **************/ - -/* Given an expression, compare it's type with the type of the current - constructor. Returns nonzero if an error was issued. The - cons_state variable keeps track of whether the type of the - constructor being read or resolved is known to be good, bad or just - starting out. */ - -static gfc_typespec constructor_ts; -static enum -{ CONS_START, CONS_GOOD, CONS_BAD } -cons_state; - -static int -check_element_type (gfc_expr *expr, bool convert) -{ - if (cons_state == CONS_BAD) - return 0; /* Suppress further errors */ - - if (cons_state == CONS_START) - { - if (expr->ts.type == BT_UNKNOWN) - cons_state = CONS_BAD; - else - { - cons_state = CONS_GOOD; - constructor_ts = expr->ts; - } - - return 0; - } - - if (gfc_compare_types (&constructor_ts, &expr->ts)) - return 0; - - if (convert) - return gfc_convert_type_warn (expr, &constructor_ts, 1, 1, true) ? 0 : 1; - - gfc_error ("Element in %s array constructor at %L is %s", - gfc_typename (&constructor_ts), &expr->where, - gfc_typename (expr)); - - cons_state = CONS_BAD; - return 1; -} - - -/* Recursive work function for gfc_check_constructor_type(). */ - -static bool -check_constructor_type (gfc_constructor_base base, bool convert) -{ - gfc_constructor *c; - gfc_expr *e; - - 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, convert)) - return false; - - continue; - } - - if (check_element_type (e, convert)) - return false; - } - - return true; -} - - -/* Check that all elements of an array constructor are the same type. - On false, an error has been generated. */ - -bool -gfc_check_constructor_type (gfc_expr *e) -{ - bool t; - - if (e->ts.type != BT_UNKNOWN) - { - cons_state = CONS_GOOD; - constructor_ts = e->ts; - } - else - { - cons_state = CONS_START; - gfc_clear_ts (&constructor_ts); - } - - /* 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 && e->ts.type == BT_UNKNOWN) - e->ts = constructor_ts; - - return t; -} - - - -typedef struct cons_stack -{ - gfc_iterator *iterator; - struct cons_stack *previous; -} -cons_stack; - -static cons_stack *base; - -static bool check_constructor (gfc_constructor_base, bool (*) (gfc_expr *)); - -/* Check an EXPR_VARIABLE expression in a constructor to make sure - that that variable is an iteration variable. */ - -bool -gfc_check_iter_variable (gfc_expr *expr) -{ - gfc_symbol *sym; - cons_stack *c; - - sym = expr->symtree->n.sym; - - for (c = base; c && c->iterator; c = c->previous) - if (sym == c->iterator->var->symtree->n.sym) - return true; - - return false; -} - - -/* Recursive work function for gfc_check_constructor(). This amounts - to calling the check function for each expression in the - constructor, giving variables with the names of iterators a pass. */ - -static bool -check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *)) -{ - cons_stack element; - gfc_expr *e; - bool t; - gfc_constructor *c; - - for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) - { - e = c->expr; - - if (!e) - continue; - - if (e->expr_type != EXPR_ARRAY) - { - if (!(*check_function)(e)) - return false; - continue; - } - - element.previous = base; - element.iterator = c->iterator; - - base = &element; - t = check_constructor (e->value.constructor, check_function); - base = element.previous; - - if (!t) - return false; - } - - /* Nothing went wrong, so all OK. */ - return true; -} - - -/* Checks a constructor to see if it is a particular kind of - expression -- specification, restricted, or initialization as - determined by the check_function. */ - -bool -gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *)) -{ - cons_stack *base_save; - bool t; - - base_save = base; - base = NULL; - - t = check_constructor (expr->value.constructor, check_function); - base = base_save; - - return t; -} - - - -/**************** Simplification of array constructors ****************/ - -iterator_stack *iter_stack; - -typedef struct -{ - gfc_constructor_base base; - int extract_count, extract_n; - gfc_expr *extracted; - mpz_t *count; - - mpz_t *offset; - gfc_component *component; - mpz_t *repeat; - - bool (*expand_work_function) (gfc_expr *); -} -expand_info; - -static expand_info current_expand; - -static bool expand_constructor (gfc_constructor_base); - - -/* Work function that counts the number of elements present in a - constructor. */ - -static bool -count_elements (gfc_expr *e) -{ - mpz_t result; - - if (e->rank == 0) - mpz_add_ui (*current_expand.count, *current_expand.count, 1); - else - { - if (!gfc_array_size (e, &result)) - { - gfc_free_expr (e); - return false; - } - - mpz_add (*current_expand.count, *current_expand.count, result); - mpz_clear (result); - } - - gfc_free_expr (e); - return true; -} - - -/* Work function that extracts a particular element from an array - constructor, freeing the rest. */ - -static bool -extract_element (gfc_expr *e) -{ - if (e->rank != 0) - { /* Something unextractable */ - gfc_free_expr (e); - return false; - } - - if (current_expand.extract_count == current_expand.extract_n) - current_expand.extracted = e; - else - gfc_free_expr (e); - - current_expand.extract_count++; - - return true; -} - - -/* Work function that constructs a new constructor out of the old one, - stringing new elements together. */ - -static bool -expand (gfc_expr *e) -{ - gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base, - e, &e->where); - - c->n.component = current_expand.component; - return true; -} - - -/* Given an initialization expression that is a variable reference, - substitute the current value of the iteration variable. */ - -void -gfc_simplify_iterator_var (gfc_expr *e) -{ - iterator_stack *p; - - for (p = iter_stack; p; p = p->prev) - if (e->symtree == p->variable) - break; - - if (p == NULL) - return; /* Variable not found */ - - gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); - - mpz_set (e->value.integer, p->value); - - return; -} - - -/* Expand an expression with that is inside of a constructor, - recursing into other constructors if present. */ - -static bool -expand_expr (gfc_expr *e) -{ - if (e->expr_type == EXPR_ARRAY) - return expand_constructor (e->value.constructor); - - e = gfc_copy_expr (e); - - if (!gfc_simplify_expr (e, 1)) - { - gfc_free_expr (e); - return false; - } - - return current_expand.expand_work_function (e); -} - - -static bool -expand_iterator (gfc_constructor *c) -{ - gfc_expr *start, *end, *step; - iterator_stack frame; - mpz_t trip; - bool t; - - end = step = NULL; - - t = false; - - mpz_init (trip); - mpz_init (frame.value); - frame.prev = NULL; - - start = gfc_copy_expr (c->iterator->start); - if (!gfc_simplify_expr (start, 1)) - goto cleanup; - - if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER) - goto cleanup; - - end = gfc_copy_expr (c->iterator->end); - if (!gfc_simplify_expr (end, 1)) - goto cleanup; - - if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER) - goto cleanup; - - step = gfc_copy_expr (c->iterator->step); - if (!gfc_simplify_expr (step, 1)) - goto cleanup; - - if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER) - goto cleanup; - - if (mpz_sgn (step->value.integer) == 0) - { - gfc_error ("Iterator step at %L cannot be zero", &step->where); - goto cleanup; - } - - /* Calculate the trip count of the loop. */ - mpz_sub (trip, end->value.integer, start->value.integer); - mpz_add (trip, trip, step->value.integer); - mpz_tdiv_q (trip, trip, step->value.integer); - - mpz_set (frame.value, start->value.integer); - - frame.prev = iter_stack; - frame.variable = c->iterator->var->symtree; - iter_stack = &frame; - - while (mpz_sgn (trip) > 0) - { - if (!expand_expr (c->expr)) - goto cleanup; - - mpz_add (frame.value, frame.value, step->value.integer); - mpz_sub_ui (trip, trip, 1); - } - - t = true; - -cleanup: - gfc_free_expr (start); - gfc_free_expr (end); - gfc_free_expr (step); - - mpz_clear (trip); - mpz_clear (frame.value); - - iter_stack = frame.prev; - - return t; -} - -/* Variables for noticing if all constructors are empty, and - if any of them had a type. */ - -static bool empty_constructor; -static gfc_typespec empty_ts; - -/* Expand a constructor into constant constructors without any - iterators, calling the work function for each of the expanded - expressions. The work function needs to either save or free the - passed expression. */ - -static bool -expand_constructor (gfc_constructor_base base) -{ - gfc_constructor *c; - gfc_expr *e; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) - { - if (c->iterator != NULL) - { - if (!expand_iterator (c)) - return false; - continue; - } - - e = c->expr; - - if (e == NULL) - return false; - - if (empty_constructor) - empty_ts = e->ts; - - /* Simplify constant array expression/section within constructor. */ - if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref - && e->symtree && e->symtree->n.sym - && e->symtree->n.sym->attr.flavor == FL_PARAMETER) - gfc_simplify_expr (e, 0); - - if (e->expr_type == EXPR_ARRAY) - { - if (!expand_constructor (e->value.constructor)) - return false; - - continue; - } - - empty_constructor = false; - e = gfc_copy_expr (e); - if (!gfc_simplify_expr (e, 1)) - { - gfc_free_expr (e); - return false; - } - e->from_constructor = 1; - current_expand.offset = &c->offset; - current_expand.repeat = &c->repeat; - current_expand.component = c->n.component; - if (!current_expand.expand_work_function(e)) - return false; - } - return true; -} - - -/* 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; - bool 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) - return NULL; - - return e; -} - - -/* Top level subroutine for expanding constructors. We only expand - constructor if they are small enough. */ - -bool -gfc_expand_constructor (gfc_expr *e, bool fatal) -{ - expand_info expand_save; - gfc_expr *f; - bool 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, 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, flag_max_array_constructor); - return false; - } - return true; - } - - /* 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; - - iter_stack = NULL; - - empty_constructor = true; - gfc_clear_ts (&empty_ts); - current_expand.expand_work_function = expand; - - if (!expand_constructor (e->value.constructor)) - { - gfc_constructor_free (current_expand.base); - rc = false; - goto done; - } - - /* If we don't have an explicit constructor type, and there - were only empty constructors, then take the type from - them. */ - - if (constructor_ts.type == BT_UNKNOWN && empty_constructor) - e->ts = empty_ts; - - gfc_constructor_free (e->value.constructor); - e->value.constructor = current_expand.base; - - rc = true; - -done: - current_expand = expand_save; - - return rc; -} - - -/* Work function for checking that an element of a constructor is a - constant, after removal of any iteration variables. We return - false if not so. */ - -static bool -is_constant_element (gfc_expr *e) -{ - int rv; - - rv = gfc_is_constant_expr (e); - gfc_free_expr (e); - - return rv ? true : false; -} - - -/* Given an array constructor, determine if the constructor is - constant or not by expanding it and making sure that all elements - are constants. This is a bit of a hack since something like (/ (i, - i=1,100000000) /) will take a while as* opposed to a more clever - function that traverses the expression tree. FIXME. */ - -int -gfc_constant_ac (gfc_expr *e) -{ - expand_info expand_save; - bool rc; - - iter_stack = NULL; - expand_save = current_expand; - current_expand.expand_work_function = is_constant_element; - - rc = expand_constructor (e->value.constructor); - - current_expand = expand_save; - if (!rc) - return 0; - - return 1; -} - - -/* Returns nonzero if an array constructor has been completely - expanded (no iterators) and zero if iterators are present. */ - -int -gfc_expanded_ac (gfc_expr *e) -{ - gfc_constructor *c; - - 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)) - return 0; - - return 1; -} - - -/*************** Type resolution of array constructors ***************/ - - -/* The symbol expr_is_sought_symbol_ref will try to find. */ -static const gfc_symbol *sought_symbol = NULL; - - -/* Tells whether the expression E is a variable reference to the symbol - in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE - accordingly. - To be used with gfc_expr_walker: if a reference is found we don't need - to look further so we return 1 to skip any further walk. */ - -static int -expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *where) -{ - gfc_expr *expr = *e; - locus *sym_loc = (locus *)where; - - if (expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym == sought_symbol) - { - *sym_loc = expr->where; - return 1; - } - - return 0; -} - - -/* Tells whether the expression EXPR contains a reference to the symbol - SYM and in that case sets the position SYM_LOC where the reference is. */ - -static bool -find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc) -{ - int ret; - - sought_symbol = sym; - ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc); - sought_symbol = NULL; - return ret; -} - - -/* Recursive array list resolution function. All of the elements must - be of the same type. */ - -static bool -resolve_array_list (gfc_constructor_base base) -{ - bool t; - gfc_constructor *c; - gfc_iterator *iter; - - t = true; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - iter = c->iterator; - if (iter != NULL) - { - gfc_symbol *iter_var; - locus iter_var_loc; - - if (!gfc_resolve_iterator (iter, false, true)) - t = false; - - /* Check for bounds referencing the iterator variable. */ - gcc_assert (iter->var->expr_type == EXPR_VARIABLE); - iter_var = iter->var->symtree->n.sym; - if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc)) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial " - "expression references control variable " - "at %L", &iter_var_loc)) - t = false; - } - if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc)) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final " - "expression references control variable " - "at %L", &iter_var_loc)) - t = false; - } - if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc)) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step " - "expression references control variable " - "at %L", &iter_var_loc)) - t = false; - } - } - - if (!gfc_resolve_expr (c->expr)) - t = false; - - if (UNLIMITED_POLY (c->expr)) - { - gfc_error ("Array constructor value at %L shall not be unlimited " - "polymorphic [F2008: C4106]", &c->expr->where); - t = false; - } - } - - return t; -} - -/* 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. */ - -bool -gfc_resolve_character_array_constructor (gfc_expr *expr) -{ - gfc_constructor *p; - HOST_WIDE_INT found_length; - - gcc_assert (expr->expr_type == EXPR_ARRAY); - gcc_assert (expr->ts.type == BT_CHARACTER); - - if (expr->ts.u.cl == NULL) - { - 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); - } - -got_charlen: - - /* Early exit for zero size arrays. */ - if (expr->shape) - { - mpz_t size; - HOST_WIDE_INT arraysize; - - gfc_array_size (expr, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - if (arraysize == 0) - return true; - } - - found_length = -1; - - if (expr->ts.u.cl->length == NULL) - { - /* 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)) - { - HOST_WIDE_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 - && ref->u.ss.start->expr_type == EXPR_CONSTANT - && ref->u.ss.end - && 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) - current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer) - - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1; - else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length - && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) - current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer); - else - return true; - - if (current_length < 0) - current_length = 0; - - if (found_length == -1) - found_length = current_length; - else if (found_length != current_length) - { - gfc_error ("Different CHARACTER lengths (%ld/%ld) in array" - " constructor at %L", (long) found_length, - (long) current_length, &p->expr->where); - return false; - } - - 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_charlen_int_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_hwi (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; - HOST_WIDE_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_hwi (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->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 true; -} - - -/* Resolve all of the expressions in an array list. */ - -bool -gfc_resolve_array_constructor (gfc_expr *expr) -{ - bool t; - - t = resolve_array_list (expr->value.constructor); - if (t) - t = gfc_check_constructor_type (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; -} - - -/* Copy an iterator structure. */ - -gfc_iterator * -gfc_copy_iterator (gfc_iterator *src) -{ - gfc_iterator *dest; - - if (src == NULL) - return NULL; - - dest = gfc_get_iterator (); - - dest->var = gfc_copy_expr (src->var); - dest->start = gfc_copy_expr (src->start); - dest->end = gfc_copy_expr (src->end); - dest->step = gfc_copy_expr (src->step); - dest->unroll = src->unroll; - dest->ivdep = src->ivdep; - dest->vector = src->vector; - dest->novector = src->novector; - - return dest; -} - - -/********* Subroutines for determining the size of an array *********/ - -/* These are needed just to accommodate RESHAPE(). There are no - diagnostics here, we just return false if something goes wrong. */ - - -/* Get the size of single dimension of an array specification. The - array is guaranteed to be one dimensional. */ - -bool -spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) -{ - if (as == NULL) - return false; - - if (dimen < 0 || dimen > as->rank - 1) - gfc_internal_error ("spec_dimen_size(): Bad dimension"); - - if (as->type != AS_EXPLICIT - || !as->lower[dimen] - || !as->upper[dimen]) - return false; - - if (as->lower[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 false; - - mpz_init (*result); - - mpz_sub (*result, as->upper[dimen]->value.integer, - as->lower[dimen]->value.integer); - - mpz_add_ui (*result, *result, 1); - - if (mpz_cmp_si (*result, 0) < 0) - mpz_set_si (*result, 0); - - return true; -} - - -bool -spec_size (gfc_array_spec *as, mpz_t *result) -{ - mpz_t size; - int d; - - if (!as || as->type == AS_ASSUMED_RANK) - return false; - - mpz_init_set_ui (*result, 1); - - for (d = 0; d < as->rank; d++) - { - if (!spec_dimen_size (as, d, &size)) - { - mpz_clear (*result); - return false; - } - - mpz_mul (*result, *result, size); - mpz_clear (size); - } - - return true; -} - - -/* Get the number of elements in an array section. Optionally, also supply - the end value. */ - -bool -gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end) -{ - mpz_t upper, lower, stride; - mpz_t diff; - bool t; - gfc_expr *stride_expr = NULL; - - if (dimen < 0 || ar == NULL) - gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension"); - - if (dimen > ar->dimen - 1) - { - gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]); - return false; - } - - switch (ar->dimen_type[dimen]) - { - case DIMEN_ELEMENT: - mpz_init (*result); - mpz_set_ui (*result, 1); - t = true; - break; - - case DIMEN_VECTOR: - t = gfc_array_size (ar->start[dimen], result); /* Recurse! */ - break; - - case DIMEN_RANGE: - - mpz_init (stride); - - if (ar->stride[dimen] == NULL) - mpz_set_ui (stride, 1); - else - { - stride_expr = gfc_copy_expr(ar->stride[dimen]); - - if (!gfc_simplify_expr (stride_expr, 1) - || stride_expr->expr_type != EXPR_CONSTANT - || mpz_cmp_ui (stride_expr->value.integer, 0) == 0) - { - gfc_free_expr (stride_expr); - mpz_clear (stride); - return false; - } - mpz_set (stride, stride_expr->value.integer); - gfc_free_expr(stride_expr); - } - - /* Calculate the number of elements via gfc_dep_differce, but only if - start and end are both supplied in the reference or the array spec. - This is to guard against strange but valid code like - - subroutine foo(a,n) - real a(1:n) - n = 3 - print *,size(a(n-1:)) - - where the user changes the value of a variable. If we have to - determine end as well, we cannot do this using gfc_dep_difference. - Fall back to the constants-only code then. */ - - if (end == NULL) - { - bool use_dep; - - use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen], - &diff); - if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL) - use_dep = gfc_dep_difference (ar->as->upper[dimen], - ar->as->lower[dimen], &diff); - - if (use_dep) - { - mpz_init (*result); - mpz_add (*result, diff, stride); - mpz_div (*result, *result, stride); - if (mpz_cmp_ui (*result, 0) < 0) - mpz_set_ui (*result, 0); - - mpz_clear (stride); - mpz_clear (diff); - return true; - } - - } - - /* Constant-only code here, which covers more cases - like a(:4) etc. */ - mpz_init (upper); - mpz_init (lower); - t = false; - - if (ar->start[dimen] == NULL) - { - if (ar->as->lower[dimen] == NULL - || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT - || ar->as->lower[dimen]->ts.type != BT_INTEGER) - goto cleanup; - mpz_set (lower, ar->as->lower[dimen]->value.integer); - } - else - { - if (ar->start[dimen]->expr_type != EXPR_CONSTANT) - goto cleanup; - mpz_set (lower, ar->start[dimen]->value.integer); - } - - if (ar->end[dimen] == NULL) - { - if (ar->as->upper[dimen] == NULL - || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT - || ar->as->upper[dimen]->ts.type != BT_INTEGER) - goto cleanup; - mpz_set (upper, ar->as->upper[dimen]->value.integer); - } - else - { - if (ar->end[dimen]->expr_type != EXPR_CONSTANT) - goto cleanup; - mpz_set (upper, ar->end[dimen]->value.integer); - } - - mpz_init (*result); - mpz_sub (*result, upper, lower); - mpz_add (*result, *result, stride); - mpz_div (*result, *result, stride); - - /* Zero stride caught earlier. */ - if (mpz_cmp_ui (*result, 0) < 0) - mpz_set_ui (*result, 0); - t = true; - - 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); - mpz_clear (stride); - return t; - - default: - gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type"); - } - - return t; -} - - -static bool -ref_size (gfc_array_ref *ar, mpz_t *result) -{ - mpz_t size; - int d; - - mpz_init_set_ui (*result, 1); - - for (d = 0; d < ar->dimen; d++) - { - if (!gfc_ref_dimen_size (ar, d, &size, NULL)) - { - mpz_clear (*result); - return false; - } - - mpz_mul (*result, *result, size); - mpz_clear (size); - } - - return true; -} - - -/* Given an array expression and a dimension, figure out how many - elements it has along that dimension. Returns true if we were - able to return a result in the 'result' variable, false - otherwise. */ - -bool -gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) -{ - gfc_ref *ref; - int i; - - gcc_assert (array != NULL); - - if (array->ts.type == BT_CLASS) - return false; - - if (array->rank == -1) - return false; - - if (dimen < 0 || dimen > array->rank - 1) - gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); - - switch (array->expr_type) - { - case EXPR_VARIABLE: - case EXPR_FUNCTION: - for (ref = array->ref; ref; ref = ref->next) - { - if (ref->type != REF_ARRAY) - continue; - - if (ref->u.ar.type == AR_FULL) - return spec_dimen_size (ref->u.ar.as, dimen, result); - - if (ref->u.ar.type == AR_SECTION) - { - for (i = 0; dimen >= 0; i++) - if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) - dimen--; - - return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL); - } - } - - if (array->shape) - { - mpz_init_set (*result, array->shape[dimen]); - return true; - } - - if (array->symtree->n.sym->attr.generic - && array->value.function.esym != NULL) - { - if (!spec_dimen_size (array->value.function.esym->as, dimen, result)) - return false; - } - else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result)) - return false; - - break; - - case EXPR_ARRAY: - if (array->shape == NULL) { - /* Expressions with rank > 1 should have "shape" properly set */ - if ( array->rank != 1 ) - gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr"); - return gfc_array_size(array, result); - } - - /* Fall through */ - default: - if (array->shape == NULL) - return false; - - mpz_init_set (*result, array->shape[dimen]); - - break; - } - - return true; -} - - -/* Given an array expression, figure out how many elements are in the - array. Returns true if this is possible, and sets the 'result' - variable. Otherwise returns false. */ - -bool -gfc_array_size (gfc_expr *array, mpz_t *result) -{ - expand_info expand_save; - gfc_ref *ref; - int i; - bool t; - - if (array->ts.type == BT_CLASS) - return false; - - switch (array->expr_type) - { - case EXPR_ARRAY: - gfc_push_suppress_errors (); - - expand_save = current_expand; - - current_expand.count = result; - mpz_init_set_ui (*result, 0); - - current_expand.expand_work_function = count_elements; - iter_stack = NULL; - - t = expand_constructor (array->value.constructor); - - gfc_pop_suppress_errors (); - - if (!t) - mpz_clear (*result); - current_expand = expand_save; - return t; - - case EXPR_VARIABLE: - for (ref = array->ref; ref; ref = ref->next) - { - if (ref->type != REF_ARRAY) - continue; - - if (ref->u.ar.type == AR_FULL) - return spec_size (ref->u.ar.as, result); - - if (ref->u.ar.type == AR_SECTION) - return ref_size (&ref->u.ar, result); - } - - return spec_size (array->symtree->n.sym->as, result); - - - default: - if (array->rank == 0 || array->shape == NULL) - return false; - - mpz_init_set_ui (*result, 1); - - for (i = 0; i < array->rank; i++) - mpz_mul (*result, *result, array->shape[i]); - - break; - } - - return true; -} - - -/* Given an array reference, return the shape of the reference in an - array of mpz_t integers. */ - -bool -gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) -{ - int d; - int i; - - d = 0; - - switch (ar->type) - { - case AR_FULL: - for (; d < ar->as->rank; d++) - if (!spec_dimen_size (ar->as, d, &shape[d])) - goto cleanup; - - return true; - - case AR_SECTION: - for (i = 0; i < ar->dimen; i++) - { - if (ar->dimen_type[i] != DIMEN_ELEMENT) - { - if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL)) - goto cleanup; - d++; - } - } - - return true; - - default: - break; - } - -cleanup: - gfc_clear_shape (shape, d); - return false; -} - - -/* Given an array expression, find the array reference structure that - characterizes the reference. */ - -gfc_array_ref * -gfc_find_array_ref (gfc_expr *e, bool allow_null) -{ - 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)) - break; - - if (ref == NULL) - { - if (allow_null) - return NULL; - else - gfc_internal_error ("gfc_find_array_ref(): No ref found"); - } - - return &ref->u.ar; -} - - -/* Find out if an array shape is known at compile time. */ - -bool -gfc_is_compile_time_shape (gfc_array_spec *as) -{ - if (as->type != AS_EXPLICIT) - return false; - - for (int i = 0; i < as->rank; i++) - if (!gfc_is_constant_expr (as->lower[i]) - || !gfc_is_constant_expr (as->upper[i])) - return false; - - return true; -} |