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)
1042 gfc_current_locus = where;
1044 if (gfc_match (end_delim) == MATCH_YES)
1050 gfc_error ("Empty array constructor at %C is not allowed");
1057 m = match_array_cons_element (&head);
1058 if (m == MATCH_ERROR)
1063 if (gfc_match_char (',') == MATCH_NO)
1067 if (gfc_match (end_delim) == MATCH_NO)
1071 /* Size must be calculated at resolution time. */
1074 expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1078 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1080 expr->value.constructor = head;
1082 expr->ts.u.cl->length_from_typespec = seen_ts;
1088 gfc_error ("Syntax error in array constructor at %C");
1091 gfc_constructor_free (head);
1097 /************** Check array constructors for correctness **************/
1099 /* Given an expression, compare it's type with the type of the current
1100 constructor. Returns nonzero if an error was issued. The
1101 cons_state variable keeps track of whether the type of the
1102 constructor being read or resolved is known to be good, bad or just
1105 static gfc_typespec constructor_ts;
1107 { CONS_START, CONS_GOOD, CONS_BAD }
1111 check_element_type (gfc_expr *expr, bool convert)
1113 if (cons_state == CONS_BAD)
1114 return 0; /* Suppress further errors */
1116 if (cons_state == CONS_START)
1118 if (expr->ts.type == BT_UNKNOWN)
1119 cons_state = CONS_BAD;
1122 cons_state = CONS_GOOD;
1123 constructor_ts = expr->ts;
1129 if (gfc_compare_types (&constructor_ts, &expr->ts))
1133 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1135 gfc_error ("Element in %s array constructor at %L is %s",
1136 gfc_typename (&constructor_ts), &expr->where,
1137 gfc_typename (&expr->ts));
1139 cons_state = CONS_BAD;
1144 /* Recursive work function for gfc_check_constructor_type(). */
1147 check_constructor_type (gfc_constructor_base base, bool convert)
1152 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1156 if (e->expr_type == EXPR_ARRAY)
1158 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1164 if (check_element_type (e, convert))
1172 /* Check that all elements of an array constructor are the same type.
1173 On FAILURE, an error has been generated. */
1176 gfc_check_constructor_type (gfc_expr *e)
1180 if (e->ts.type != BT_UNKNOWN)
1182 cons_state = CONS_GOOD;
1183 constructor_ts = e->ts;
1187 cons_state = CONS_START;
1188 gfc_clear_ts (&constructor_ts);
1191 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1192 typespec, and we will now convert the values on the fly. */
1193 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1194 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1195 e->ts = constructor_ts;
1202 typedef struct cons_stack
1204 gfc_iterator *iterator;
1205 struct cons_stack *previous;
1209 static cons_stack *base;
1211 static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1213 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1214 that that variable is an iteration variables. */
1217 gfc_check_iter_variable (gfc_expr *expr)
1222 sym = expr->symtree->n.sym;
1224 for (c = base; c && c->iterator; c = c->previous)
1225 if (sym == c->iterator->var->symtree->n.sym)
1232 /* Recursive work function for gfc_check_constructor(). This amounts
1233 to calling the check function for each expression in the
1234 constructor, giving variables with the names of iterators a pass. */
1237 check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1244 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1248 if (e->expr_type != EXPR_ARRAY)
1250 if ((*check_function) (e) == FAILURE)
1255 element.previous = base;
1256 element.iterator = c->iterator;
1259 t = check_constructor (e->value.constructor, check_function);
1260 base = element.previous;
1266 /* Nothing went wrong, so all OK. */
1271 /* Checks a constructor to see if it is a particular kind of
1272 expression -- specification, restricted, or initialization as
1273 determined by the check_function. */
1276 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1278 cons_stack *base_save;
1284 t = check_constructor (expr->value.constructor, check_function);
1292 /**************** Simplification of array constructors ****************/
1294 iterator_stack *iter_stack;
1298 gfc_constructor_base base;
1299 int extract_count, extract_n;
1300 gfc_expr *extracted;
1304 gfc_component *component;
1306 gfc_try (*expand_work_function) (gfc_expr *);
1310 static expand_info current_expand;
1312 static gfc_try expand_constructor (gfc_constructor_base);
1315 /* Work function that counts the number of elements present in a
1319 count_elements (gfc_expr *e)
1324 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1327 if (gfc_array_size (e, &result) == FAILURE)
1333 mpz_add (*current_expand.count, *current_expand.count, result);
1342 /* Work function that extracts a particular element from an array
1343 constructor, freeing the rest. */
1346 extract_element (gfc_expr *e)
1349 { /* Something unextractable */
1354 if (current_expand.extract_count == current_expand.extract_n)
1355 current_expand.extracted = e;
1359 current_expand.extract_count++;
1365 /* Work function that constructs a new constructor out of the old one,
1366 stringing new elements together. */
1369 expand (gfc_expr *e)
1371 gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
1374 c->n.component = current_expand.component;
1379 /* Given an initialization expression that is a variable reference,
1380 substitute the current value of the iteration variable. */
1383 gfc_simplify_iterator_var (gfc_expr *e)
1387 for (p = iter_stack; p; p = p->prev)
1388 if (e->symtree == p->variable)
1392 return; /* Variable not found */
1394 gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1396 mpz_set (e->value.integer, p->value);
1402 /* Expand an expression with that is inside of a constructor,
1403 recursing into other constructors if present. */
1406 expand_expr (gfc_expr *e)
1408 if (e->expr_type == EXPR_ARRAY)
1409 return expand_constructor (e->value.constructor);
1411 e = gfc_copy_expr (e);
1413 if (gfc_simplify_expr (e, 1) == FAILURE)
1419 return current_expand.expand_work_function (e);
1424 expand_iterator (gfc_constructor *c)
1426 gfc_expr *start, *end, *step;
1427 iterator_stack frame;
1436 mpz_init (frame.value);
1439 start = gfc_copy_expr (c->iterator->start);
1440 if (gfc_simplify_expr (start, 1) == FAILURE)
1443 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1446 end = gfc_copy_expr (c->iterator->end);
1447 if (gfc_simplify_expr (end, 1) == FAILURE)
1450 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1453 step = gfc_copy_expr (c->iterator->step);
1454 if (gfc_simplify_expr (step, 1) == FAILURE)
1457 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1460 if (mpz_sgn (step->value.integer) == 0)
1462 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1466 /* Calculate the trip count of the loop. */
1467 mpz_sub (trip, end->value.integer, start->value.integer);
1468 mpz_add (trip, trip, step->value.integer);
1469 mpz_tdiv_q (trip, trip, step->value.integer);
1471 mpz_set (frame.value, start->value.integer);
1473 frame.prev = iter_stack;
1474 frame.variable = c->iterator->var->symtree;
1475 iter_stack = &frame;
1477 while (mpz_sgn (trip) > 0)
1479 if (expand_expr (c->expr) == FAILURE)
1482 mpz_add (frame.value, frame.value, step->value.integer);
1483 mpz_sub_ui (trip, trip, 1);
1489 gfc_free_expr (start);
1490 gfc_free_expr (end);
1491 gfc_free_expr (step);
1494 mpz_clear (frame.value);
1496 iter_stack = frame.prev;
1502 /* Expand a constructor into constant constructors without any
1503 iterators, calling the work function for each of the expanded
1504 expressions. The work function needs to either save or free the
1505 passed expression. */
1508 expand_constructor (gfc_constructor_base base)
1513 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1515 if (c->iterator != NULL)
1517 if (expand_iterator (c) == FAILURE)
1524 if (e->expr_type == EXPR_ARRAY)
1526 if (expand_constructor (e->value.constructor) == FAILURE)
1532 e = gfc_copy_expr (e);
1533 if (gfc_simplify_expr (e, 1) == FAILURE)
1538 current_expand.offset = &c->offset;
1539 current_expand.component = c->n.component;
1540 if (current_expand.expand_work_function (e) == FAILURE)
1547 /* Given an array expression and an element number (starting at zero),
1548 return a pointer to the array element. NULL is returned if the
1549 size of the array has been exceeded. The expression node returned
1550 remains a part of the array and should not be freed. Access is not
1551 efficient at all, but this is another place where things do not
1552 have to be particularly fast. */
1555 gfc_get_array_element (gfc_expr *array, int element)
1557 expand_info expand_save;
1561 expand_save = current_expand;
1562 current_expand.extract_n = element;
1563 current_expand.expand_work_function = extract_element;
1564 current_expand.extracted = NULL;
1565 current_expand.extract_count = 0;
1569 rc = expand_constructor (array->value.constructor);
1570 e = current_expand.extracted;
1571 current_expand = expand_save;
1580 /* Top level subroutine for expanding constructors. We only expand
1581 constructor if they are small enough. */
1584 gfc_expand_constructor (gfc_expr *e, bool fatal)
1586 expand_info expand_save;
1590 /* If we can successfully get an array element at the max array size then
1591 the array is too big to expand, so we just return. */
1592 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1598 gfc_error ("The number of elements in the array constructor "
1599 "at %L requires an increase of the allowed %d "
1600 "upper limit. See -fmax-array-constructor "
1601 "option", &e->where,
1602 gfc_option.flag_max_array_constructor);
1608 /* We now know the array is not too big so go ahead and try to expand it. */
1609 expand_save = current_expand;
1610 current_expand.base = NULL;
1614 current_expand.expand_work_function = expand;
1616 if (expand_constructor (e->value.constructor) == FAILURE)
1618 gfc_constructor_free (current_expand.base);
1623 gfc_constructor_free (e->value.constructor);
1624 e->value.constructor = current_expand.base;
1629 current_expand = expand_save;
1635 /* Work function for checking that an element of a constructor is a
1636 constant, after removal of any iteration variables. We return
1637 FAILURE if not so. */
1640 is_constant_element (gfc_expr *e)
1644 rv = gfc_is_constant_expr (e);
1647 return rv ? SUCCESS : FAILURE;
1651 /* Given an array constructor, determine if the constructor is
1652 constant or not by expanding it and making sure that all elements
1653 are constants. This is a bit of a hack since something like (/ (i,
1654 i=1,100000000) /) will take a while as* opposed to a more clever
1655 function that traverses the expression tree. FIXME. */
1658 gfc_constant_ac (gfc_expr *e)
1660 expand_info expand_save;
1664 expand_save = current_expand;
1665 current_expand.expand_work_function = is_constant_element;
1667 rc = expand_constructor (e->value.constructor);
1669 current_expand = expand_save;
1677 /* Returns nonzero if an array constructor has been completely
1678 expanded (no iterators) and zero if iterators are present. */
1681 gfc_expanded_ac (gfc_expr *e)
1685 if (e->expr_type == EXPR_ARRAY)
1686 for (c = gfc_constructor_first (e->value.constructor);
1687 c; c = gfc_constructor_next (c))
1688 if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1695 /*************** Type resolution of array constructors ***************/
1697 /* Recursive array list resolution function. All of the elements must
1698 be of the same type. */
1701 resolve_array_list (gfc_constructor_base base)
1708 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1710 if (c->iterator != NULL
1711 && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1714 if (gfc_resolve_expr (c->expr) == FAILURE)
1721 /* Resolve character array constructor. If it has a specified constant character
1722 length, pad/truncate the elements here; if the length is not specified and
1723 all elements are of compile-time known length, emit an error as this is
1727 gfc_resolve_character_array_constructor (gfc_expr *expr)
1732 gcc_assert (expr->expr_type == EXPR_ARRAY);
1733 gcc_assert (expr->ts.type == BT_CHARACTER);
1735 if (expr->ts.u.cl == NULL)
1737 for (p = gfc_constructor_first (expr->value.constructor);
1738 p; p = gfc_constructor_next (p))
1739 if (p->expr->ts.u.cl != NULL)
1741 /* Ensure that if there is a char_len around that it is
1742 used; otherwise the middle-end confuses them! */
1743 expr->ts.u.cl = p->expr->ts.u.cl;
1747 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1754 if (expr->ts.u.cl->length == NULL)
1756 /* Check that all constant string elements have the same length until
1757 we reach the end or find a variable-length one. */
1759 for (p = gfc_constructor_first (expr->value.constructor);
1760 p; p = gfc_constructor_next (p))
1762 int current_length = -1;
1764 for (ref = p->expr->ref; ref; ref = ref->next)
1765 if (ref->type == REF_SUBSTRING
1766 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1767 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1770 if (p->expr->expr_type == EXPR_CONSTANT)
1771 current_length = p->expr->value.character.length;
1775 j = mpz_get_ui (ref->u.ss.end->value.integer)
1776 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1777 current_length = (int) j;
1779 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1780 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1783 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1784 current_length = (int) j;
1789 gcc_assert (current_length != -1);
1791 if (found_length == -1)
1792 found_length = current_length;
1793 else if (found_length != current_length)
1795 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1796 " constructor at %L", found_length, current_length,
1801 gcc_assert (found_length == current_length);
1804 gcc_assert (found_length != -1);
1806 /* Update the character length of the array constructor. */
1807 expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1808 NULL, found_length);
1812 /* We've got a character length specified. It should be an integer,
1813 otherwise an error is signalled elsewhere. */
1814 gcc_assert (expr->ts.u.cl->length);
1816 /* If we've got a constant character length, pad according to this.
1817 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1818 max_length only if they pass. */
1819 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1821 /* Now pad/truncate the elements accordingly to the specified character
1822 length. This is ok inside this conditional, as in the case above
1823 (without typespec) all elements are verified to have the same length
1825 if (found_length != -1)
1826 for (p = gfc_constructor_first (expr->value.constructor);
1827 p; p = gfc_constructor_next (p))
1828 if (p->expr->expr_type == EXPR_CONSTANT)
1830 gfc_expr *cl = NULL;
1831 int current_length = -1;
1834 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1836 cl = p->expr->ts.u.cl->length;
1837 gfc_extract_int (cl, ¤t_length);
1840 /* If gfc_extract_int above set current_length, we implicitly
1841 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1843 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1846 || (current_length != -1 && current_length != found_length))
1847 gfc_set_constant_character_len (found_length, p->expr,
1848 has_ts ? -1 : found_length);
1856 /* Resolve all of the expressions in an array list. */
1859 gfc_resolve_array_constructor (gfc_expr *expr)
1863 t = resolve_array_list (expr->value.constructor);
1865 t = gfc_check_constructor_type (expr);
1867 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1868 the call to this function, so we don't need to call it here; if it was
1869 called twice, an error message there would be duplicated. */
1875 /* Copy an iterator structure. */
1878 gfc_copy_iterator (gfc_iterator *src)
1885 dest = gfc_get_iterator ();
1887 dest->var = gfc_copy_expr (src->var);
1888 dest->start = gfc_copy_expr (src->start);
1889 dest->end = gfc_copy_expr (src->end);
1890 dest->step = gfc_copy_expr (src->step);
1896 /********* Subroutines for determining the size of an array *********/
1898 /* These are needed just to accommodate RESHAPE(). There are no
1899 diagnostics here, we just return a negative number if something
1903 /* Get the size of single dimension of an array specification. The
1904 array is guaranteed to be one dimensional. */
1907 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1912 if (dimen < 0 || dimen > as->rank - 1)
1913 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1915 if (as->type != AS_EXPLICIT
1916 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1917 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1918 || as->lower[dimen]->ts.type != BT_INTEGER
1919 || as->upper[dimen]->ts.type != BT_INTEGER)
1924 mpz_sub (*result, as->upper[dimen]->value.integer,
1925 as->lower[dimen]->value.integer);
1927 mpz_add_ui (*result, *result, 1);
1934 spec_size (gfc_array_spec *as, mpz_t *result)
1939 mpz_init_set_ui (*result, 1);
1941 for (d = 0; d < as->rank; d++)
1943 if (spec_dimen_size (as, d, &size) == FAILURE)
1945 mpz_clear (*result);
1949 mpz_mul (*result, *result, size);
1957 /* Get the number of elements in an array section. Optionally, also supply
1961 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
1963 mpz_t upper, lower, stride;
1966 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1967 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1969 switch (ar->dimen_type[dimen])
1973 mpz_set_ui (*result, 1);
1978 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1987 if (ar->start[dimen] == NULL)
1989 if (ar->as->lower[dimen] == NULL
1990 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1992 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1996 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1998 mpz_set (lower, ar->start[dimen]->value.integer);
2001 if (ar->end[dimen] == NULL)
2003 if (ar->as->upper[dimen] == NULL
2004 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2006 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2010 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2012 mpz_set (upper, ar->end[dimen]->value.integer);
2015 if (ar->stride[dimen] == NULL)
2016 mpz_set_ui (stride, 1);
2019 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2021 mpz_set (stride, ar->stride[dimen]->value.integer);
2025 mpz_sub (*result, upper, lower);
2026 mpz_add (*result, *result, stride);
2027 mpz_div (*result, *result, stride);
2029 /* Zero stride caught earlier. */
2030 if (mpz_cmp_ui (*result, 0) < 0)
2031 mpz_set_ui (*result, 0);
2038 mpz_sub_ui (*end, *result, 1UL);
2039 mpz_mul (*end, *end, stride);
2040 mpz_add (*end, *end, lower);
2050 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2058 ref_size (gfc_array_ref *ar, mpz_t *result)
2063 mpz_init_set_ui (*result, 1);
2065 for (d = 0; d < ar->dimen; d++)
2067 if (gfc_ref_dimen_size (ar, d, &size, NULL) == FAILURE)
2069 mpz_clear (*result);
2073 mpz_mul (*result, *result, size);
2081 /* Given an array expression and a dimension, figure out how many
2082 elements it has along that dimension. Returns SUCCESS if we were
2083 able to return a result in the 'result' variable, FAILURE
2087 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2092 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2093 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2095 switch (array->expr_type)
2099 for (ref = array->ref; ref; ref = ref->next)
2101 if (ref->type != REF_ARRAY)
2104 if (ref->u.ar.type == AR_FULL)
2105 return spec_dimen_size (ref->u.ar.as, dimen, result);
2107 if (ref->u.ar.type == AR_SECTION)
2109 for (i = 0; dimen >= 0; i++)
2110 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2113 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2117 if (array->shape && array->shape[dimen])
2119 mpz_init_set (*result, array->shape[dimen]);
2123 if (array->symtree->n.sym->attr.generic
2124 && array->value.function.esym != NULL)
2126 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2130 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2137 if (array->shape == NULL) {
2138 /* Expressions with rank > 1 should have "shape" properly set */
2139 if ( array->rank != 1 )
2140 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2141 return gfc_array_size(array, result);
2146 if (array->shape == NULL)
2149 mpz_init_set (*result, array->shape[dimen]);
2158 /* Given an array expression, figure out how many elements are in the
2159 array. Returns SUCCESS if this is possible, and sets the 'result'
2160 variable. Otherwise returns FAILURE. */
2163 gfc_array_size (gfc_expr *array, mpz_t *result)
2165 expand_info expand_save;
2170 switch (array->expr_type)
2173 gfc_push_suppress_errors ();
2175 expand_save = current_expand;
2177 current_expand.count = result;
2178 mpz_init_set_ui (*result, 0);
2180 current_expand.expand_work_function = count_elements;
2183 t = expand_constructor (array->value.constructor);
2185 gfc_pop_suppress_errors ();
2188 mpz_clear (*result);
2189 current_expand = expand_save;
2193 for (ref = array->ref; ref; ref = ref->next)
2195 if (ref->type != REF_ARRAY)
2198 if (ref->u.ar.type == AR_FULL)
2199 return spec_size (ref->u.ar.as, result);
2201 if (ref->u.ar.type == AR_SECTION)
2202 return ref_size (&ref->u.ar, result);
2205 return spec_size (array->symtree->n.sym->as, result);
2209 if (array->rank == 0 || array->shape == NULL)
2212 mpz_init_set_ui (*result, 1);
2214 for (i = 0; i < array->rank; i++)
2215 mpz_mul (*result, *result, array->shape[i]);
2224 /* Given an array reference, return the shape of the reference in an
2225 array of mpz_t integers. */
2228 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2238 for (; d < ar->as->rank; d++)
2239 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2245 for (i = 0; i < ar->dimen; i++)
2247 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2249 if (gfc_ref_dimen_size (ar, i, &shape[d], NULL) == FAILURE)
2262 for (d--; d >= 0; d--)
2263 mpz_clear (shape[d]);
2269 /* Given an array expression, find the array reference structure that
2270 characterizes the reference. */
2273 gfc_find_array_ref (gfc_expr *e)
2277 for (ref = e->ref; ref; ref = ref->next)
2278 if (ref->type == REF_ARRAY
2279 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
2280 || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
2284 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2290 /* Find out if an array shape is known at compile time. */
2293 gfc_is_compile_time_shape (gfc_array_spec *as)
2297 if (as->type != AS_EXPLICIT)
2300 for (i = 0; i < as->rank; i++)
2301 if (!gfc_is_constant_expr (as->lower[i])
2302 || !gfc_is_constant_expr (as->upper[i]))