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;
348 as = gfc_get_array_spec ();
352 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
361 if (gfc_match_char ('(') != MATCH_YES)
371 current_type = match_array_element_spec (as);
375 if (current_type == AS_UNKNOWN)
377 as->type = current_type;
381 { /* See how current spec meshes with the existing. */
386 if (current_type == AS_ASSUMED_SIZE)
388 as->type = AS_ASSUMED_SIZE;
392 if (current_type == AS_EXPLICIT)
395 gfc_error ("Bad array specification for an explicitly shaped "
400 case AS_ASSUMED_SHAPE:
401 if ((current_type == AS_ASSUMED_SHAPE)
402 || (current_type == AS_DEFERRED))
405 gfc_error ("Bad array specification for assumed shape "
410 if (current_type == AS_DEFERRED)
413 if (current_type == AS_ASSUMED_SHAPE)
415 as->type = AS_ASSUMED_SHAPE;
419 gfc_error ("Bad specification for deferred shape array at %C");
422 case AS_ASSUMED_SIZE:
423 gfc_error ("Bad specification for assumed size array at %C");
427 if (gfc_match_char (')') == MATCH_YES)
430 if (gfc_match_char (',') != MATCH_YES)
432 gfc_error ("Expected another dimension in array declaration at %C");
436 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
438 gfc_error ("Array specification at %C has more than %d dimensions",
443 if (as->corank + as->rank >= 7
444 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
445 "specification at %C with more than 7 dimensions")
454 if (gfc_match_char ('[') != MATCH_YES)
457 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
464 current_type = match_array_element_spec (as);
466 if (current_type == AS_UNKNOWN)
470 as->cotype = current_type;
473 { /* See how current spec meshes with the existing. */
478 if (current_type == AS_ASSUMED_SIZE)
480 as->cotype = AS_ASSUMED_SIZE;
484 if (current_type == AS_EXPLICIT)
487 gfc_error ("Bad array specification for an explicitly "
488 "shaped array at %C");
492 case AS_ASSUMED_SHAPE:
493 if ((current_type == AS_ASSUMED_SHAPE)
494 || (current_type == AS_DEFERRED))
497 gfc_error ("Bad array specification for assumed shape "
502 if (current_type == AS_DEFERRED)
505 if (current_type == AS_ASSUMED_SHAPE)
507 as->cotype = AS_ASSUMED_SHAPE;
511 gfc_error ("Bad specification for deferred shape array at %C");
514 case AS_ASSUMED_SIZE:
515 gfc_error ("Bad specification for assumed size array at %C");
519 if (gfc_match_char (']') == MATCH_YES)
522 if (gfc_match_char (',') != MATCH_YES)
524 gfc_error ("Expected another dimension in array declaration at %C");
528 if (as->corank >= GFC_MAX_DIMENSIONS)
530 gfc_error ("Array specification at %C has more than %d "
531 "dimensions", GFC_MAX_DIMENSIONS);
536 if (current_type == AS_EXPLICIT)
538 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
542 if (as->cotype == AS_ASSUMED_SIZE)
543 as->cotype = AS_EXPLICIT;
546 as->type = as->cotype;
549 if (as->rank == 0 && as->corank == 0)
552 gfc_free_array_spec (as);
556 /* If a lower bounds of an assumed shape array is blank, put in one. */
557 if (as->type == AS_ASSUMED_SHAPE)
559 for (i = 0; i < as->rank + as->corank; i++)
561 if (as->lower[i] == NULL)
562 as->lower[i] = gfc_int_expr (1);
571 /* Something went wrong. */
572 gfc_free_array_spec (as);
577 /* Given a symbol and an array specification, modify the symbol to
578 have that array specification. The error locus is needed in case
579 something goes wrong. On failure, the caller must free the spec. */
582 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
590 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
594 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
605 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
606 the codimension is simply added. */
607 gcc_assert (as->rank == 0 && sym->as->corank == 0);
609 sym->as->cotype = as->cotype;
610 sym->as->corank = as->corank;
611 for (i = 0; i < as->corank; i++)
613 sym->as->lower[sym->as->rank + i] = as->lower[i];
614 sym->as->upper[sym->as->rank + i] = as->upper[i];
619 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
620 the dimension is added - but first the codimensions (if existing
621 need to be shifted to make space for the dimension. */
622 gcc_assert (as->corank == 0 && sym->as->rank == 0);
624 sym->as->rank = as->rank;
625 sym->as->type = as->type;
626 sym->as->cray_pointee = as->cray_pointee;
627 sym->as->cp_was_assumed = as->cp_was_assumed;
629 for (i = 0; i < sym->as->corank; i++)
631 sym->as->lower[as->rank + i] = sym->as->lower[i];
632 sym->as->upper[as->rank + i] = sym->as->upper[i];
634 for (i = 0; i < as->rank; i++)
636 sym->as->lower[i] = as->lower[i];
637 sym->as->upper[i] = as->upper[i];
646 /* Copy an array specification. */
649 gfc_copy_array_spec (gfc_array_spec *src)
651 gfc_array_spec *dest;
657 dest = gfc_get_array_spec ();
661 for (i = 0; i < dest->rank + dest->corank; i++)
663 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
664 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
671 /* Returns nonzero if the two expressions are equal. Only handles integer
675 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
677 if (bound1 == NULL || bound2 == NULL
678 || bound1->expr_type != EXPR_CONSTANT
679 || bound2->expr_type != EXPR_CONSTANT
680 || bound1->ts.type != BT_INTEGER
681 || bound2->ts.type != BT_INTEGER)
682 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
684 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
691 /* Compares two array specifications. They must be constant or deferred
695 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
699 if (as1 == NULL && as2 == NULL)
702 if (as1 == NULL || as2 == NULL)
705 if (as1->rank != as2->rank)
708 if (as1->corank != as2->corank)
714 if (as1->type != as2->type)
717 if (as1->type == AS_EXPLICIT)
718 for (i = 0; i < as1->rank + as1->corank; i++)
720 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
723 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
731 /****************** Array constructor functions ******************/
733 /* Start an array constructor. The constructor starts with zero
734 elements and should be appended to by gfc_append_constructor(). */
737 gfc_start_constructor (bt type, int kind, locus *where)
741 result = gfc_get_expr ();
743 result->expr_type = EXPR_ARRAY;
746 result->ts.type = type;
747 result->ts.kind = kind;
748 result->where = *where;
753 /* Given an array constructor expression, append the new expression
754 node onto the constructor. */
757 gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
761 if (base->value.constructor == NULL)
762 base->value.constructor = c = gfc_get_constructor ();
765 c = base->value.constructor;
769 c->next = gfc_get_constructor ();
776 && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
777 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
781 /* Given an array constructor expression, insert the new expression's
782 constructor onto the base's one according to the offset. */
785 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
787 gfc_constructor *c, *pre;
791 type = base->expr_type;
793 if (base->value.constructor == NULL)
794 base->value.constructor = c1;
797 c = pre = base->value.constructor;
800 if (type == EXPR_ARRAY)
802 t = mpz_cmp (c->n.offset, c1->n.offset);
810 gfc_error ("duplicated initializer");
831 base->value.constructor = c1;
837 /* Get a new constructor. */
840 gfc_get_constructor (void)
844 c = XCNEW (gfc_constructor);
848 mpz_init_set_si (c->n.offset, 0);
849 mpz_init_set_si (c->repeat, 0);
854 /* Free chains of gfc_constructor structures. */
857 gfc_free_constructor (gfc_constructor *p)
859 gfc_constructor *next;
869 gfc_free_expr (p->expr);
870 if (p->iterator != NULL)
871 gfc_free_iterator (p->iterator, 1);
872 mpz_clear (p->n.offset);
873 mpz_clear (p->repeat);
879 /* Given an expression node that might be an array constructor and a
880 symbol, make sure that no iterators in this or child constructors
881 use the symbol as an implied-DO iterator. Returns nonzero if a
882 duplicate was found. */
885 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
889 for (; c; c = c->next)
893 if (e->expr_type == EXPR_ARRAY
894 && check_duplicate_iterator (e->value.constructor, master))
897 if (c->iterator == NULL)
900 if (c->iterator->var->symtree->n.sym == master)
902 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
903 "same name", master->name, &c->where);
913 /* Forward declaration because these functions are mutually recursive. */
914 static match match_array_cons_element (gfc_constructor **);
916 /* Match a list of array elements. */
919 match_array_list (gfc_constructor **result)
921 gfc_constructor *p, *head, *tail, *new_cons;
928 old_loc = gfc_current_locus;
930 if (gfc_match_char ('(') == MATCH_NO)
933 memset (&iter, '\0', sizeof (gfc_iterator));
936 m = match_array_cons_element (&head);
942 if (gfc_match_char (',') != MATCH_YES)
950 m = gfc_match_iterator (&iter, 0);
953 if (m == MATCH_ERROR)
956 m = match_array_cons_element (&new_cons);
957 if (m == MATCH_ERROR)
964 goto cleanup; /* Could be a complex constant */
967 tail->next = new_cons;
970 if (gfc_match_char (',') != MATCH_YES)
979 if (gfc_match_char (')') != MATCH_YES)
982 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
989 e->expr_type = EXPR_ARRAY;
991 e->value.constructor = head;
993 p = gfc_get_constructor ();
994 p->where = gfc_current_locus;
995 p->iterator = gfc_get_iterator ();
1004 gfc_error ("Syntax error in array constructor at %C");
1008 gfc_free_constructor (head);
1009 gfc_free_iterator (&iter, 0);
1010 gfc_current_locus = old_loc;
1015 /* Match a single element of an array constructor, which can be a
1016 single expression or a list of elements. */
1019 match_array_cons_element (gfc_constructor **result)
1025 m = match_array_list (result);
1029 m = gfc_match_expr (&expr);
1033 p = gfc_get_constructor ();
1034 p->where = gfc_current_locus;
1042 /* Match an array constructor. */
1045 gfc_match_array_constructor (gfc_expr **result)
1047 gfc_constructor *head, *tail, *new_cons;
1052 const char *end_delim;
1055 if (gfc_match (" (/") == MATCH_NO)
1057 if (gfc_match (" [") == MATCH_NO)
1061 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1062 "style array constructors at %C") == FAILURE)
1070 where = gfc_current_locus;
1074 /* Try to match an optional "type-spec ::" */
1075 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1077 seen_ts = (gfc_match (" ::") == MATCH_YES);
1081 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1082 "including type specification at %C") == FAILURE)
1088 gfc_current_locus = where;
1090 if (gfc_match (end_delim) == MATCH_YES)
1096 gfc_error ("Empty array constructor at %C is not allowed");
1103 m = match_array_cons_element (&new_cons);
1104 if (m == MATCH_ERROR)
1112 tail->next = new_cons;
1116 if (gfc_match_char (',') == MATCH_NO)
1120 if (gfc_match (end_delim) == MATCH_NO)
1124 expr = gfc_get_expr ();
1126 expr->expr_type = EXPR_ARRAY;
1128 expr->value.constructor = head;
1129 /* Size must be calculated at resolution time. */
1134 expr->ts.type = BT_UNKNOWN;
1137 expr->ts.u.cl->length_from_typespec = seen_ts;
1139 expr->where = where;
1146 gfc_error ("Syntax error in array constructor at %C");
1149 gfc_free_constructor (head);
1155 /************** Check array constructors for correctness **************/
1157 /* Given an expression, compare it's type with the type of the current
1158 constructor. Returns nonzero if an error was issued. The
1159 cons_state variable keeps track of whether the type of the
1160 constructor being read or resolved is known to be good, bad or just
1163 static gfc_typespec constructor_ts;
1165 { CONS_START, CONS_GOOD, CONS_BAD }
1169 check_element_type (gfc_expr *expr, bool convert)
1171 if (cons_state == CONS_BAD)
1172 return 0; /* Suppress further errors */
1174 if (cons_state == CONS_START)
1176 if (expr->ts.type == BT_UNKNOWN)
1177 cons_state = CONS_BAD;
1180 cons_state = CONS_GOOD;
1181 constructor_ts = expr->ts;
1187 if (gfc_compare_types (&constructor_ts, &expr->ts))
1191 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1193 gfc_error ("Element in %s array constructor at %L is %s",
1194 gfc_typename (&constructor_ts), &expr->where,
1195 gfc_typename (&expr->ts));
1197 cons_state = CONS_BAD;
1202 /* Recursive work function for gfc_check_constructor_type(). */
1205 check_constructor_type (gfc_constructor *c, bool convert)
1209 for (; c; c = c->next)
1213 if (e->expr_type == EXPR_ARRAY)
1215 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1221 if (check_element_type (e, convert))
1229 /* Check that all elements of an array constructor are the same type.
1230 On FAILURE, an error has been generated. */
1233 gfc_check_constructor_type (gfc_expr *e)
1237 if (e->ts.type != BT_UNKNOWN)
1239 cons_state = CONS_GOOD;
1240 constructor_ts = e->ts;
1244 cons_state = CONS_START;
1245 gfc_clear_ts (&constructor_ts);
1248 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1249 typespec, and we will now convert the values on the fly. */
1250 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1251 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1252 e->ts = constructor_ts;
1259 typedef struct cons_stack
1261 gfc_iterator *iterator;
1262 struct cons_stack *previous;
1266 static cons_stack *base;
1268 static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
1270 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1271 that that variable is an iteration variables. */
1274 gfc_check_iter_variable (gfc_expr *expr)
1279 sym = expr->symtree->n.sym;
1281 for (c = base; c; c = c->previous)
1282 if (sym == c->iterator->var->symtree->n.sym)
1289 /* Recursive work function for gfc_check_constructor(). This amounts
1290 to calling the check function for each expression in the
1291 constructor, giving variables with the names of iterators a pass. */
1294 check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
1300 for (; c; c = c->next)
1304 if (e->expr_type != EXPR_ARRAY)
1306 if ((*check_function) (e) == FAILURE)
1311 element.previous = base;
1312 element.iterator = c->iterator;
1315 t = check_constructor (e->value.constructor, check_function);
1316 base = element.previous;
1322 /* Nothing went wrong, so all OK. */
1327 /* Checks a constructor to see if it is a particular kind of
1328 expression -- specification, restricted, or initialization as
1329 determined by the check_function. */
1332 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1334 cons_stack *base_save;
1340 t = check_constructor (expr->value.constructor, check_function);
1348 /**************** Simplification of array constructors ****************/
1350 iterator_stack *iter_stack;
1354 gfc_constructor *new_head, *new_tail;
1355 int extract_count, extract_n;
1356 gfc_expr *extracted;
1360 gfc_component *component;
1363 gfc_try (*expand_work_function) (gfc_expr *);
1367 static expand_info current_expand;
1369 static gfc_try expand_constructor (gfc_constructor *);
1372 /* Work function that counts the number of elements present in a
1376 count_elements (gfc_expr *e)
1381 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1384 if (gfc_array_size (e, &result) == FAILURE)
1390 mpz_add (*current_expand.count, *current_expand.count, result);
1399 /* Work function that extracts a particular element from an array
1400 constructor, freeing the rest. */
1403 extract_element (gfc_expr *e)
1406 { /* Something unextractable */
1411 if (current_expand.extract_count == current_expand.extract_n)
1412 current_expand.extracted = e;
1416 current_expand.extract_count++;
1422 /* Work function that constructs a new constructor out of the old one,
1423 stringing new elements together. */
1426 expand (gfc_expr *e)
1428 if (current_expand.new_head == NULL)
1429 current_expand.new_head = current_expand.new_tail =
1430 gfc_get_constructor ();
1433 current_expand.new_tail->next = gfc_get_constructor ();
1434 current_expand.new_tail = current_expand.new_tail->next;
1437 current_expand.new_tail->where = e->where;
1438 current_expand.new_tail->expr = e;
1440 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1441 current_expand.new_tail->n.component = current_expand.component;
1442 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1447 /* Given an initialization expression that is a variable reference,
1448 substitute the current value of the iteration variable. */
1451 gfc_simplify_iterator_var (gfc_expr *e)
1455 for (p = iter_stack; p; p = p->prev)
1456 if (e->symtree == p->variable)
1460 return; /* Variable not found */
1462 gfc_replace_expr (e, gfc_int_expr (0));
1464 mpz_set (e->value.integer, p->value);
1470 /* Expand an expression with that is inside of a constructor,
1471 recursing into other constructors if present. */
1474 expand_expr (gfc_expr *e)
1476 if (e->expr_type == EXPR_ARRAY)
1477 return expand_constructor (e->value.constructor);
1479 e = gfc_copy_expr (e);
1481 if (gfc_simplify_expr (e, 1) == FAILURE)
1487 return current_expand.expand_work_function (e);
1492 expand_iterator (gfc_constructor *c)
1494 gfc_expr *start, *end, *step;
1495 iterator_stack frame;
1504 mpz_init (frame.value);
1507 start = gfc_copy_expr (c->iterator->start);
1508 if (gfc_simplify_expr (start, 1) == FAILURE)
1511 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1514 end = gfc_copy_expr (c->iterator->end);
1515 if (gfc_simplify_expr (end, 1) == FAILURE)
1518 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1521 step = gfc_copy_expr (c->iterator->step);
1522 if (gfc_simplify_expr (step, 1) == FAILURE)
1525 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1528 if (mpz_sgn (step->value.integer) == 0)
1530 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1534 /* Calculate the trip count of the loop. */
1535 mpz_sub (trip, end->value.integer, start->value.integer);
1536 mpz_add (trip, trip, step->value.integer);
1537 mpz_tdiv_q (trip, trip, step->value.integer);
1539 mpz_set (frame.value, start->value.integer);
1541 frame.prev = iter_stack;
1542 frame.variable = c->iterator->var->symtree;
1543 iter_stack = &frame;
1545 while (mpz_sgn (trip) > 0)
1547 if (expand_expr (c->expr) == FAILURE)
1550 mpz_add (frame.value, frame.value, step->value.integer);
1551 mpz_sub_ui (trip, trip, 1);
1557 gfc_free_expr (start);
1558 gfc_free_expr (end);
1559 gfc_free_expr (step);
1562 mpz_clear (frame.value);
1564 iter_stack = frame.prev;
1570 /* Expand a constructor into constant constructors without any
1571 iterators, calling the work function for each of the expanded
1572 expressions. The work function needs to either save or free the
1573 passed expression. */
1576 expand_constructor (gfc_constructor *c)
1580 for (; c; c = c->next)
1582 if (c->iterator != NULL)
1584 if (expand_iterator (c) == FAILURE)
1591 if (e->expr_type == EXPR_ARRAY)
1593 if (expand_constructor (e->value.constructor) == FAILURE)
1599 e = gfc_copy_expr (e);
1600 if (gfc_simplify_expr (e, 1) == FAILURE)
1605 current_expand.offset = &c->n.offset;
1606 current_expand.component = c->n.component;
1607 current_expand.repeat = &c->repeat;
1608 if (current_expand.expand_work_function (e) == FAILURE)
1615 /* Top level subroutine for expanding constructors. We only expand
1616 constructor if they are small enough. */
1619 gfc_expand_constructor (gfc_expr *e)
1621 expand_info expand_save;
1625 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1632 expand_save = current_expand;
1633 current_expand.new_head = current_expand.new_tail = NULL;
1637 current_expand.expand_work_function = expand;
1639 if (expand_constructor (e->value.constructor) == FAILURE)
1641 gfc_free_constructor (current_expand.new_head);
1646 gfc_free_constructor (e->value.constructor);
1647 e->value.constructor = current_expand.new_head;
1652 current_expand = expand_save;
1658 /* Work function for checking that an element of a constructor is a
1659 constant, after removal of any iteration variables. We return
1660 FAILURE if not so. */
1663 is_constant_element (gfc_expr *e)
1667 rv = gfc_is_constant_expr (e);
1670 return rv ? SUCCESS : FAILURE;
1674 /* Given an array constructor, determine if the constructor is
1675 constant or not by expanding it and making sure that all elements
1676 are constants. This is a bit of a hack since something like (/ (i,
1677 i=1,100000000) /) will take a while as* opposed to a more clever
1678 function that traverses the expression tree. FIXME. */
1681 gfc_constant_ac (gfc_expr *e)
1683 expand_info expand_save;
1685 gfc_constructor * con;
1689 if (e->value.constructor
1690 && e->value.constructor->expr->expr_type == EXPR_ARRAY)
1692 /* Expand the constructor. */
1694 expand_save = current_expand;
1695 current_expand.expand_work_function = is_constant_element;
1697 rc = expand_constructor (e->value.constructor);
1699 current_expand = expand_save;
1703 /* No need to expand this further. */
1704 for (con = e->value.constructor; con; con = con->next)
1706 if (con->expr->expr_type == EXPR_CONSTANT)
1710 if (!gfc_is_constant_expr (con->expr))
1723 /* Returns nonzero if an array constructor has been completely
1724 expanded (no iterators) and zero if iterators are present. */
1727 gfc_expanded_ac (gfc_expr *e)
1731 if (e->expr_type == EXPR_ARRAY)
1732 for (p = e->value.constructor; p; p = p->next)
1733 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1740 /*************** Type resolution of array constructors ***************/
1742 /* Recursive array list resolution function. All of the elements must
1743 be of the same type. */
1746 resolve_array_list (gfc_constructor *p)
1752 for (; p; p = p->next)
1754 if (p->iterator != NULL
1755 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1758 if (gfc_resolve_expr (p->expr) == FAILURE)
1765 /* Resolve character array constructor. If it has a specified constant character
1766 length, pad/truncate the elements here; if the length is not specified and
1767 all elements are of compile-time known length, emit an error as this is
1771 gfc_resolve_character_array_constructor (gfc_expr *expr)
1776 gcc_assert (expr->expr_type == EXPR_ARRAY);
1777 gcc_assert (expr->ts.type == BT_CHARACTER);
1779 if (expr->ts.u.cl == NULL)
1781 for (p = expr->value.constructor; p; p = p->next)
1782 if (p->expr->ts.u.cl != NULL)
1784 /* Ensure that if there is a char_len around that it is
1785 used; otherwise the middle-end confuses them! */
1786 expr->ts.u.cl = p->expr->ts.u.cl;
1790 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1797 if (expr->ts.u.cl->length == NULL)
1799 /* Check that all constant string elements have the same length until
1800 we reach the end or find a variable-length one. */
1802 for (p = expr->value.constructor; p; p = p->next)
1804 int current_length = -1;
1806 for (ref = p->expr->ref; ref; ref = ref->next)
1807 if (ref->type == REF_SUBSTRING
1808 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1809 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1812 if (p->expr->expr_type == EXPR_CONSTANT)
1813 current_length = p->expr->value.character.length;
1817 j = mpz_get_ui (ref->u.ss.end->value.integer)
1818 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1819 current_length = (int) j;
1821 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1822 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1825 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1826 current_length = (int) j;
1831 gcc_assert (current_length != -1);
1833 if (found_length == -1)
1834 found_length = current_length;
1835 else if (found_length != current_length)
1837 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1838 " constructor at %L", found_length, current_length,
1843 gcc_assert (found_length == current_length);
1846 gcc_assert (found_length != -1);
1848 /* Update the character length of the array constructor. */
1849 expr->ts.u.cl->length = gfc_int_expr (found_length);
1853 /* We've got a character length specified. It should be an integer,
1854 otherwise an error is signalled elsewhere. */
1855 gcc_assert (expr->ts.u.cl->length);
1857 /* If we've got a constant character length, pad according to this.
1858 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1859 max_length only if they pass. */
1860 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1862 /* Now pad/truncate the elements accordingly to the specified character
1863 length. This is ok inside this conditional, as in the case above
1864 (without typespec) all elements are verified to have the same length
1866 if (found_length != -1)
1867 for (p = expr->value.constructor; p; p = p->next)
1868 if (p->expr->expr_type == EXPR_CONSTANT)
1870 gfc_expr *cl = NULL;
1871 int current_length = -1;
1874 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1876 cl = p->expr->ts.u.cl->length;
1877 gfc_extract_int (cl, ¤t_length);
1880 /* If gfc_extract_int above set current_length, we implicitly
1881 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1883 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1886 || (current_length != -1 && current_length < found_length))
1887 gfc_set_constant_character_len (found_length, p->expr,
1888 has_ts ? -1 : found_length);
1896 /* Resolve all of the expressions in an array list. */
1899 gfc_resolve_array_constructor (gfc_expr *expr)
1903 t = resolve_array_list (expr->value.constructor);
1905 t = gfc_check_constructor_type (expr);
1907 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1908 the call to this function, so we don't need to call it here; if it was
1909 called twice, an error message there would be duplicated. */
1915 /* Copy an iterator structure. */
1917 static gfc_iterator *
1918 copy_iterator (gfc_iterator *src)
1925 dest = gfc_get_iterator ();
1927 dest->var = gfc_copy_expr (src->var);
1928 dest->start = gfc_copy_expr (src->start);
1929 dest->end = gfc_copy_expr (src->end);
1930 dest->step = gfc_copy_expr (src->step);
1936 /* Copy a constructor structure. */
1939 gfc_copy_constructor (gfc_constructor *src)
1941 gfc_constructor *dest;
1942 gfc_constructor *tail;
1951 dest = tail = gfc_get_constructor ();
1954 tail->next = gfc_get_constructor ();
1957 tail->where = src->where;
1958 tail->expr = gfc_copy_expr (src->expr);
1959 tail->iterator = copy_iterator (src->iterator);
1960 mpz_set (tail->n.offset, src->n.offset);
1961 tail->n.component = src->n.component;
1962 mpz_set (tail->repeat, src->repeat);
1970 /* Given an array expression and an element number (starting at zero),
1971 return a pointer to the array element. NULL is returned if the
1972 size of the array has been exceeded. The expression node returned
1973 remains a part of the array and should not be freed. Access is not
1974 efficient at all, but this is another place where things do not
1975 have to be particularly fast. */
1978 gfc_get_array_element (gfc_expr *array, int element)
1980 expand_info expand_save;
1984 expand_save = current_expand;
1985 current_expand.extract_n = element;
1986 current_expand.expand_work_function = extract_element;
1987 current_expand.extracted = NULL;
1988 current_expand.extract_count = 0;
1992 rc = expand_constructor (array->value.constructor);
1993 e = current_expand.extracted;
1994 current_expand = expand_save;
2003 /********* Subroutines for determining the size of an array *********/
2005 /* These are needed just to accommodate RESHAPE(). There are no
2006 diagnostics here, we just return a negative number if something
2010 /* Get the size of single dimension of an array specification. The
2011 array is guaranteed to be one dimensional. */
2014 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2019 if (dimen < 0 || dimen > as->rank - 1)
2020 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2022 if (as->type != AS_EXPLICIT
2023 || as->lower[dimen]->expr_type != EXPR_CONSTANT
2024 || as->upper[dimen]->expr_type != EXPR_CONSTANT
2025 || as->lower[dimen]->ts.type != BT_INTEGER
2026 || as->upper[dimen]->ts.type != BT_INTEGER)
2031 mpz_sub (*result, as->upper[dimen]->value.integer,
2032 as->lower[dimen]->value.integer);
2034 mpz_add_ui (*result, *result, 1);
2041 spec_size (gfc_array_spec *as, mpz_t *result)
2046 mpz_init_set_ui (*result, 1);
2048 for (d = 0; d < as->rank; d++)
2050 if (spec_dimen_size (as, d, &size) == FAILURE)
2052 mpz_clear (*result);
2056 mpz_mul (*result, *result, size);
2064 /* Get the number of elements in an array section. */
2067 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
2069 mpz_t upper, lower, stride;
2072 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
2073 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2075 switch (ar->dimen_type[dimen])
2079 mpz_set_ui (*result, 1);
2084 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2093 if (ar->start[dimen] == NULL)
2095 if (ar->as->lower[dimen] == NULL
2096 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
2098 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2102 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2104 mpz_set (lower, ar->start[dimen]->value.integer);
2107 if (ar->end[dimen] == NULL)
2109 if (ar->as->upper[dimen] == NULL
2110 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2112 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2116 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2118 mpz_set (upper, ar->end[dimen]->value.integer);
2121 if (ar->stride[dimen] == NULL)
2122 mpz_set_ui (stride, 1);
2125 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2127 mpz_set (stride, ar->stride[dimen]->value.integer);
2131 mpz_sub (*result, upper, lower);
2132 mpz_add (*result, *result, stride);
2133 mpz_div (*result, *result, stride);
2135 /* Zero stride caught earlier. */
2136 if (mpz_cmp_ui (*result, 0) < 0)
2137 mpz_set_ui (*result, 0);
2147 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2155 ref_size (gfc_array_ref *ar, mpz_t *result)
2160 mpz_init_set_ui (*result, 1);
2162 for (d = 0; d < ar->dimen; d++)
2164 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2166 mpz_clear (*result);
2170 mpz_mul (*result, *result, size);
2178 /* Given an array expression and a dimension, figure out how many
2179 elements it has along that dimension. Returns SUCCESS if we were
2180 able to return a result in the 'result' variable, FAILURE
2184 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2189 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2190 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2192 switch (array->expr_type)
2196 for (ref = array->ref; ref; ref = ref->next)
2198 if (ref->type != REF_ARRAY)
2201 if (ref->u.ar.type == AR_FULL)
2202 return spec_dimen_size (ref->u.ar.as, dimen, result);
2204 if (ref->u.ar.type == AR_SECTION)
2206 for (i = 0; dimen >= 0; i++)
2207 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2210 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2214 if (array->shape && array->shape[dimen])
2216 mpz_init_set (*result, array->shape[dimen]);
2220 if (array->symtree->n.sym->attr.generic
2221 && array->value.function.esym != NULL)
2223 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2227 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2234 if (array->shape == NULL) {
2235 /* Expressions with rank > 1 should have "shape" properly set */
2236 if ( array->rank != 1 )
2237 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2238 return gfc_array_size(array, result);
2243 if (array->shape == NULL)
2246 mpz_init_set (*result, array->shape[dimen]);
2255 /* Given an array expression, figure out how many elements are in the
2256 array. Returns SUCCESS if this is possible, and sets the 'result'
2257 variable. Otherwise returns FAILURE. */
2260 gfc_array_size (gfc_expr *array, mpz_t *result)
2262 expand_info expand_save;
2267 switch (array->expr_type)
2270 gfc_push_suppress_errors ();
2272 expand_save = current_expand;
2274 current_expand.count = result;
2275 mpz_init_set_ui (*result, 0);
2277 current_expand.expand_work_function = count_elements;
2280 t = expand_constructor (array->value.constructor);
2282 gfc_pop_suppress_errors ();
2285 mpz_clear (*result);
2286 current_expand = expand_save;
2290 for (ref = array->ref; ref; ref = ref->next)
2292 if (ref->type != REF_ARRAY)
2295 if (ref->u.ar.type == AR_FULL)
2296 return spec_size (ref->u.ar.as, result);
2298 if (ref->u.ar.type == AR_SECTION)
2299 return ref_size (&ref->u.ar, result);
2302 return spec_size (array->symtree->n.sym->as, result);
2306 if (array->rank == 0 || array->shape == NULL)
2309 mpz_init_set_ui (*result, 1);
2311 for (i = 0; i < array->rank; i++)
2312 mpz_mul (*result, *result, array->shape[i]);
2321 /* Given an array reference, return the shape of the reference in an
2322 array of mpz_t integers. */
2325 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2335 for (; d < ar->as->rank; d++)
2336 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2342 for (i = 0; i < ar->dimen; i++)
2344 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2346 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2359 for (d--; d >= 0; d--)
2360 mpz_clear (shape[d]);
2366 /* Given an array expression, find the array reference structure that
2367 characterizes the reference. */
2370 gfc_find_array_ref (gfc_expr *e)
2374 for (ref = e->ref; ref; ref = ref->next)
2375 if (ref->type == REF_ARRAY
2376 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2380 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2386 /* Find out if an array shape is known at compile time. */
2389 gfc_is_compile_time_shape (gfc_array_spec *as)
2393 if (as->type != AS_EXPLICIT)
2396 for (i = 0; i < as->rank; i++)
2397 if (!gfc_is_constant_expr (as->lower[i])
2398 || !gfc_is_constant_expr (as->upper[i]))