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/>. */
27 /**************** Array reference matching subroutines *****************/
29 /* Copy an array reference structure. */
32 gfc_copy_array_ref (gfc_array_ref *src)
40 dest = gfc_get_array_ref ();
44 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
46 dest->start[i] = gfc_copy_expr (src->start[i]);
47 dest->end[i] = gfc_copy_expr (src->end[i]);
48 dest->stride[i] = gfc_copy_expr (src->stride[i]);
51 dest->offset = gfc_copy_expr (src->offset);
57 /* Match a single dimension of an array reference. This can be a
58 single element or an array section. Any modifications we've made
59 to the ar structure are cleaned up by the caller. If the init
60 is set, we require the subscript to be a valid initialization
64 match_subscript (gfc_array_ref *ar, int init)
71 ar->c_where[i] = gfc_current_locus;
72 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
74 /* We can't be sure of the difference between DIMEN_ELEMENT and
75 DIMEN_VECTOR until we know the type of the element itself at
78 ar->dimen_type[i] = DIMEN_UNKNOWN;
80 if (gfc_match_char (':') == MATCH_YES)
83 /* Get start element. */
85 m = gfc_match_init_expr (&ar->start[i]);
87 m = gfc_match_expr (&ar->start[i]);
90 gfc_error ("Expected array subscript at %C");
94 if (gfc_match_char (':') == MATCH_NO)
97 /* Get an optional end element. Because we've seen the colon, we
98 definitely have a range along this dimension. */
100 ar->dimen_type[i] = DIMEN_RANGE;
103 m = gfc_match_init_expr (&ar->end[i]);
105 m = gfc_match_expr (&ar->end[i]);
107 if (m == MATCH_ERROR)
110 /* See if we have an optional stride. */
111 if (gfc_match_char (':') == MATCH_YES)
113 m = init ? gfc_match_init_expr (&ar->stride[i])
114 : gfc_match_expr (&ar->stride[i]);
117 gfc_error ("Expected array subscript stride at %C");
126 /* Match an array reference, whether it is the whole array or a
127 particular elements or a section. If init is set, the reference has
128 to consist of init expressions. */
131 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
135 memset (ar, '\0', sizeof (ar));
137 ar->where = gfc_current_locus;
140 if (gfc_match_char ('(') != MATCH_YES)
147 ar->type = AR_UNKNOWN;
149 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
151 m = match_subscript (ar, init);
152 if (m == MATCH_ERROR)
155 if (gfc_match_char (')') == MATCH_YES)
158 if (gfc_match_char (',') != MATCH_YES)
160 gfc_error ("Invalid form of array reference at %C");
165 gfc_error ("Array reference at %C cannot have more than %d dimensions",
178 /************** Array specification matching subroutines ***************/
180 /* Free all of the expressions associated with array bounds
184 gfc_free_array_spec (gfc_array_spec *as)
191 for (i = 0; i < as->rank + as->corank; i++)
193 gfc_free_expr (as->lower[i]);
194 gfc_free_expr (as->upper[i]);
201 /* Take an array bound, resolves the expression, that make up the
202 shape and check associated constraints. */
205 resolve_array_bound (gfc_expr *e, int check_constant)
210 if (gfc_resolve_expr (e) == FAILURE
211 || gfc_specification_expr (e) == FAILURE)
214 if (check_constant && gfc_is_constant_expr (e) == 0)
216 gfc_error ("Variable '%s' at %L in this context must be constant",
217 e->symtree->n.sym->name, &e->where);
225 /* Takes an array specification, resolves the expressions that make up
226 the shape and make sure everything is integral. */
229 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
237 for (i = 0; i < as->rank + as->corank; i++)
240 if (resolve_array_bound (e, check_constant) == FAILURE)
244 if (resolve_array_bound (e, check_constant) == FAILURE)
247 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
250 /* If the size is negative in this dimension, set it to zero. */
251 if (as->lower[i]->expr_type == EXPR_CONSTANT
252 && as->upper[i]->expr_type == EXPR_CONSTANT
253 && mpz_cmp (as->upper[i]->value.integer,
254 as->lower[i]->value.integer) < 0)
256 gfc_free_expr (as->upper[i]);
257 as->upper[i] = gfc_copy_expr (as->lower[i]);
258 mpz_sub_ui (as->upper[i]->value.integer,
259 as->upper[i]->value.integer, 1);
267 /* Match a single array element specification. The return values as
268 well as the upper and lower bounds of the array spec are filled
269 in according to what we see on the input. The caller makes sure
270 individual specifications make sense as a whole.
273 Parsed Lower Upper Returned
274 ------------------------------------
275 : NULL NULL AS_DEFERRED (*)
277 x: x NULL AS_ASSUMED_SHAPE
279 x:* x NULL AS_ASSUMED_SIZE
280 * 1 NULL AS_ASSUMED_SIZE
282 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
283 is fixed during the resolution of formal interfaces.
285 Anything else AS_UNKNOWN. */
288 match_array_element_spec (gfc_array_spec *as)
290 gfc_expr **upper, **lower;
293 lower = &as->lower[as->rank + as->corank - 1];
294 upper = &as->upper[as->rank + as->corank - 1];
296 if (gfc_match_char ('*') == MATCH_YES)
298 *lower = gfc_int_expr (1);
299 return AS_ASSUMED_SIZE;
302 if (gfc_match_char (':') == MATCH_YES)
305 m = gfc_match_expr (upper);
307 gfc_error ("Expected expression in array specification at %C");
310 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
313 if (gfc_match_char (':') == MATCH_NO)
315 *lower = gfc_int_expr (1);
322 if (gfc_match_char ('*') == MATCH_YES)
323 return AS_ASSUMED_SIZE;
325 m = gfc_match_expr (upper);
326 if (m == MATCH_ERROR)
329 return AS_ASSUMED_SHAPE;
330 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
337 /* Matches an array specification, incidentally figuring out what sort
338 it is. Match either a normal array specification, or a coarray spec
339 or both. Optionally allow [:] for coarrays. */
342 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
344 array_type current_type;
345 array_type coarray_type = AS_UNKNOWN;
349 as = gfc_get_array_spec ();
353 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
362 if (gfc_match_char ('(') != MATCH_YES)
372 current_type = match_array_element_spec (as);
376 if (current_type == AS_UNKNOWN)
378 as->type = current_type;
382 { /* See how current spec meshes with the existing. */
387 if (current_type == AS_ASSUMED_SIZE)
389 as->type = AS_ASSUMED_SIZE;
393 if (current_type == AS_EXPLICIT)
396 gfc_error ("Bad array specification for an explicitly shaped "
401 case AS_ASSUMED_SHAPE:
402 if ((current_type == AS_ASSUMED_SHAPE)
403 || (current_type == AS_DEFERRED))
406 gfc_error ("Bad array specification for assumed shape "
411 if (current_type == AS_DEFERRED)
414 if (current_type == AS_ASSUMED_SHAPE)
416 as->type = AS_ASSUMED_SHAPE;
420 gfc_error ("Bad specification for deferred shape array at %C");
423 case AS_ASSUMED_SIZE:
424 gfc_error ("Bad specification for assumed size array at %C");
428 if (gfc_match_char (')') == MATCH_YES)
431 if (gfc_match_char (',') != MATCH_YES)
433 gfc_error ("Expected another dimension in array declaration at %C");
437 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
439 gfc_error ("Array specification at %C has more than %d dimensions",
444 if (as->corank + as->rank >= 7
445 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
446 "specification at %C with more than 7 dimensions")
455 if (gfc_match_char ('[') != MATCH_YES)
458 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
465 current_type = match_array_element_spec (as);
467 if (current_type == AS_UNKNOWN)
470 if (as->rank && as->type != AS_DEFERRED && current_type == AS_DEFERRED)
472 gfc_error ("Array at %C has non-deferred shape and deferred "
476 if (as->rank && as->type == AS_DEFERRED && current_type != AS_DEFERRED)
478 gfc_error ("Array at %C has deferred shape and non-deferred "
484 coarray_type = current_type;
486 switch (coarray_type)
487 { /* See how current spec meshes with the existing. */
492 if (current_type == AS_ASSUMED_SIZE)
494 coarray_type = AS_ASSUMED_SIZE;
498 if (current_type == AS_EXPLICIT)
501 gfc_error ("Bad array specification for an explicitly "
502 "shaped array at %C");
506 case AS_ASSUMED_SHAPE:
507 if ((current_type == AS_ASSUMED_SHAPE)
508 || (current_type == AS_DEFERRED))
511 gfc_error ("Bad array specification for assumed shape "
516 if (current_type == AS_DEFERRED)
519 if (current_type == AS_ASSUMED_SHAPE)
521 as->type = AS_ASSUMED_SHAPE;
525 gfc_error ("Bad specification for deferred shape array at %C");
528 case AS_ASSUMED_SIZE:
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->corank >= GFC_MAX_DIMENSIONS)
544 gfc_error ("Array specification at %C has more than %d "
545 "dimensions", GFC_MAX_DIMENSIONS);
550 if (current_type == AS_EXPLICIT)
552 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
556 if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE)
557 as->type = AS_EXPLICIT;
558 else if (as->rank == 0)
559 as->type = coarray_type;
562 if (as->rank == 0 && as->corank == 0)
565 gfc_free_array_spec (as);
569 /* If a lower bounds of an assumed shape array is blank, put in one. */
570 if (as->type == AS_ASSUMED_SHAPE)
572 for (i = 0; i < as->rank + as->corank; i++)
574 if (as->lower[i] == NULL)
575 as->lower[i] = gfc_int_expr (1);
584 /* Something went wrong. */
585 gfc_free_array_spec (as);
590 /* Given a symbol and an array specification, modify the symbol to
591 have that array specification. The error locus is needed in case
592 something goes wrong. On failure, the caller must free the spec. */
595 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
603 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
607 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
616 if (sym->as->type == AS_DEFERRED && as->type != AS_DEFERRED)
618 gfc_error ("'%s' at %L has deferred shape and non-deferred coshape",
619 sym->name, error_loc);
623 if (sym->as->type != AS_DEFERRED && as->type == AS_DEFERRED)
625 gfc_error ("'%s' at %L has non-deferred shape and deferred coshape",
626 sym->name, error_loc);
632 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
633 the codimension is simply added. */
634 gcc_assert (as->rank == 0 && sym->as->corank == 0);
636 sym->as->corank = as->corank;
637 for (i = 0; i < as->corank; i++)
639 sym->as->lower[sym->as->rank + i] = as->lower[i];
640 sym->as->upper[sym->as->rank + i] = as->upper[i];
645 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
646 the dimension is added - but first the codimensions (if existing
647 need to be shifted to make space for the dimension. */
648 gcc_assert (as->corank == 0 && sym->as->rank == 0);
650 sym->as->rank = as->rank;
651 sym->as->type = as->type;
652 sym->as->cray_pointee = as->cray_pointee;
653 sym->as->cp_was_assumed = as->cp_was_assumed;
655 for (i = 0; i < sym->as->corank; i++)
657 sym->as->lower[as->rank + i] = sym->as->lower[i];
658 sym->as->upper[as->rank + i] = sym->as->upper[i];
660 for (i = 0; i < as->rank; i++)
662 sym->as->lower[i] = as->lower[i];
663 sym->as->upper[i] = as->upper[i];
672 /* Copy an array specification. */
675 gfc_copy_array_spec (gfc_array_spec *src)
677 gfc_array_spec *dest;
683 dest = gfc_get_array_spec ();
687 for (i = 0; i < dest->rank + dest->corank; i++)
689 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
690 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
697 /* Returns nonzero if the two expressions are equal. Only handles integer
701 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
703 if (bound1 == NULL || bound2 == NULL
704 || bound1->expr_type != EXPR_CONSTANT
705 || bound2->expr_type != EXPR_CONSTANT
706 || bound1->ts.type != BT_INTEGER
707 || bound2->ts.type != BT_INTEGER)
708 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
710 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
717 /* Compares two array specifications. They must be constant or deferred
721 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
725 if (as1 == NULL && as2 == NULL)
728 if (as1 == NULL || as2 == NULL)
731 if (as1->rank != as2->rank)
734 if (as1->corank != as2->corank)
740 if (as1->type != as2->type)
743 if (as1->type == AS_EXPLICIT)
744 for (i = 0; i < as1->rank + as1->corank; i++)
746 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
749 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
757 /****************** Array constructor functions ******************/
759 /* Start an array constructor. The constructor starts with zero
760 elements and should be appended to by gfc_append_constructor(). */
763 gfc_start_constructor (bt type, int kind, locus *where)
767 result = gfc_get_expr ();
769 result->expr_type = EXPR_ARRAY;
772 result->ts.type = type;
773 result->ts.kind = kind;
774 result->where = *where;
779 /* Given an array constructor expression, append the new expression
780 node onto the constructor. */
783 gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
787 if (base->value.constructor == NULL)
788 base->value.constructor = c = gfc_get_constructor ();
791 c = base->value.constructor;
795 c->next = gfc_get_constructor ();
802 && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
803 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
807 /* Given an array constructor expression, insert the new expression's
808 constructor onto the base's one according to the offset. */
811 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
813 gfc_constructor *c, *pre;
817 type = base->expr_type;
819 if (base->value.constructor == NULL)
820 base->value.constructor = c1;
823 c = pre = base->value.constructor;
826 if (type == EXPR_ARRAY)
828 t = mpz_cmp (c->n.offset, c1->n.offset);
836 gfc_error ("duplicated initializer");
857 base->value.constructor = c1;
863 /* Get a new constructor. */
866 gfc_get_constructor (void)
870 c = XCNEW (gfc_constructor);
874 mpz_init_set_si (c->n.offset, 0);
875 mpz_init_set_si (c->repeat, 0);
880 /* Free chains of gfc_constructor structures. */
883 gfc_free_constructor (gfc_constructor *p)
885 gfc_constructor *next;
895 gfc_free_expr (p->expr);
896 if (p->iterator != NULL)
897 gfc_free_iterator (p->iterator, 1);
898 mpz_clear (p->n.offset);
899 mpz_clear (p->repeat);
905 /* Given an expression node that might be an array constructor and a
906 symbol, make sure that no iterators in this or child constructors
907 use the symbol as an implied-DO iterator. Returns nonzero if a
908 duplicate was found. */
911 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
915 for (; c; c = c->next)
919 if (e->expr_type == EXPR_ARRAY
920 && check_duplicate_iterator (e->value.constructor, master))
923 if (c->iterator == NULL)
926 if (c->iterator->var->symtree->n.sym == master)
928 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
929 "same name", master->name, &c->where);
939 /* Forward declaration because these functions are mutually recursive. */
940 static match match_array_cons_element (gfc_constructor **);
942 /* Match a list of array elements. */
945 match_array_list (gfc_constructor **result)
947 gfc_constructor *p, *head, *tail, *new_cons;
954 old_loc = gfc_current_locus;
956 if (gfc_match_char ('(') == MATCH_NO)
959 memset (&iter, '\0', sizeof (gfc_iterator));
962 m = match_array_cons_element (&head);
968 if (gfc_match_char (',') != MATCH_YES)
976 m = gfc_match_iterator (&iter, 0);
979 if (m == MATCH_ERROR)
982 m = match_array_cons_element (&new_cons);
983 if (m == MATCH_ERROR)
990 goto cleanup; /* Could be a complex constant */
993 tail->next = new_cons;
996 if (gfc_match_char (',') != MATCH_YES)
1005 if (gfc_match_char (')') != MATCH_YES)
1008 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
1014 e = gfc_get_expr ();
1015 e->expr_type = EXPR_ARRAY;
1017 e->value.constructor = head;
1019 p = gfc_get_constructor ();
1020 p->where = gfc_current_locus;
1021 p->iterator = gfc_get_iterator ();
1022 *p->iterator = iter;
1030 gfc_error ("Syntax error in array constructor at %C");
1034 gfc_free_constructor (head);
1035 gfc_free_iterator (&iter, 0);
1036 gfc_current_locus = old_loc;
1041 /* Match a single element of an array constructor, which can be a
1042 single expression or a list of elements. */
1045 match_array_cons_element (gfc_constructor **result)
1051 m = match_array_list (result);
1055 m = gfc_match_expr (&expr);
1059 p = gfc_get_constructor ();
1060 p->where = gfc_current_locus;
1068 /* Match an array constructor. */
1071 gfc_match_array_constructor (gfc_expr **result)
1073 gfc_constructor *head, *tail, *new_cons;
1078 const char *end_delim;
1081 if (gfc_match (" (/") == MATCH_NO)
1083 if (gfc_match (" [") == MATCH_NO)
1087 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1088 "style array constructors at %C") == FAILURE)
1096 where = gfc_current_locus;
1100 /* Try to match an optional "type-spec ::" */
1101 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1103 seen_ts = (gfc_match (" ::") == MATCH_YES);
1107 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1108 "including type specification at %C") == FAILURE)
1114 gfc_current_locus = where;
1116 if (gfc_match (end_delim) == MATCH_YES)
1122 gfc_error ("Empty array constructor at %C is not allowed");
1129 m = match_array_cons_element (&new_cons);
1130 if (m == MATCH_ERROR)
1138 tail->next = new_cons;
1142 if (gfc_match_char (',') == MATCH_NO)
1146 if (gfc_match (end_delim) == MATCH_NO)
1150 expr = gfc_get_expr ();
1152 expr->expr_type = EXPR_ARRAY;
1154 expr->value.constructor = head;
1155 /* Size must be calculated at resolution time. */
1160 expr->ts.type = BT_UNKNOWN;
1163 expr->ts.u.cl->length_from_typespec = seen_ts;
1165 expr->where = where;
1172 gfc_error ("Syntax error in array constructor at %C");
1175 gfc_free_constructor (head);
1181 /************** Check array constructors for correctness **************/
1183 /* Given an expression, compare it's type with the type of the current
1184 constructor. Returns nonzero if an error was issued. The
1185 cons_state variable keeps track of whether the type of the
1186 constructor being read or resolved is known to be good, bad or just
1189 static gfc_typespec constructor_ts;
1191 { CONS_START, CONS_GOOD, CONS_BAD }
1195 check_element_type (gfc_expr *expr, bool convert)
1197 if (cons_state == CONS_BAD)
1198 return 0; /* Suppress further errors */
1200 if (cons_state == CONS_START)
1202 if (expr->ts.type == BT_UNKNOWN)
1203 cons_state = CONS_BAD;
1206 cons_state = CONS_GOOD;
1207 constructor_ts = expr->ts;
1213 if (gfc_compare_types (&constructor_ts, &expr->ts))
1217 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1219 gfc_error ("Element in %s array constructor at %L is %s",
1220 gfc_typename (&constructor_ts), &expr->where,
1221 gfc_typename (&expr->ts));
1223 cons_state = CONS_BAD;
1228 /* Recursive work function for gfc_check_constructor_type(). */
1231 check_constructor_type (gfc_constructor *c, bool convert)
1235 for (; c; c = c->next)
1239 if (e->expr_type == EXPR_ARRAY)
1241 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1247 if (check_element_type (e, convert))
1255 /* Check that all elements of an array constructor are the same type.
1256 On FAILURE, an error has been generated. */
1259 gfc_check_constructor_type (gfc_expr *e)
1263 if (e->ts.type != BT_UNKNOWN)
1265 cons_state = CONS_GOOD;
1266 constructor_ts = e->ts;
1270 cons_state = CONS_START;
1271 gfc_clear_ts (&constructor_ts);
1274 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1275 typespec, and we will now convert the values on the fly. */
1276 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1277 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1278 e->ts = constructor_ts;
1285 typedef struct cons_stack
1287 gfc_iterator *iterator;
1288 struct cons_stack *previous;
1292 static cons_stack *base;
1294 static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
1296 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1297 that that variable is an iteration variables. */
1300 gfc_check_iter_variable (gfc_expr *expr)
1305 sym = expr->symtree->n.sym;
1307 for (c = base; c; c = c->previous)
1308 if (sym == c->iterator->var->symtree->n.sym)
1315 /* Recursive work function for gfc_check_constructor(). This amounts
1316 to calling the check function for each expression in the
1317 constructor, giving variables with the names of iterators a pass. */
1320 check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
1326 for (; c; c = c->next)
1330 if (e->expr_type != EXPR_ARRAY)
1332 if ((*check_function) (e) == FAILURE)
1337 element.previous = base;
1338 element.iterator = c->iterator;
1341 t = check_constructor (e->value.constructor, check_function);
1342 base = element.previous;
1348 /* Nothing went wrong, so all OK. */
1353 /* Checks a constructor to see if it is a particular kind of
1354 expression -- specification, restricted, or initialization as
1355 determined by the check_function. */
1358 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1360 cons_stack *base_save;
1366 t = check_constructor (expr->value.constructor, check_function);
1374 /**************** Simplification of array constructors ****************/
1376 iterator_stack *iter_stack;
1380 gfc_constructor *new_head, *new_tail;
1381 int extract_count, extract_n;
1382 gfc_expr *extracted;
1386 gfc_component *component;
1389 gfc_try (*expand_work_function) (gfc_expr *);
1393 static expand_info current_expand;
1395 static gfc_try expand_constructor (gfc_constructor *);
1398 /* Work function that counts the number of elements present in a
1402 count_elements (gfc_expr *e)
1407 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1410 if (gfc_array_size (e, &result) == FAILURE)
1416 mpz_add (*current_expand.count, *current_expand.count, result);
1425 /* Work function that extracts a particular element from an array
1426 constructor, freeing the rest. */
1429 extract_element (gfc_expr *e)
1432 { /* Something unextractable */
1437 if (current_expand.extract_count == current_expand.extract_n)
1438 current_expand.extracted = e;
1442 current_expand.extract_count++;
1448 /* Work function that constructs a new constructor out of the old one,
1449 stringing new elements together. */
1452 expand (gfc_expr *e)
1454 if (current_expand.new_head == NULL)
1455 current_expand.new_head = current_expand.new_tail =
1456 gfc_get_constructor ();
1459 current_expand.new_tail->next = gfc_get_constructor ();
1460 current_expand.new_tail = current_expand.new_tail->next;
1463 current_expand.new_tail->where = e->where;
1464 current_expand.new_tail->expr = e;
1466 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1467 current_expand.new_tail->n.component = current_expand.component;
1468 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1473 /* Given an initialization expression that is a variable reference,
1474 substitute the current value of the iteration variable. */
1477 gfc_simplify_iterator_var (gfc_expr *e)
1481 for (p = iter_stack; p; p = p->prev)
1482 if (e->symtree == p->variable)
1486 return; /* Variable not found */
1488 gfc_replace_expr (e, gfc_int_expr (0));
1490 mpz_set (e->value.integer, p->value);
1496 /* Expand an expression with that is inside of a constructor,
1497 recursing into other constructors if present. */
1500 expand_expr (gfc_expr *e)
1502 if (e->expr_type == EXPR_ARRAY)
1503 return expand_constructor (e->value.constructor);
1505 e = gfc_copy_expr (e);
1507 if (gfc_simplify_expr (e, 1) == FAILURE)
1513 return current_expand.expand_work_function (e);
1518 expand_iterator (gfc_constructor *c)
1520 gfc_expr *start, *end, *step;
1521 iterator_stack frame;
1530 mpz_init (frame.value);
1533 start = gfc_copy_expr (c->iterator->start);
1534 if (gfc_simplify_expr (start, 1) == FAILURE)
1537 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1540 end = gfc_copy_expr (c->iterator->end);
1541 if (gfc_simplify_expr (end, 1) == FAILURE)
1544 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1547 step = gfc_copy_expr (c->iterator->step);
1548 if (gfc_simplify_expr (step, 1) == FAILURE)
1551 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1554 if (mpz_sgn (step->value.integer) == 0)
1556 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1560 /* Calculate the trip count of the loop. */
1561 mpz_sub (trip, end->value.integer, start->value.integer);
1562 mpz_add (trip, trip, step->value.integer);
1563 mpz_tdiv_q (trip, trip, step->value.integer);
1565 mpz_set (frame.value, start->value.integer);
1567 frame.prev = iter_stack;
1568 frame.variable = c->iterator->var->symtree;
1569 iter_stack = &frame;
1571 while (mpz_sgn (trip) > 0)
1573 if (expand_expr (c->expr) == FAILURE)
1576 mpz_add (frame.value, frame.value, step->value.integer);
1577 mpz_sub_ui (trip, trip, 1);
1583 gfc_free_expr (start);
1584 gfc_free_expr (end);
1585 gfc_free_expr (step);
1588 mpz_clear (frame.value);
1590 iter_stack = frame.prev;
1596 /* Expand a constructor into constant constructors without any
1597 iterators, calling the work function for each of the expanded
1598 expressions. The work function needs to either save or free the
1599 passed expression. */
1602 expand_constructor (gfc_constructor *c)
1606 for (; c; c = c->next)
1608 if (c->iterator != NULL)
1610 if (expand_iterator (c) == FAILURE)
1617 if (e->expr_type == EXPR_ARRAY)
1619 if (expand_constructor (e->value.constructor) == FAILURE)
1625 e = gfc_copy_expr (e);
1626 if (gfc_simplify_expr (e, 1) == FAILURE)
1631 current_expand.offset = &c->n.offset;
1632 current_expand.component = c->n.component;
1633 current_expand.repeat = &c->repeat;
1634 if (current_expand.expand_work_function (e) == FAILURE)
1641 /* Top level subroutine for expanding constructors. We only expand
1642 constructor if they are small enough. */
1645 gfc_expand_constructor (gfc_expr *e)
1647 expand_info expand_save;
1651 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1658 expand_save = current_expand;
1659 current_expand.new_head = current_expand.new_tail = NULL;
1663 current_expand.expand_work_function = expand;
1665 if (expand_constructor (e->value.constructor) == FAILURE)
1667 gfc_free_constructor (current_expand.new_head);
1672 gfc_free_constructor (e->value.constructor);
1673 e->value.constructor = current_expand.new_head;
1678 current_expand = expand_save;
1684 /* Work function for checking that an element of a constructor is a
1685 constant, after removal of any iteration variables. We return
1686 FAILURE if not so. */
1689 is_constant_element (gfc_expr *e)
1693 rv = gfc_is_constant_expr (e);
1696 return rv ? SUCCESS : FAILURE;
1700 /* Given an array constructor, determine if the constructor is
1701 constant or not by expanding it and making sure that all elements
1702 are constants. This is a bit of a hack since something like (/ (i,
1703 i=1,100000000) /) will take a while as* opposed to a more clever
1704 function that traverses the expression tree. FIXME. */
1707 gfc_constant_ac (gfc_expr *e)
1709 expand_info expand_save;
1711 gfc_constructor * con;
1715 if (e->value.constructor
1716 && e->value.constructor->expr->expr_type == EXPR_ARRAY)
1718 /* Expand the constructor. */
1720 expand_save = current_expand;
1721 current_expand.expand_work_function = is_constant_element;
1723 rc = expand_constructor (e->value.constructor);
1725 current_expand = expand_save;
1729 /* No need to expand this further. */
1730 for (con = e->value.constructor; con; con = con->next)
1732 if (con->expr->expr_type == EXPR_CONSTANT)
1736 if (!gfc_is_constant_expr (con->expr))
1749 /* Returns nonzero if an array constructor has been completely
1750 expanded (no iterators) and zero if iterators are present. */
1753 gfc_expanded_ac (gfc_expr *e)
1757 if (e->expr_type == EXPR_ARRAY)
1758 for (p = e->value.constructor; p; p = p->next)
1759 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1766 /*************** Type resolution of array constructors ***************/
1768 /* Recursive array list resolution function. All of the elements must
1769 be of the same type. */
1772 resolve_array_list (gfc_constructor *p)
1778 for (; p; p = p->next)
1780 if (p->iterator != NULL
1781 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1784 if (gfc_resolve_expr (p->expr) == FAILURE)
1791 /* Resolve character array constructor. If it has a specified constant character
1792 length, pad/truncate the elements here; if the length is not specified and
1793 all elements are of compile-time known length, emit an error as this is
1797 gfc_resolve_character_array_constructor (gfc_expr *expr)
1802 gcc_assert (expr->expr_type == EXPR_ARRAY);
1803 gcc_assert (expr->ts.type == BT_CHARACTER);
1805 if (expr->ts.u.cl == NULL)
1807 for (p = expr->value.constructor; p; p = p->next)
1808 if (p->expr->ts.u.cl != NULL)
1810 /* Ensure that if there is a char_len around that it is
1811 used; otherwise the middle-end confuses them! */
1812 expr->ts.u.cl = p->expr->ts.u.cl;
1816 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1823 if (expr->ts.u.cl->length == NULL)
1825 /* Check that all constant string elements have the same length until
1826 we reach the end or find a variable-length one. */
1828 for (p = expr->value.constructor; p; p = p->next)
1830 int current_length = -1;
1832 for (ref = p->expr->ref; ref; ref = ref->next)
1833 if (ref->type == REF_SUBSTRING
1834 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1835 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1838 if (p->expr->expr_type == EXPR_CONSTANT)
1839 current_length = p->expr->value.character.length;
1843 j = mpz_get_ui (ref->u.ss.end->value.integer)
1844 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1845 current_length = (int) j;
1847 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1848 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1851 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1852 current_length = (int) j;
1857 gcc_assert (current_length != -1);
1859 if (found_length == -1)
1860 found_length = current_length;
1861 else if (found_length != current_length)
1863 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1864 " constructor at %L", found_length, current_length,
1869 gcc_assert (found_length == current_length);
1872 gcc_assert (found_length != -1);
1874 /* Update the character length of the array constructor. */
1875 expr->ts.u.cl->length = gfc_int_expr (found_length);
1879 /* We've got a character length specified. It should be an integer,
1880 otherwise an error is signalled elsewhere. */
1881 gcc_assert (expr->ts.u.cl->length);
1883 /* If we've got a constant character length, pad according to this.
1884 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1885 max_length only if they pass. */
1886 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1888 /* Now pad/truncate the elements accordingly to the specified character
1889 length. This is ok inside this conditional, as in the case above
1890 (without typespec) all elements are verified to have the same length
1892 if (found_length != -1)
1893 for (p = expr->value.constructor; p; p = p->next)
1894 if (p->expr->expr_type == EXPR_CONSTANT)
1896 gfc_expr *cl = NULL;
1897 int current_length = -1;
1900 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1902 cl = p->expr->ts.u.cl->length;
1903 gfc_extract_int (cl, ¤t_length);
1906 /* If gfc_extract_int above set current_length, we implicitly
1907 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1909 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1912 || (current_length != -1 && current_length < found_length))
1913 gfc_set_constant_character_len (found_length, p->expr,
1914 has_ts ? -1 : found_length);
1922 /* Resolve all of the expressions in an array list. */
1925 gfc_resolve_array_constructor (gfc_expr *expr)
1929 t = resolve_array_list (expr->value.constructor);
1931 t = gfc_check_constructor_type (expr);
1933 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1934 the call to this function, so we don't need to call it here; if it was
1935 called twice, an error message there would be duplicated. */
1941 /* Copy an iterator structure. */
1943 static gfc_iterator *
1944 copy_iterator (gfc_iterator *src)
1951 dest = gfc_get_iterator ();
1953 dest->var = gfc_copy_expr (src->var);
1954 dest->start = gfc_copy_expr (src->start);
1955 dest->end = gfc_copy_expr (src->end);
1956 dest->step = gfc_copy_expr (src->step);
1962 /* Copy a constructor structure. */
1965 gfc_copy_constructor (gfc_constructor *src)
1967 gfc_constructor *dest;
1968 gfc_constructor *tail;
1977 dest = tail = gfc_get_constructor ();
1980 tail->next = gfc_get_constructor ();
1983 tail->where = src->where;
1984 tail->expr = gfc_copy_expr (src->expr);
1985 tail->iterator = copy_iterator (src->iterator);
1986 mpz_set (tail->n.offset, src->n.offset);
1987 tail->n.component = src->n.component;
1988 mpz_set (tail->repeat, src->repeat);
1996 /* Given an array expression and an element number (starting at zero),
1997 return a pointer to the array element. NULL is returned if the
1998 size of the array has been exceeded. The expression node returned
1999 remains a part of the array and should not be freed. Access is not
2000 efficient at all, but this is another place where things do not
2001 have to be particularly fast. */
2004 gfc_get_array_element (gfc_expr *array, int element)
2006 expand_info expand_save;
2010 expand_save = current_expand;
2011 current_expand.extract_n = element;
2012 current_expand.expand_work_function = extract_element;
2013 current_expand.extracted = NULL;
2014 current_expand.extract_count = 0;
2018 rc = expand_constructor (array->value.constructor);
2019 e = current_expand.extracted;
2020 current_expand = expand_save;
2029 /********* Subroutines for determining the size of an array *********/
2031 /* These are needed just to accommodate RESHAPE(). There are no
2032 diagnostics here, we just return a negative number if something
2036 /* Get the size of single dimension of an array specification. The
2037 array is guaranteed to be one dimensional. */
2040 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2045 if (dimen < 0 || dimen > as->rank - 1)
2046 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2048 if (as->type != AS_EXPLICIT
2049 || as->lower[dimen]->expr_type != EXPR_CONSTANT
2050 || as->upper[dimen]->expr_type != EXPR_CONSTANT
2051 || as->lower[dimen]->ts.type != BT_INTEGER
2052 || as->upper[dimen]->ts.type != BT_INTEGER)
2057 mpz_sub (*result, as->upper[dimen]->value.integer,
2058 as->lower[dimen]->value.integer);
2060 mpz_add_ui (*result, *result, 1);
2067 spec_size (gfc_array_spec *as, mpz_t *result)
2072 mpz_init_set_ui (*result, 1);
2074 for (d = 0; d < as->rank; d++)
2076 if (spec_dimen_size (as, d, &size) == FAILURE)
2078 mpz_clear (*result);
2082 mpz_mul (*result, *result, size);
2090 /* Get the number of elements in an array section. */
2093 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
2095 mpz_t upper, lower, stride;
2098 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
2099 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2101 switch (ar->dimen_type[dimen])
2105 mpz_set_ui (*result, 1);
2110 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2119 if (ar->start[dimen] == NULL)
2121 if (ar->as->lower[dimen] == NULL
2122 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
2124 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2128 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2130 mpz_set (lower, ar->start[dimen]->value.integer);
2133 if (ar->end[dimen] == NULL)
2135 if (ar->as->upper[dimen] == NULL
2136 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2138 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2142 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2144 mpz_set (upper, ar->end[dimen]->value.integer);
2147 if (ar->stride[dimen] == NULL)
2148 mpz_set_ui (stride, 1);
2151 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2153 mpz_set (stride, ar->stride[dimen]->value.integer);
2157 mpz_sub (*result, upper, lower);
2158 mpz_add (*result, *result, stride);
2159 mpz_div (*result, *result, stride);
2161 /* Zero stride caught earlier. */
2162 if (mpz_cmp_ui (*result, 0) < 0)
2163 mpz_set_ui (*result, 0);
2173 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2181 ref_size (gfc_array_ref *ar, mpz_t *result)
2186 mpz_init_set_ui (*result, 1);
2188 for (d = 0; d < ar->dimen; d++)
2190 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2192 mpz_clear (*result);
2196 mpz_mul (*result, *result, size);
2204 /* Given an array expression and a dimension, figure out how many
2205 elements it has along that dimension. Returns SUCCESS if we were
2206 able to return a result in the 'result' variable, FAILURE
2210 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2215 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2216 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2218 switch (array->expr_type)
2222 for (ref = array->ref; ref; ref = ref->next)
2224 if (ref->type != REF_ARRAY)
2227 if (ref->u.ar.type == AR_FULL)
2228 return spec_dimen_size (ref->u.ar.as, dimen, result);
2230 if (ref->u.ar.type == AR_SECTION)
2232 for (i = 0; dimen >= 0; i++)
2233 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2236 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2240 if (array->shape && array->shape[dimen])
2242 mpz_init_set (*result, array->shape[dimen]);
2246 if (array->symtree->n.sym->attr.generic
2247 && array->value.function.esym != NULL)
2249 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2253 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2260 if (array->shape == NULL) {
2261 /* Expressions with rank > 1 should have "shape" properly set */
2262 if ( array->rank != 1 )
2263 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2264 return gfc_array_size(array, result);
2269 if (array->shape == NULL)
2272 mpz_init_set (*result, array->shape[dimen]);
2281 /* Given an array expression, figure out how many elements are in the
2282 array. Returns SUCCESS if this is possible, and sets the 'result'
2283 variable. Otherwise returns FAILURE. */
2286 gfc_array_size (gfc_expr *array, mpz_t *result)
2288 expand_info expand_save;
2293 switch (array->expr_type)
2296 gfc_push_suppress_errors ();
2298 expand_save = current_expand;
2300 current_expand.count = result;
2301 mpz_init_set_ui (*result, 0);
2303 current_expand.expand_work_function = count_elements;
2306 t = expand_constructor (array->value.constructor);
2308 gfc_pop_suppress_errors ();
2311 mpz_clear (*result);
2312 current_expand = expand_save;
2316 for (ref = array->ref; ref; ref = ref->next)
2318 if (ref->type != REF_ARRAY)
2321 if (ref->u.ar.type == AR_FULL)
2322 return spec_size (ref->u.ar.as, result);
2324 if (ref->u.ar.type == AR_SECTION)
2325 return ref_size (&ref->u.ar, result);
2328 return spec_size (array->symtree->n.sym->as, result);
2332 if (array->rank == 0 || array->shape == NULL)
2335 mpz_init_set_ui (*result, 1);
2337 for (i = 0; i < array->rank; i++)
2338 mpz_mul (*result, *result, array->shape[i]);
2347 /* Given an array reference, return the shape of the reference in an
2348 array of mpz_t integers. */
2351 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2361 for (; d < ar->as->rank; d++)
2362 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2368 for (i = 0; i < ar->dimen; i++)
2370 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2372 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2385 for (d--; d >= 0; d--)
2386 mpz_clear (shape[d]);
2392 /* Given an array expression, find the array reference structure that
2393 characterizes the reference. */
2396 gfc_find_array_ref (gfc_expr *e)
2400 for (ref = e->ref; ref; ref = ref->next)
2401 if (ref->type == REF_ARRAY
2402 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2406 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2412 /* Find out if an array shape is known at compile time. */
2415 gfc_is_compile_time_shape (gfc_array_spec *as)
2419 if (as->type != AS_EXPLICIT)
2422 for (i = 0; i < as->rank; i++)
2423 if (!gfc_is_constant_expr (as->lower[i])
2424 || !gfc_is_constant_expr (as->upper[i]))