summaryrefslogtreecommitdiff
path: root/gcc/fortran/array.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/array.c')
-rw-r--r--gcc/fortran/array.c1973
1 files changed, 1973 insertions, 0 deletions
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
new file mode 100644
index 00000000000..6ab5f83b9a3
--- /dev/null
+++ b/gcc/fortran/array.c
@@ -0,0 +1,1973 @@
+/* Array things
+ Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+ Contributed by Andy Vaught
+
+This file is part of GNU G95.
+
+GNU G95 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 version.
+
+GNU G95 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 GNU G95; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+#include "config.h"
+#include "gfortran.h"
+#include "match.h"
+
+#include <string.h>
+#include <assert.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 100
+
+
+/**************** 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]);
+ }
+
+ dest->offset = gfc_copy_expr (src->offset);
+
+ 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)
+{
+ match m;
+ int i;
+
+ i = ar->dimen;
+
+ 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 (init)
+ m = gfc_match_init_expr (&ar->start[i]);
+ else
+ m = gfc_match_expr (&ar->start[i]);
+
+ 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;
+
+ /* 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)
+ m = gfc_match_init_expr (&ar->end[i]);
+ else
+ m = gfc_match_expr (&ar->end[i]);
+
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ /* See if we have an optional stride. */
+ if (gfc_match_char (':') == MATCH_YES)
+ {
+ m = init ? gfc_match_init_expr (&ar->stride[i])
+ : gfc_match_expr (&ar->stride[i]);
+
+ if (m == MATCH_NO)
+ gfc_error ("Expected array subscript stride at %C");
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+}
+
+
+/* Match an array reference, whether it is the whole array or a
+ 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)
+{
+ match m;
+
+ memset (ar, '\0', sizeof (ar));
+
+ ar->where = *gfc_current_locus ();
+ ar->as = as;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ ar->type = AR_FULL;
+ ar->dimen = 0;
+ return MATCH_YES;
+ }
+
+ ar->type = AR_UNKNOWN;
+
+ for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
+ {
+ m = match_subscript (ar, init);
+ if (m == MATCH_ERROR)
+ goto error;
+
+ if (gfc_match_char (')') == MATCH_YES)
+ goto matched;
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Invalid form of array reference at %C");
+ goto error;
+ }
+ }
+
+ gfc_error ("Array reference at %C cannot have more than "
+ stringize (GFC_MAX_DIMENSIONS) " dimensions");
+
+error:
+ return MATCH_ERROR;
+
+matched:
+ ar->dimen++;
+
+ return MATCH_YES;
+}
+
+
+/************** 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;
+
+ for (i = 0; i < as->rank; i++)
+ {
+ gfc_free_expr (as->lower[i]);
+ gfc_free_expr (as->upper[i]);
+ }
+
+ gfc_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)
+{
+
+ if (e == NULL)
+ return SUCCESS;
+
+ if (gfc_resolve_expr (e) == FAILURE
+ || gfc_specification_expr (e) == FAILURE)
+ return FAILURE;
+
+ if (check_constant && gfc_is_constant_expr (e) == 0)
+ {
+ gfc_error ("Variable '%s' at %L in this context must be constant",
+ e->symtree->n.sym->name, &e->where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+/* 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_expr *e;
+ int i;
+
+ if (as == NULL)
+ return SUCCESS;
+
+ for (i = 0; i < as->rank; i++)
+ {
+ e = as->lower[i];
+ if (resolve_array_bound (e, check_constant) == FAILURE)
+ return FAILURE;
+
+ e = as->upper[i];
+ if (resolve_array_bound (e, check_constant) == FAILURE)
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+/* 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;
+
+ lower = &as->lower[as->rank - 1];
+ upper = &as->upper[as->rank - 1];
+
+ if (gfc_match_char ('*') == MATCH_YES)
+ {
+ *lower = gfc_int_expr (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_match_char (':') == MATCH_NO)
+ {
+ *lower = gfc_int_expr (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;
+
+ return AS_EXPLICIT;
+}
+
+
+/* Matches an array specification, incidentally figuring out what sort
+ it is. */
+
+match
+gfc_match_array_spec (gfc_array_spec ** asp)
+{
+ 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++)
+ {
+ as->lower[i] = NULL;
+ as->upper[i] = NULL;
+ }
+
+ as->rank = 1;
+
+ for (;;)
+ {
+ current_type = match_array_element_spec (as);
+
+ 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_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:
+ 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 >= GFC_MAX_DIMENSIONS)
+ {
+ gfc_error ("Array specification at %C has more than "
+ stringize (GFC_MAX_DIMENSIONS) " dimensions");
+ goto cleanup;
+ }
+
+ as->rank++;
+ }
+
+ /* 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++)
+ {
+ if (as->lower[i] == NULL)
+ as->lower[i] = gfc_int_expr (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. */
+
+try
+gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
+{
+
+ if (as == NULL)
+ return SUCCESS;
+
+ if (gfc_add_dimension (&sym->attr, error_loc) == FAILURE)
+ return FAILURE;
+
+ sym->as = as;
+
+ return SUCCESS;
+}
+
+
+/* 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; 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->rank == 0)
+ return 1;
+
+ if (as1->type != as2->type)
+ return 0;
+
+ if (as1->type == AS_EXPLICIT)
+ for (i = 0; i < as1->rank; 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 ******************/
+
+/* 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;
+
+ 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)
+ {
+ if (mpz_cmp (c->n.offset, c1->n.offset) < 0)
+ {
+ pre = c;
+ c = c->next;
+ }
+ else if (mpz_cmp (c->n.offset, c1->n.offset) == 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
+ use the symbol as an implied-DO iterator. Returns nonzero if a
+ duplicate was found. */
+
+static int
+check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
+{
+ gfc_expr *e;
+
+ for (; c; c = c->next)
+ {
+ 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 '%s' 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 **);
+
+/* Match a list of array elements. */
+
+static match
+match_array_list (gfc_constructor ** result)
+{
+ gfc_constructor *p, *head, *tail, *new;
+ 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;
+
+ tail = head;
+
+ 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 (&new);
+ 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 */
+ }
+
+ tail->next = new;
+ tail = new;
+
+ 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_expr ();
+ e->expr_type = EXPR_ARRAY;
+ e->where = old_loc;
+ e->value.constructor = head;
+
+ p = gfc_get_constructor ();
+ p->where = *gfc_current_locus ();
+ p->iterator = gfc_get_iterator ();
+ *p->iterator = iter;
+
+ p->expr = e;
+ *result = p;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in array constructor at %C");
+ m = MATCH_ERROR;
+
+cleanup:
+ gfc_free_constructor (head);
+ gfc_free_iterator (&iter, 0);
+ gfc_set_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 ** result)
+{
+ gfc_constructor *p;
+ 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;
+
+ p = gfc_get_constructor ();
+ p->where = *gfc_current_locus ();
+ p->expr = expr;
+
+ *result = p;
+ return MATCH_YES;
+}
+
+
+/* Match an array constructor. */
+
+match
+gfc_match_array_constructor (gfc_expr ** result)
+{
+ gfc_constructor *head, *tail, *new;
+ gfc_expr *expr;
+ locus where;
+ match m;
+
+ if (gfc_match (" (/") == MATCH_NO)
+ return MATCH_NO;
+
+ where = *gfc_current_locus ();
+ head = tail = NULL;
+
+ if (gfc_match (" /)") == MATCH_YES)
+ goto empty; /* Special case */
+
+ for (;;)
+ {
+ m = match_array_cons_element (&new);
+ 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;
+ }
+
+ if (gfc_match (" /)") == MATCH_NO)
+ goto syntax;
+
+empty:
+ expr = gfc_get_expr ();
+
+ expr->expr_type = EXPR_ARRAY;
+
+ expr->value.constructor = head;
+ /* Size must be calculated at resolution time. */
+
+ expr->where = where;
+ expr->rank = 1;
+
+ *result = expr;
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in array constructor at %C");
+
+cleanup:
+ gfc_free_constructor (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)
+{
+
+ if (cons_state == CONS_BAD)
+ return 0; /* Supress 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;
+
+ gfc_error ("Element in %s array constructor at %L is %s",
+ gfc_typename (&constructor_ts), &expr->where,
+ gfc_typename (&expr->ts));
+
+ cons_state = CONS_BAD;
+ return 1;
+}
+
+
+/* Recursive work function for gfc_check_constructor_type(). */
+
+static try
+check_constructor_type (gfc_constructor * c)
+{
+ gfc_expr *e;
+
+ for (; c; c = c->next)
+ {
+ e = c->expr;
+
+ if (e->expr_type == EXPR_ARRAY)
+ {
+ if (check_constructor_type (e->value.constructor) == FAILURE)
+ return FAILURE;
+
+ continue;
+ }
+
+ if (check_element_type (e))
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+/* 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)
+{
+ try t;
+
+ cons_state = CONS_START;
+ gfc_clear_ts (&constructor_ts);
+
+ t = check_constructor_type (e->value.constructor);
+ if (t == SUCCESS && 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 try check_constructor (gfc_constructor *, 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_symbol *sym;
+ cons_stack *c;
+
+ sym = expr->symtree->n.sym;
+
+ for (c = base; c; c = c->previous)
+ if (sym == c->iterator->var->symtree->n.sym)
+ return SUCCESS;
+
+ return FAILURE;
+}
+
+
+/* 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 try
+check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
+{
+ cons_stack element;
+ gfc_expr *e;
+ try t;
+
+ for (; c; c = c->next)
+ {
+ e = c->expr;
+
+ if (e->expr_type != EXPR_ARRAY)
+ {
+ if ((*check_function) (e) == FAILURE)
+ return FAILURE;
+ continue;
+ }
+
+ element.previous = base;
+ element.iterator = c->iterator;
+
+ base = &element;
+ t = check_constructor (e->value.constructor, check_function);
+ base = element.previous;
+
+ if (t == FAILURE)
+ return FAILURE;
+ }
+
+ /* Nothing went wrong, so all OK. */
+ return SUCCESS;
+}
+
+
+/* Checks a constructor to see if it is a particular kind of
+ expression -- specification, restricted, or initialization as
+ determined by the check_function. */
+
+try
+gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *))
+{
+ cons_stack *base_save;
+ try 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 *new_head, *new_tail;
+ int extract_count, extract_n;
+ gfc_expr *extracted;
+ mpz_t *count;
+
+ mpz_t *offset;
+ gfc_component *component;
+ mpz_t *repeat;
+
+ try (*expand_work_function) (gfc_expr *);
+}
+expand_info;
+
+static expand_info current_expand;
+
+static try expand_constructor (gfc_constructor *);
+
+
+/* Work function that counts the number of elements present in a
+ constructor. */
+
+static try
+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) == FAILURE)
+ {
+ gfc_free_expr (e);
+ return FAILURE;
+ }
+
+ mpz_add (*current_expand.count, *current_expand.count, result);
+ mpz_clear (result);
+ }
+
+ gfc_free_expr (e);
+ return SUCCESS;
+}
+
+
+/* Work function that extracts a particular element from an array
+ constructor, freeing the rest. */
+
+static try
+extract_element (gfc_expr * e)
+{
+
+ if (e->rank != 0)
+ { /* Something unextractable */
+ gfc_free_expr (e);
+ return FAILURE;
+ }
+
+ if (current_expand.extract_count == current_expand.extract_n)
+ current_expand.extracted = e;
+ else
+ gfc_free_expr (e);
+
+ current_expand.extract_count++;
+ return SUCCESS;
+}
+
+
+/* Work function that constructs a new constructor out of the old one,
+ stringing new elements together. */
+
+static try
+expand (gfc_expr * e)
+{
+
+ 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);
+ return SUCCESS;
+}
+
+
+/* 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_int_expr (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 try
+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) == FAILURE)
+ {
+ gfc_free_expr (e);
+ return FAILURE;
+ }
+
+ return current_expand.expand_work_function (e);
+}
+
+
+static try
+expand_iterator (gfc_constructor * c)
+{
+ gfc_expr *start, *end, *step;
+ iterator_stack frame;
+ mpz_t trip;
+ try t;
+
+ end = step = NULL;
+
+ t = FAILURE;
+
+ mpz_init (trip);
+ mpz_init (frame.value);
+
+ start = gfc_copy_expr (c->iterator->start);
+ if (gfc_simplify_expr (start, 1) == FAILURE)
+ 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) == FAILURE)
+ 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) == FAILURE)
+ 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) == FAILURE)
+ goto cleanup;
+
+ mpz_add (frame.value, frame.value, step->value.integer);
+ mpz_sub_ui (trip, trip, 1);
+ }
+
+ t = SUCCESS;
+
+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;
+}
+
+
+/* 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 try
+expand_constructor (gfc_constructor * c)
+{
+ gfc_expr *e;
+
+ for (; c; c = c->next)
+ {
+ if (c->iterator != NULL)
+ {
+ if (expand_iterator (c) == FAILURE)
+ return FAILURE;
+ continue;
+ }
+
+ e = c->expr;
+
+ if (e->expr_type == EXPR_ARRAY)
+ {
+ if (expand_constructor (e->value.constructor) == FAILURE)
+ return FAILURE;
+
+ continue;
+ }
+
+ e = gfc_copy_expr (e);
+ if (gfc_simplify_expr (e, 1) == FAILURE)
+ {
+ gfc_free_expr (e);
+ return FAILURE;
+ }
+ current_expand.offset = &c->n.offset;
+ current_expand.component = c->n.component;
+ current_expand.repeat = &c->repeat;
+ if (current_expand.expand_work_function (e) == FAILURE)
+ return FAILURE;
+ }
+ return SUCCESS;
+}
+
+
+/* Top level subroutine for expanding constructors. We only expand
+ constructor if they are small enough. */
+
+try
+gfc_expand_constructor (gfc_expr * e)
+{
+ expand_info expand_save;
+ gfc_expr *f;
+ try rc;
+
+ f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
+ if (f != NULL)
+ {
+ gfc_free_expr (f);
+ return SUCCESS;
+ }
+
+ expand_save = current_expand;
+ current_expand.new_head = current_expand.new_tail = NULL;
+
+ iter_stack = NULL;
+
+ current_expand.expand_work_function = expand;
+
+ if (expand_constructor (e->value.constructor) == FAILURE)
+ {
+ gfc_free_constructor (current_expand.new_head);
+ rc = FAILURE;
+ goto done;
+ }
+
+ gfc_free_constructor (e->value.constructor);
+ e->value.constructor = current_expand.new_head;
+
+ rc = SUCCESS;
+
+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
+ FAILURE if not so. */
+
+static try
+constant_element (gfc_expr * e)
+{
+ int rv;
+
+ rv = gfc_is_constant_expr (e);
+ gfc_free_expr (e);
+
+ return rv ? SUCCESS : FAILURE;
+}
+
+
+/* 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;
+ try rc;
+
+ iter_stack = NULL;
+ expand_save = current_expand;
+ current_expand.expand_work_function = constant_element;
+
+ rc = expand_constructor (e->value.constructor);
+
+ current_expand = expand_save;
+ if (rc == FAILURE)
+ 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 *p;
+
+ if (e->expr_type == EXPR_ARRAY)
+ for (p = e->value.constructor; p; p = p->next)
+ if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
+ return 0;
+
+ return 1;
+}
+
+
+/*************** Type resolution of array constructors ***************/
+
+/* Recursive array list resolution function. All of the elements must
+ be of the same type. */
+
+static try
+resolve_array_list (gfc_constructor * p)
+{
+ try t;
+
+ t = SUCCESS;
+
+ for (; p; p = p->next)
+ {
+ if (p->iterator != NULL
+ && gfc_resolve_iterator (p->iterator) == FAILURE)
+ t = FAILURE;
+
+ if (gfc_resolve_expr (p->expr) == FAILURE)
+ t = FAILURE;
+ }
+
+ return t;
+}
+
+
+/* Resolve all of the expressions in an array list.
+ TODO: String lengths. */
+
+try
+gfc_resolve_array_constructor (gfc_expr * expr)
+{
+ try t;
+
+ t = resolve_array_list (expr->value.constructor);
+ if (t == SUCCESS)
+ t = gfc_check_constructor_type (expr);
+
+ return t;
+}
+
+
+/* Copy an iterator structure. */
+
+static gfc_iterator *
+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);
+
+ return dest;
+}
+
+
+/* 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 accomodate RESHAPE(). There are no
+ diagnostics here, we just return a negative number if something
+ goes wrong. */
+
+
+/* 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)
+{
+
+ if (as == NULL)
+ return FAILURE;
+
+ if (dimen < 0 || dimen > as->rank - 1)
+ gfc_internal_error ("spec_dimen_size(): Bad dimension");
+
+ if (as->type != AS_EXPLICIT
+ || as->lower[dimen]->expr_type != EXPR_CONSTANT
+ || as->upper[dimen]->expr_type != EXPR_CONSTANT)
+ return FAILURE;
+
+ mpz_init (*result);
+
+ mpz_sub (*result, as->upper[dimen]->value.integer,
+ as->lower[dimen]->value.integer);
+
+ mpz_add_ui (*result, *result, 1);
+
+ return SUCCESS;
+}
+
+
+try
+spec_size (gfc_array_spec * as, mpz_t * result)
+{
+ mpz_t size;
+ int d;
+
+ mpz_init_set_ui (*result, 1);
+
+ for (d = 0; d < as->rank; d++)
+ {
+ if (spec_dimen_size (as, d, &size) == FAILURE)
+ {
+ mpz_clear (*result);
+ return FAILURE;
+ }
+
+ mpz_mul (*result, *result, size);
+ mpz_clear (size);
+ }
+
+ return SUCCESS;
+}
+
+
+/* Get the number of elements in an array section. */
+
+static try
+ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
+{
+ mpz_t upper, lower, stride;
+ try t;
+
+ if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
+ gfc_internal_error ("ref_dimen_size(): Bad dimension");
+
+ switch (ar->dimen_type[dimen])
+ {
+ case DIMEN_ELEMENT:
+ mpz_init (*result);
+ mpz_set_ui (*result, 1);
+ t = SUCCESS;
+ break;
+
+ case DIMEN_VECTOR:
+ t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
+ break;
+
+ case DIMEN_RANGE:
+ mpz_init (upper);
+ mpz_init (lower);
+ mpz_init (stride);
+ t = FAILURE;
+
+ if (ar->start[dimen] == NULL)
+ {
+ if (ar->as->lower[dimen] == NULL
+ || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
+ 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)
+ 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);
+ }
+
+ if (ar->stride[dimen] == NULL)
+ mpz_set_ui (stride, 1);
+ else
+ {
+ if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
+ goto cleanup;
+ mpz_set (stride, ar->stride[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 = SUCCESS;
+
+ cleanup:
+ mpz_clear (upper);
+ mpz_clear (lower);
+ mpz_clear (stride);
+ return t;
+
+ default:
+ gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
+ }
+
+ return t;
+}
+
+
+static try
+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 (ref_dimen_size (ar, d, &size) == FAILURE)
+ {
+ mpz_clear (*result);
+ return FAILURE;
+ }
+
+ mpz_mul (*result, *result, size);
+ mpz_clear (size);
+ }
+
+ return SUCCESS;
+}
+
+
+/* Given an array expression and a dimension, figure out how many
+ elements it has along that dimension. Returns SUCCESS if we were
+ 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_ref *ref;
+ int i;
+
+ if (dimen < 0 || array == NULL || 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 ref_dimen_size (&ref->u.ar, i - 1, result);
+ }
+ }
+
+ if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
+ return FAILURE;
+
+ 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 FAILURE;
+
+ mpz_init_set (*result, array->shape[dimen]);
+
+ break;
+ }
+
+ return SUCCESS;
+}
+
+
+/* Given an array expression, figure out how many elements are in the
+ 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)
+{
+ expand_info expand_save;
+ gfc_ref *ref;
+ int i, flag;
+ try t;
+
+ switch (array->expr_type)
+ {
+ case EXPR_ARRAY:
+ flag = gfc_suppress_error;
+ gfc_suppress_error = 1;
+
+ 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_suppress_error = flag;
+
+ if (t == FAILURE)
+ 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 FAILURE;
+
+ mpz_init_set_ui (*result, 1);
+
+ for (i = 0; i < array->rank; i++)
+ mpz_mul (*result, *result, array->shape[i]);
+
+ break;
+ }
+
+ return SUCCESS;
+}
+
+
+/* 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)
+{
+ 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]) == FAILURE)
+ goto cleanup;
+
+ return SUCCESS;
+
+ case AR_SECTION:
+ for (i = 0; i < ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] != DIMEN_ELEMENT)
+ {
+ if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
+ goto cleanup;
+ d++;
+ }
+ }
+
+ return SUCCESS;
+
+ default:
+ break;
+ }
+
+cleanup:
+ for (d--; d >= 0; d--)
+ mpz_clear (shape[d]);
+
+ return FAILURE;
+}
+
+
+/* Given an array expression, find the array reference structure that
+ characterizes the reference. */
+
+gfc_array_ref *
+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))
+ break;
+
+ if (ref == NULL)
+ gfc_internal_error ("gfc_find_array_ref(): No ref found");
+
+ return &ref->u.ar;
+}