2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
26 #include "constructor.h"
28 /**************** Array reference matching subroutines *****************/
30 /* Copy an array reference structure. */
33 gfc_copy_array_ref (gfc_array_ref *src)
41 dest = gfc_get_array_ref ();
45 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
47 dest->start[i] = gfc_copy_expr (src->start[i]);
48 dest->end[i] = gfc_copy_expr (src->end[i]);
49 dest->stride[i] = gfc_copy_expr (src->stride[i]);
52 dest->offset = gfc_copy_expr (src->offset);
58 /* Match a single dimension of an array reference. This can be a
59 single element or an array section. Any modifications we've made
60 to the ar structure are cleaned up by the caller. If the init
61 is set, we require the subscript to be a valid initialization
65 match_subscript (gfc_array_ref *ar, int init, bool match_star)
67 match m = MATCH_ERROR;
71 i = ar->dimen + ar->codimen;
73 ar->c_where[i] = gfc_current_locus;
74 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
76 /* We can't be sure of the difference between DIMEN_ELEMENT and
77 DIMEN_VECTOR until we know the type of the element itself at
80 ar->dimen_type[i] = DIMEN_UNKNOWN;
82 if (gfc_match_char (':') == MATCH_YES)
85 /* Get start element. */
86 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
90 m = gfc_match_init_expr (&ar->start[i]);
92 m = gfc_match_expr (&ar->start[i]);
94 if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES)
96 else if (m == MATCH_NO)
97 gfc_error ("Expected array subscript at %C");
101 if (gfc_match_char (':') == MATCH_NO)
106 gfc_error ("Unexpected '*' in coarray subscript at %C");
110 /* Get an optional end element. Because we've seen the colon, we
111 definitely have a range along this dimension. */
113 ar->dimen_type[i] = DIMEN_RANGE;
115 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
118 m = gfc_match_init_expr (&ar->end[i]);
120 m = gfc_match_expr (&ar->end[i]);
122 if (m == MATCH_ERROR)
125 /* See if we have an optional stride. */
126 if (gfc_match_char (':') == MATCH_YES)
130 gfc_error ("Strides not allowed in coarray subscript at %C");
134 m = init ? gfc_match_init_expr (&ar->stride[i])
135 : gfc_match_expr (&ar->stride[i]);
138 gfc_error ("Expected array subscript stride at %C");
145 ar->dimen_type[i] = DIMEN_STAR;
151 /* Match an array reference, whether it is the whole array or a
152 particular elements or a section. If init is set, the reference has
153 to consist of init expressions. */
156 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
160 bool matched_bracket = false;
162 memset (ar, '\0', sizeof (ar));
164 ar->where = gfc_current_locus;
166 ar->type = AR_UNKNOWN;
168 if (gfc_match_char ('[') == MATCH_YES)
170 matched_bracket = true;
174 if (gfc_match_char ('(') != MATCH_YES)
181 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
183 m = match_subscript (ar, init, false);
184 if (m == MATCH_ERROR)
187 if (gfc_match_char (')') == MATCH_YES)
193 if (gfc_match_char (',') != MATCH_YES)
195 gfc_error ("Invalid form of array reference at %C");
200 gfc_error ("Array reference at %C cannot have more than %d dimensions",
205 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
213 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
215 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
221 gfc_error ("Unexpected coarray designator at %C");
225 for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
227 m = match_subscript (ar, init, ar->codimen == (corank - 1));
228 if (m == MATCH_ERROR)
231 if (gfc_match_char (']') == MATCH_YES)
234 if (ar->codimen < corank)
236 gfc_error ("Too few codimensions at %C, expected %d not %d",
237 corank, ar->codimen);
243 if (gfc_match_char (',') != MATCH_YES)
245 if (gfc_match_char ('*') == MATCH_YES)
246 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
247 ar->codimen + 1, corank);
249 gfc_error ("Invalid form of coarray reference at %C");
252 if (ar->codimen >= corank)
254 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
255 ar->codimen + 1, corank);
260 gfc_error ("Array reference at %C cannot have more than %d dimensions",
267 /************** Array specification matching subroutines ***************/
269 /* Free all of the expressions associated with array bounds
273 gfc_free_array_spec (gfc_array_spec *as)
280 for (i = 0; i < as->rank + as->corank; i++)
282 gfc_free_expr (as->lower[i]);
283 gfc_free_expr (as->upper[i]);
290 /* Take an array bound, resolves the expression, that make up the
291 shape and check associated constraints. */
294 resolve_array_bound (gfc_expr *e, int check_constant)
299 if (gfc_resolve_expr (e) == FAILURE
300 || gfc_specification_expr (e) == FAILURE)
303 if (check_constant && !gfc_is_constant_expr (e))
305 if (e->expr_type == EXPR_VARIABLE)
306 gfc_error ("Variable '%s' at %L in this context must be constant",
307 e->symtree->n.sym->name, &e->where);
309 gfc_error ("Expression at %L in this context must be constant",
318 /* Takes an array specification, resolves the expressions that make up
319 the shape and make sure everything is integral. */
322 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
330 for (i = 0; i < as->rank + as->corank; i++)
333 if (resolve_array_bound (e, check_constant) == FAILURE)
337 if (resolve_array_bound (e, check_constant) == FAILURE)
340 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
343 /* If the size is negative in this dimension, set it to zero. */
344 if (as->lower[i]->expr_type == EXPR_CONSTANT
345 && as->upper[i]->expr_type == EXPR_CONSTANT
346 && mpz_cmp (as->upper[i]->value.integer,
347 as->lower[i]->value.integer) < 0)
349 gfc_free_expr (as->upper[i]);
350 as->upper[i] = gfc_copy_expr (as->lower[i]);
351 mpz_sub_ui (as->upper[i]->value.integer,
352 as->upper[i]->value.integer, 1);
360 /* Match a single array element specification. The return values as
361 well as the upper and lower bounds of the array spec are filled
362 in according to what we see on the input. The caller makes sure
363 individual specifications make sense as a whole.
366 Parsed Lower Upper Returned
367 ------------------------------------
368 : NULL NULL AS_DEFERRED (*)
370 x: x NULL AS_ASSUMED_SHAPE
372 x:* x NULL AS_ASSUMED_SIZE
373 * 1 NULL AS_ASSUMED_SIZE
375 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
376 is fixed during the resolution of formal interfaces.
378 Anything else AS_UNKNOWN. */
381 match_array_element_spec (gfc_array_spec *as)
383 gfc_expr **upper, **lower;
386 lower = &as->lower[as->rank + as->corank - 1];
387 upper = &as->upper[as->rank + as->corank - 1];
389 if (gfc_match_char ('*') == MATCH_YES)
391 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
392 return AS_ASSUMED_SIZE;
395 if (gfc_match_char (':') == MATCH_YES)
398 m = gfc_match_expr (upper);
400 gfc_error ("Expected expression in array specification at %C");
403 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
406 if (gfc_match_char (':') == MATCH_NO)
408 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
415 if (gfc_match_char ('*') == MATCH_YES)
416 return AS_ASSUMED_SIZE;
418 m = gfc_match_expr (upper);
419 if (m == MATCH_ERROR)
422 return AS_ASSUMED_SHAPE;
423 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
430 /* Matches an array specification, incidentally figuring out what sort
431 it is. Match either a normal array specification, or a coarray spec
432 or both. Optionally allow [:] for coarrays. */
435 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
437 array_type current_type;
441 as = gfc_get_array_spec ();
446 if (gfc_match_char ('(') != MATCH_YES)
456 current_type = match_array_element_spec (as);
458 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
459 and implied-shape specifications. If the rank is at least 2, we can
460 distinguish between them. But for rank 1, we currently return
461 ASSUMED_SIZE; this gets adjusted later when we know for sure
462 whether the symbol parsed is a PARAMETER or not. */
466 if (current_type == AS_UNKNOWN)
468 as->type = current_type;
472 { /* See how current spec meshes with the existing. */
476 case AS_IMPLIED_SHAPE:
477 if (current_type != AS_ASSUMED_SHAPE)
479 gfc_error ("Bad array specification for implied-shape"
486 if (current_type == AS_ASSUMED_SIZE)
488 as->type = AS_ASSUMED_SIZE;
492 if (current_type == AS_EXPLICIT)
495 gfc_error ("Bad array specification for an explicitly shaped "
500 case AS_ASSUMED_SHAPE:
501 if ((current_type == AS_ASSUMED_SHAPE)
502 || (current_type == AS_DEFERRED))
505 gfc_error ("Bad array specification for assumed shape "
510 if (current_type == AS_DEFERRED)
513 if (current_type == AS_ASSUMED_SHAPE)
515 as->type = AS_ASSUMED_SHAPE;
519 gfc_error ("Bad specification for deferred shape array at %C");
522 case AS_ASSUMED_SIZE:
523 if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
525 as->type = AS_IMPLIED_SHAPE;
529 gfc_error ("Bad specification for assumed size array at %C");
533 if (gfc_match_char (')') == MATCH_YES)
536 if (gfc_match_char (',') != MATCH_YES)
538 gfc_error ("Expected another dimension in array declaration at %C");
542 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
544 gfc_error ("Array specification at %C has more than %d dimensions",
549 if (as->corank + as->rank >= 7
550 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
551 "specification at %C with more than 7 dimensions")
560 if (gfc_match_char ('[') != MATCH_YES)
563 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
567 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
569 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
576 current_type = match_array_element_spec (as);
578 if (current_type == AS_UNKNOWN)
582 as->cotype = current_type;
585 { /* See how current spec meshes with the existing. */
586 case AS_IMPLIED_SHAPE:
591 if (current_type == AS_ASSUMED_SIZE)
593 as->cotype = AS_ASSUMED_SIZE;
597 if (current_type == AS_EXPLICIT)
600 gfc_error ("Bad array specification for an explicitly "
601 "shaped array at %C");
605 case AS_ASSUMED_SHAPE:
606 if ((current_type == AS_ASSUMED_SHAPE)
607 || (current_type == AS_DEFERRED))
610 gfc_error ("Bad array specification for assumed shape "
615 if (current_type == AS_DEFERRED)
618 if (current_type == AS_ASSUMED_SHAPE)
620 as->cotype = AS_ASSUMED_SHAPE;
624 gfc_error ("Bad specification for deferred shape array at %C");
627 case AS_ASSUMED_SIZE:
628 gfc_error ("Bad specification for assumed size array at %C");
632 if (gfc_match_char (']') == MATCH_YES)
635 if (gfc_match_char (',') != MATCH_YES)
637 gfc_error ("Expected another dimension in array declaration at %C");
641 if (as->corank >= GFC_MAX_DIMENSIONS)
643 gfc_error ("Array specification at %C has more than %d "
644 "dimensions", GFC_MAX_DIMENSIONS);
649 if (current_type == AS_EXPLICIT)
651 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
655 if (as->cotype == AS_ASSUMED_SIZE)
656 as->cotype = AS_EXPLICIT;
659 as->type = as->cotype;
662 if (as->rank == 0 && as->corank == 0)
665 gfc_free_array_spec (as);
669 /* If a lower bounds of an assumed shape array is blank, put in one. */
670 if (as->type == AS_ASSUMED_SHAPE)
672 for (i = 0; i < as->rank + as->corank; i++)
674 if (as->lower[i] == NULL)
675 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
684 /* Something went wrong. */
685 gfc_free_array_spec (as);
690 /* Given a symbol and an array specification, modify the symbol to
691 have that array specification. The error locus is needed in case
692 something goes wrong. On failure, the caller must free the spec. */
695 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
703 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
707 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
718 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
719 the codimension is simply added. */
720 gcc_assert (as->rank == 0 && sym->as->corank == 0);
722 sym->as->cotype = as->cotype;
723 sym->as->corank = as->corank;
724 for (i = 0; i < as->corank; i++)
726 sym->as->lower[sym->as->rank + i] = as->lower[i];
727 sym->as->upper[sym->as->rank + i] = as->upper[i];
732 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
733 the dimension is added - but first the codimensions (if existing
734 need to be shifted to make space for the dimension. */
735 gcc_assert (as->corank == 0 && sym->as->rank == 0);
737 sym->as->rank = as->rank;
738 sym->as->type = as->type;
739 sym->as->cray_pointee = as->cray_pointee;
740 sym->as->cp_was_assumed = as->cp_was_assumed;
742 for (i = 0; i < sym->as->corank; i++)
744 sym->as->lower[as->rank + i] = sym->as->lower[i];
745 sym->as->upper[as->rank + i] = sym->as->upper[i];
747 for (i = 0; i < as->rank; i++)
749 sym->as->lower[i] = as->lower[i];
750 sym->as->upper[i] = as->upper[i];
759 /* Copy an array specification. */
762 gfc_copy_array_spec (gfc_array_spec *src)
764 gfc_array_spec *dest;
770 dest = gfc_get_array_spec ();
774 for (i = 0; i < dest->rank + dest->corank; i++)
776 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
777 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
784 /* Returns nonzero if the two expressions are equal. Only handles integer
788 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
790 if (bound1 == NULL || bound2 == NULL
791 || bound1->expr_type != EXPR_CONSTANT
792 || bound2->expr_type != EXPR_CONSTANT
793 || bound1->ts.type != BT_INTEGER
794 || bound2->ts.type != BT_INTEGER)
795 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
797 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
804 /* Compares two array specifications. They must be constant or deferred
808 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
812 if (as1 == NULL && as2 == NULL)
815 if (as1 == NULL || as2 == NULL)
818 if (as1->rank != as2->rank)
821 if (as1->corank != as2->corank)
827 if (as1->type != as2->type)
830 if (as1->type == AS_EXPLICIT)
831 for (i = 0; i < as1->rank + as1->corank; i++)
833 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
836 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
844 /****************** Array constructor functions ******************/
847 /* Given an expression node that might be an array constructor and a
848 symbol, make sure that no iterators in this or child constructors
849 use the symbol as an implied-DO iterator. Returns nonzero if a
850 duplicate was found. */
853 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
858 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
862 if (e->expr_type == EXPR_ARRAY
863 && check_duplicate_iterator (e->value.constructor, master))
866 if (c->iterator == NULL)
869 if (c->iterator->var->symtree->n.sym == master)
871 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
872 "same name", master->name, &c->where);
882 /* Forward declaration because these functions are mutually recursive. */
883 static match match_array_cons_element (gfc_constructor_base *);
885 /* Match a list of array elements. */
888 match_array_list (gfc_constructor_base *result)
890 gfc_constructor_base head;
898 old_loc = gfc_current_locus;
900 if (gfc_match_char ('(') == MATCH_NO)
903 memset (&iter, '\0', sizeof (gfc_iterator));
906 m = match_array_cons_element (&head);
910 if (gfc_match_char (',') != MATCH_YES)
918 m = gfc_match_iterator (&iter, 0);
921 if (m == MATCH_ERROR)
924 m = match_array_cons_element (&head);
925 if (m == MATCH_ERROR)
932 goto cleanup; /* Could be a complex constant */
935 if (gfc_match_char (',') != MATCH_YES)
944 if (gfc_match_char (')') != MATCH_YES)
947 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
953 e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
954 e->value.constructor = head;
956 p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
957 p->iterator = gfc_get_iterator ();
963 gfc_error ("Syntax error in array constructor at %C");
967 gfc_constructor_free (head);
968 gfc_free_iterator (&iter, 0);
969 gfc_current_locus = old_loc;
974 /* Match a single element of an array constructor, which can be a
975 single expression or a list of elements. */
978 match_array_cons_element (gfc_constructor_base *result)
983 m = match_array_list (result);
987 m = gfc_match_expr (&expr);
991 gfc_constructor_append_expr (result, expr, &gfc_current_locus);
996 /* Match an array constructor. */
999 gfc_match_array_constructor (gfc_expr **result)
1001 gfc_constructor_base head, new_cons;
1006 const char *end_delim;
1009 if (gfc_match (" (/") == MATCH_NO)
1011 if (gfc_match (" [") == MATCH_NO)
1015 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1016 "style array constructors at %C") == FAILURE)
1024 where = gfc_current_locus;
1025 head = new_cons = NULL;
1028 /* Try to match an optional "type-spec ::" */
1029 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1031 seen_ts = (gfc_match (" ::") == MATCH_YES);
1035 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1036 "including type specification at %C") == FAILURE)
1041 gfc_error ("Type-spec at %L cannot contain a deferred "
1042 "type parameter", &where);
1049 gfc_current_locus = where;
1051 if (gfc_match (end_delim) == MATCH_YES)
1057 gfc_error ("Empty array constructor at %C is not allowed");
1064 m = match_array_cons_element (&head);
1065 if (m == MATCH_ERROR)
1070 if (gfc_match_char (',') == MATCH_NO)
1074 if (gfc_match (end_delim) == MATCH_NO)
1078 /* Size must be calculated at resolution time. */
1081 expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1085 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1087 expr->value.constructor = head;
1089 expr->ts.u.cl->length_from_typespec = seen_ts;
1095 gfc_error ("Syntax error in array constructor at %C");
1098 gfc_constructor_free (head);
1104 /************** Check array constructors for correctness **************/
1106 /* Given an expression, compare it's type with the type of the current
1107 constructor. Returns nonzero if an error was issued. The
1108 cons_state variable keeps track of whether the type of the
1109 constructor being read or resolved is known to be good, bad or just
1112 static gfc_typespec constructor_ts;
1114 { CONS_START, CONS_GOOD, CONS_BAD }
1118 check_element_type (gfc_expr *expr, bool convert)
1120 if (cons_state == CONS_BAD)
1121 return 0; /* Suppress further errors */
1123 if (cons_state == CONS_START)
1125 if (expr->ts.type == BT_UNKNOWN)
1126 cons_state = CONS_BAD;
1129 cons_state = CONS_GOOD;
1130 constructor_ts = expr->ts;
1136 if (gfc_compare_types (&constructor_ts, &expr->ts))
1140 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1142 gfc_error ("Element in %s array constructor at %L is %s",
1143 gfc_typename (&constructor_ts), &expr->where,
1144 gfc_typename (&expr->ts));
1146 cons_state = CONS_BAD;
1151 /* Recursive work function for gfc_check_constructor_type(). */
1154 check_constructor_type (gfc_constructor_base base, bool convert)
1159 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1163 if (e->expr_type == EXPR_ARRAY)
1165 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1171 if (check_element_type (e, convert))
1179 /* Check that all elements of an array constructor are the same type.
1180 On FAILURE, an error has been generated. */
1183 gfc_check_constructor_type (gfc_expr *e)
1187 if (e->ts.type != BT_UNKNOWN)
1189 cons_state = CONS_GOOD;
1190 constructor_ts = e->ts;
1194 cons_state = CONS_START;
1195 gfc_clear_ts (&constructor_ts);
1198 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1199 typespec, and we will now convert the values on the fly. */
1200 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1201 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1202 e->ts = constructor_ts;
1209 typedef struct cons_stack
1211 gfc_iterator *iterator;
1212 struct cons_stack *previous;
1216 static cons_stack *base;
1218 static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1220 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1221 that that variable is an iteration variables. */
1224 gfc_check_iter_variable (gfc_expr *expr)
1229 sym = expr->symtree->n.sym;
1231 for (c = base; c && c->iterator; c = c->previous)
1232 if (sym == c->iterator->var->symtree->n.sym)
1239 /* Recursive work function for gfc_check_constructor(). This amounts
1240 to calling the check function for each expression in the
1241 constructor, giving variables with the names of iterators a pass. */
1244 check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1251 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1255 if (e->expr_type != EXPR_ARRAY)
1257 if ((*check_function) (e) == FAILURE)
1262 element.previous = base;
1263 element.iterator = c->iterator;
1266 t = check_constructor (e->value.constructor, check_function);
1267 base = element.previous;
1273 /* Nothing went wrong, so all OK. */
1278 /* Checks a constructor to see if it is a particular kind of
1279 expression -- specification, restricted, or initialization as
1280 determined by the check_function. */
1283 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1285 cons_stack *base_save;
1291 t = check_constructor (expr->value.constructor, check_function);
1299 /**************** Simplification of array constructors ****************/
1301 iterator_stack *iter_stack;
1305 gfc_constructor_base base;
1306 int extract_count, extract_n;
1307 gfc_expr *extracted;
1311 gfc_component *component;
1313 gfc_try (*expand_work_function) (gfc_expr *);
1317 static expand_info current_expand;
1319 static gfc_try expand_constructor (gfc_constructor_base);
1322 /* Work function that counts the number of elements present in a
1326 count_elements (gfc_expr *e)
1331 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1334 if (gfc_array_size (e, &result) == FAILURE)
1340 mpz_add (*current_expand.count, *current_expand.count, result);
1349 /* Work function that extracts a particular element from an array
1350 constructor, freeing the rest. */
1353 extract_element (gfc_expr *e)
1356 { /* Something unextractable */
1361 if (current_expand.extract_count == current_expand.extract_n)
1362 current_expand.extracted = e;
1366 current_expand.extract_count++;
1372 /* Work function that constructs a new constructor out of the old one,
1373 stringing new elements together. */
1376 expand (gfc_expr *e)
1378 gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
1381 c->n.component = current_expand.component;
1386 /* Given an initialization expression that is a variable reference,
1387 substitute the current value of the iteration variable. */
1390 gfc_simplify_iterator_var (gfc_expr *e)
1394 for (p = iter_stack; p; p = p->prev)
1395 if (e->symtree == p->variable)
1399 return; /* Variable not found */
1401 gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1403 mpz_set (e->value.integer, p->value);
1409 /* Expand an expression with that is inside of a constructor,
1410 recursing into other constructors if present. */
1413 expand_expr (gfc_expr *e)
1415 if (e->expr_type == EXPR_ARRAY)
1416 return expand_constructor (e->value.constructor);
1418 e = gfc_copy_expr (e);
1420 if (gfc_simplify_expr (e, 1) == FAILURE)
1426 return current_expand.expand_work_function (e);
1431 expand_iterator (gfc_constructor *c)
1433 gfc_expr *start, *end, *step;
1434 iterator_stack frame;
1443 mpz_init (frame.value);
1446 start = gfc_copy_expr (c->iterator->start);
1447 if (gfc_simplify_expr (start, 1) == FAILURE)
1450 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1453 end = gfc_copy_expr (c->iterator->end);
1454 if (gfc_simplify_expr (end, 1) == FAILURE)
1457 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1460 step = gfc_copy_expr (c->iterator->step);
1461 if (gfc_simplify_expr (step, 1) == FAILURE)
1464 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1467 if (mpz_sgn (step->value.integer) == 0)
1469 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1473 /* Calculate the trip count of the loop. */
1474 mpz_sub (trip, end->value.integer, start->value.integer);
1475 mpz_add (trip, trip, step->value.integer);
1476 mpz_tdiv_q (trip, trip, step->value.integer);
1478 mpz_set (frame.value, start->value.integer);
1480 frame.prev = iter_stack;
1481 frame.variable = c->iterator->var->symtree;
1482 iter_stack = &frame;
1484 while (mpz_sgn (trip) > 0)
1486 if (expand_expr (c->expr) == FAILURE)
1489 mpz_add (frame.value, frame.value, step->value.integer);
1490 mpz_sub_ui (trip, trip, 1);
1496 gfc_free_expr (start);
1497 gfc_free_expr (end);
1498 gfc_free_expr (step);
1501 mpz_clear (frame.value);
1503 iter_stack = frame.prev;
1509 /* Expand a constructor into constant constructors without any
1510 iterators, calling the work function for each of the expanded
1511 expressions. The work function needs to either save or free the
1512 passed expression. */
1515 expand_constructor (gfc_constructor_base base)
1520 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1522 if (c->iterator != NULL)
1524 if (expand_iterator (c) == FAILURE)
1531 if (e->expr_type == EXPR_ARRAY)
1533 if (expand_constructor (e->value.constructor) == FAILURE)
1539 e = gfc_copy_expr (e);
1540 if (gfc_simplify_expr (e, 1) == FAILURE)
1545 current_expand.offset = &c->offset;
1546 current_expand.component = c->n.component;
1547 if (current_expand.expand_work_function (e) == FAILURE)
1554 /* Given an array expression and an element number (starting at zero),
1555 return a pointer to the array element. NULL is returned if the
1556 size of the array has been exceeded. The expression node returned
1557 remains a part of the array and should not be freed. Access is not
1558 efficient at all, but this is another place where things do not
1559 have to be particularly fast. */
1562 gfc_get_array_element (gfc_expr *array, int element)
1564 expand_info expand_save;
1568 expand_save = current_expand;
1569 current_expand.extract_n = element;
1570 current_expand.expand_work_function = extract_element;
1571 current_expand.extracted = NULL;
1572 current_expand.extract_count = 0;
1576 rc = expand_constructor (array->value.constructor);
1577 e = current_expand.extracted;
1578 current_expand = expand_save;
1587 /* Top level subroutine for expanding constructors. We only expand
1588 constructor if they are small enough. */
1591 gfc_expand_constructor (gfc_expr *e, bool fatal)
1593 expand_info expand_save;
1597 /* If we can successfully get an array element at the max array size then
1598 the array is too big to expand, so we just return. */
1599 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1605 gfc_error ("The number of elements in the array constructor "
1606 "at %L requires an increase of the allowed %d "
1607 "upper limit. See -fmax-array-constructor "
1608 "option", &e->where,
1609 gfc_option.flag_max_array_constructor);
1615 /* We now know the array is not too big so go ahead and try to expand it. */
1616 expand_save = current_expand;
1617 current_expand.base = NULL;
1621 current_expand.expand_work_function = expand;
1623 if (expand_constructor (e->value.constructor) == FAILURE)
1625 gfc_constructor_free (current_expand.base);
1630 gfc_constructor_free (e->value.constructor);
1631 e->value.constructor = current_expand.base;
1636 current_expand = expand_save;
1642 /* Work function for checking that an element of a constructor is a
1643 constant, after removal of any iteration variables. We return
1644 FAILURE if not so. */
1647 is_constant_element (gfc_expr *e)
1651 rv = gfc_is_constant_expr (e);
1654 return rv ? SUCCESS : FAILURE;
1658 /* Given an array constructor, determine if the constructor is
1659 constant or not by expanding it and making sure that all elements
1660 are constants. This is a bit of a hack since something like (/ (i,
1661 i=1,100000000) /) will take a while as* opposed to a more clever
1662 function that traverses the expression tree. FIXME. */
1665 gfc_constant_ac (gfc_expr *e)
1667 expand_info expand_save;
1671 expand_save = current_expand;
1672 current_expand.expand_work_function = is_constant_element;
1674 rc = expand_constructor (e->value.constructor);
1676 current_expand = expand_save;
1684 /* Returns nonzero if an array constructor has been completely
1685 expanded (no iterators) and zero if iterators are present. */
1688 gfc_expanded_ac (gfc_expr *e)
1692 if (e->expr_type == EXPR_ARRAY)
1693 for (c = gfc_constructor_first (e->value.constructor);
1694 c; c = gfc_constructor_next (c))
1695 if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1702 /*************** Type resolution of array constructors ***************/
1704 /* Recursive array list resolution function. All of the elements must
1705 be of the same type. */
1708 resolve_array_list (gfc_constructor_base base)
1715 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1717 if (c->iterator != NULL
1718 && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1721 if (gfc_resolve_expr (c->expr) == FAILURE)
1728 /* Resolve character array constructor. If it has a specified constant character
1729 length, pad/truncate the elements here; if the length is not specified and
1730 all elements are of compile-time known length, emit an error as this is
1734 gfc_resolve_character_array_constructor (gfc_expr *expr)
1739 gcc_assert (expr->expr_type == EXPR_ARRAY);
1740 gcc_assert (expr->ts.type == BT_CHARACTER);
1742 if (expr->ts.u.cl == NULL)
1744 for (p = gfc_constructor_first (expr->value.constructor);
1745 p; p = gfc_constructor_next (p))
1746 if (p->expr->ts.u.cl != NULL)
1748 /* Ensure that if there is a char_len around that it is
1749 used; otherwise the middle-end confuses them! */
1750 expr->ts.u.cl = p->expr->ts.u.cl;
1754 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1761 if (expr->ts.u.cl->length == NULL)
1763 /* Check that all constant string elements have the same length until
1764 we reach the end or find a variable-length one. */
1766 for (p = gfc_constructor_first (expr->value.constructor);
1767 p; p = gfc_constructor_next (p))
1769 int current_length = -1;
1771 for (ref = p->expr->ref; ref; ref = ref->next)
1772 if (ref->type == REF_SUBSTRING
1773 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1774 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1777 if (p->expr->expr_type == EXPR_CONSTANT)
1778 current_length = p->expr->value.character.length;
1782 j = mpz_get_ui (ref->u.ss.end->value.integer)
1783 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1784 current_length = (int) j;
1786 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1787 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1790 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1791 current_length = (int) j;
1796 gcc_assert (current_length != -1);
1798 if (found_length == -1)
1799 found_length = current_length;
1800 else if (found_length != current_length)
1802 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1803 " constructor at %L", found_length, current_length,
1808 gcc_assert (found_length == current_length);
1811 gcc_assert (found_length != -1);
1813 /* Update the character length of the array constructor. */
1814 expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1815 NULL, found_length);
1819 /* We've got a character length specified. It should be an integer,
1820 otherwise an error is signalled elsewhere. */
1821 gcc_assert (expr->ts.u.cl->length);
1823 /* If we've got a constant character length, pad according to this.
1824 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1825 max_length only if they pass. */
1826 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1828 /* Now pad/truncate the elements accordingly to the specified character
1829 length. This is ok inside this conditional, as in the case above
1830 (without typespec) all elements are verified to have the same length
1832 if (found_length != -1)
1833 for (p = gfc_constructor_first (expr->value.constructor);
1834 p; p = gfc_constructor_next (p))
1835 if (p->expr->expr_type == EXPR_CONSTANT)
1837 gfc_expr *cl = NULL;
1838 int current_length = -1;
1841 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1843 cl = p->expr->ts.u.cl->length;
1844 gfc_extract_int (cl, ¤t_length);
1847 /* If gfc_extract_int above set current_length, we implicitly
1848 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1850 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1853 || (current_length != -1 && current_length != found_length))
1854 gfc_set_constant_character_len (found_length, p->expr,
1855 has_ts ? -1 : found_length);
1863 /* Resolve all of the expressions in an array list. */
1866 gfc_resolve_array_constructor (gfc_expr *expr)
1870 t = resolve_array_list (expr->value.constructor);
1872 t = gfc_check_constructor_type (expr);
1874 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1875 the call to this function, so we don't need to call it here; if it was
1876 called twice, an error message there would be duplicated. */
1882 /* Copy an iterator structure. */
1885 gfc_copy_iterator (gfc_iterator *src)
1892 dest = gfc_get_iterator ();
1894 dest->var = gfc_copy_expr (src->var);
1895 dest->start = gfc_copy_expr (src->start);
1896 dest->end = gfc_copy_expr (src->end);
1897 dest->step = gfc_copy_expr (src->step);
1903 /********* Subroutines for determining the size of an array *********/
1905 /* These are needed just to accommodate RESHAPE(). There are no
1906 diagnostics here, we just return a negative number if something
1910 /* Get the size of single dimension of an array specification. The
1911 array is guaranteed to be one dimensional. */
1914 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1919 if (dimen < 0 || dimen > as->rank - 1)
1920 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1922 if (as->type != AS_EXPLICIT
1923 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1924 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1925 || as->lower[dimen]->ts.type != BT_INTEGER
1926 || as->upper[dimen]->ts.type != BT_INTEGER)
1931 mpz_sub (*result, as->upper[dimen]->value.integer,
1932 as->lower[dimen]->value.integer);
1934 mpz_add_ui (*result, *result, 1);
1941 spec_size (gfc_array_spec *as, mpz_t *result)
1946 mpz_init_set_ui (*result, 1);
1948 for (d = 0; d < as->rank; d++)
1950 if (spec_dimen_size (as, d, &size) == FAILURE)
1952 mpz_clear (*result);
1956 mpz_mul (*result, *result, size);
1964 /* Get the number of elements in an array section. Optionally, also supply
1968 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
1970 mpz_t upper, lower, stride;
1973 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1974 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1976 switch (ar->dimen_type[dimen])
1980 mpz_set_ui (*result, 1);
1985 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1994 if (ar->start[dimen] == NULL)
1996 if (ar->as->lower[dimen] == NULL
1997 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1999 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2003 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2005 mpz_set (lower, ar->start[dimen]->value.integer);
2008 if (ar->end[dimen] == NULL)
2010 if (ar->as->upper[dimen] == NULL
2011 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2013 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2017 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2019 mpz_set (upper, ar->end[dimen]->value.integer);
2022 if (ar->stride[dimen] == NULL)
2023 mpz_set_ui (stride, 1);
2026 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2028 mpz_set (stride, ar->stride[dimen]->value.integer);
2032 mpz_sub (*result, upper, lower);
2033 mpz_add (*result, *result, stride);
2034 mpz_div (*result, *result, stride);
2036 /* Zero stride caught earlier. */
2037 if (mpz_cmp_ui (*result, 0) < 0)
2038 mpz_set_ui (*result, 0);
2045 mpz_sub_ui (*end, *result, 1UL);
2046 mpz_mul (*end, *end, stride);
2047 mpz_add (*end, *end, lower);
2057 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2065 ref_size (gfc_array_ref *ar, mpz_t *result)
2070 mpz_init_set_ui (*result, 1);
2072 for (d = 0; d < ar->dimen; d++)
2074 if (gfc_ref_dimen_size (ar, d, &size, NULL) == FAILURE)
2076 mpz_clear (*result);
2080 mpz_mul (*result, *result, size);
2088 /* Given an array expression and a dimension, figure out how many
2089 elements it has along that dimension. Returns SUCCESS if we were
2090 able to return a result in the 'result' variable, FAILURE
2094 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2099 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2100 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2102 switch (array->expr_type)
2106 for (ref = array->ref; ref; ref = ref->next)
2108 if (ref->type != REF_ARRAY)
2111 if (ref->u.ar.type == AR_FULL)
2112 return spec_dimen_size (ref->u.ar.as, dimen, result);
2114 if (ref->u.ar.type == AR_SECTION)
2116 for (i = 0; dimen >= 0; i++)
2117 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2120 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2124 if (array->shape && array->shape[dimen])
2126 mpz_init_set (*result, array->shape[dimen]);
2130 if (array->symtree->n.sym->attr.generic
2131 && array->value.function.esym != NULL)
2133 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2137 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2144 if (array->shape == NULL) {
2145 /* Expressions with rank > 1 should have "shape" properly set */
2146 if ( array->rank != 1 )
2147 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2148 return gfc_array_size(array, result);
2153 if (array->shape == NULL)
2156 mpz_init_set (*result, array->shape[dimen]);
2165 /* Given an array expression, figure out how many elements are in the
2166 array. Returns SUCCESS if this is possible, and sets the 'result'
2167 variable. Otherwise returns FAILURE. */
2170 gfc_array_size (gfc_expr *array, mpz_t *result)
2172 expand_info expand_save;
2177 switch (array->expr_type)
2180 gfc_push_suppress_errors ();
2182 expand_save = current_expand;
2184 current_expand.count = result;
2185 mpz_init_set_ui (*result, 0);
2187 current_expand.expand_work_function = count_elements;
2190 t = expand_constructor (array->value.constructor);
2192 gfc_pop_suppress_errors ();
2195 mpz_clear (*result);
2196 current_expand = expand_save;
2200 for (ref = array->ref; ref; ref = ref->next)
2202 if (ref->type != REF_ARRAY)
2205 if (ref->u.ar.type == AR_FULL)
2206 return spec_size (ref->u.ar.as, result);
2208 if (ref->u.ar.type == AR_SECTION)
2209 return ref_size (&ref->u.ar, result);
2212 return spec_size (array->symtree->n.sym->as, result);
2216 if (array->rank == 0 || array->shape == NULL)
2219 mpz_init_set_ui (*result, 1);
2221 for (i = 0; i < array->rank; i++)
2222 mpz_mul (*result, *result, array->shape[i]);
2231 /* Given an array reference, return the shape of the reference in an
2232 array of mpz_t integers. */
2235 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2245 for (; d < ar->as->rank; d++)
2246 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2252 for (i = 0; i < ar->dimen; i++)
2254 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2256 if (gfc_ref_dimen_size (ar, i, &shape[d], NULL) == FAILURE)
2269 for (d--; d >= 0; d--)
2270 mpz_clear (shape[d]);
2276 /* Given an array expression, find the array reference structure that
2277 characterizes the reference. */
2280 gfc_find_array_ref (gfc_expr *e)
2284 for (ref = e->ref; ref; ref = ref->next)
2285 if (ref->type == REF_ARRAY
2286 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
2287 || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
2291 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2297 /* Find out if an array shape is known at compile time. */
2300 gfc_is_compile_time_shape (gfc_array_spec *as)
2304 if (as->type != AS_EXPLICIT)
2307 for (i = 0; i < as->rank; i++)
2308 if (!gfc_is_constant_expr (as->lower[i])
2309 || !gfc_is_constant_expr (as->upper[i]))