2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
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; 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; 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 - 1];
294 upper = &as->upper[as->rank - 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
341 gfc_match_array_spec (gfc_array_spec **asp)
343 array_type current_type;
347 if (gfc_match_char ('(') != MATCH_YES)
353 as = gfc_get_array_spec ();
355 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
365 current_type = match_array_element_spec (as);
369 if (current_type == AS_UNKNOWN)
371 as->type = current_type;
375 { /* See how current spec meshes with the existing. */
380 if (current_type == AS_ASSUMED_SIZE)
382 as->type = AS_ASSUMED_SIZE;
386 if (current_type == AS_EXPLICIT)
389 gfc_error ("Bad array specification for an explicitly shaped "
394 case AS_ASSUMED_SHAPE:
395 if ((current_type == AS_ASSUMED_SHAPE)
396 || (current_type == AS_DEFERRED))
399 gfc_error ("Bad array specification for assumed shape "
404 if (current_type == AS_DEFERRED)
407 if (current_type == AS_ASSUMED_SHAPE)
409 as->type = AS_ASSUMED_SHAPE;
413 gfc_error ("Bad specification for deferred shape array at %C");
416 case AS_ASSUMED_SIZE:
417 gfc_error ("Bad specification for assumed size array at %C");
421 if (gfc_match_char (')') == MATCH_YES)
424 if (gfc_match_char (',') != MATCH_YES)
426 gfc_error ("Expected another dimension in array declaration at %C");
430 if (as->rank >= GFC_MAX_DIMENSIONS)
432 gfc_error ("Array specification at %C has more than %d dimensions",
438 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
439 "specification at %C with more than 7 dimensions")
446 /* If a lower bounds of an assumed shape array is blank, put in one. */
447 if (as->type == AS_ASSUMED_SHAPE)
449 for (i = 0; i < as->rank; i++)
451 if (as->lower[i] == NULL)
452 as->lower[i] = gfc_int_expr (1);
459 /* Something went wrong. */
460 gfc_free_array_spec (as);
465 /* Given a symbol and an array specification, modify the symbol to
466 have that array specification. The error locus is needed in case
467 something goes wrong. On failure, the caller must free the spec. */
470 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
475 if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
484 /* Copy an array specification. */
487 gfc_copy_array_spec (gfc_array_spec *src)
489 gfc_array_spec *dest;
495 dest = gfc_get_array_spec ();
499 for (i = 0; i < dest->rank; i++)
501 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
502 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
509 /* Returns nonzero if the two expressions are equal. Only handles integer
513 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
515 if (bound1 == NULL || bound2 == NULL
516 || bound1->expr_type != EXPR_CONSTANT
517 || bound2->expr_type != EXPR_CONSTANT
518 || bound1->ts.type != BT_INTEGER
519 || bound2->ts.type != BT_INTEGER)
520 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
522 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
529 /* Compares two array specifications. They must be constant or deferred
533 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
537 if (as1 == NULL && as2 == NULL)
540 if (as1 == NULL || as2 == NULL)
543 if (as1->rank != as2->rank)
549 if (as1->type != as2->type)
552 if (as1->type == AS_EXPLICIT)
553 for (i = 0; i < as1->rank; i++)
555 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
558 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
566 /****************** Array constructor functions ******************/
568 /* Start an array constructor. The constructor starts with zero
569 elements and should be appended to by gfc_append_constructor(). */
572 gfc_start_constructor (bt type, int kind, locus *where)
576 result = gfc_get_expr ();
578 result->expr_type = EXPR_ARRAY;
581 result->ts.type = type;
582 result->ts.kind = kind;
583 result->where = *where;
588 /* Given an array constructor expression, append the new expression
589 node onto the constructor. */
592 gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
596 if (base->value.constructor == NULL)
597 base->value.constructor = c = gfc_get_constructor ();
600 c = base->value.constructor;
604 c->next = gfc_get_constructor ();
611 && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
612 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
616 /* Given an array constructor expression, insert the new expression's
617 constructor onto the base's one according to the offset. */
620 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
622 gfc_constructor *c, *pre;
626 type = base->expr_type;
628 if (base->value.constructor == NULL)
629 base->value.constructor = c1;
632 c = pre = base->value.constructor;
635 if (type == EXPR_ARRAY)
637 t = mpz_cmp (c->n.offset, c1->n.offset);
645 gfc_error ("duplicated initializer");
666 base->value.constructor = c1;
672 /* Get a new constructor. */
675 gfc_get_constructor (void)
679 c = XCNEW (gfc_constructor);
683 mpz_init_set_si (c->n.offset, 0);
684 mpz_init_set_si (c->repeat, 0);
689 /* Free chains of gfc_constructor structures. */
692 gfc_free_constructor (gfc_constructor *p)
694 gfc_constructor *next;
704 gfc_free_expr (p->expr);
705 if (p->iterator != NULL)
706 gfc_free_iterator (p->iterator, 1);
707 mpz_clear (p->n.offset);
708 mpz_clear (p->repeat);
714 /* Given an expression node that might be an array constructor and a
715 symbol, make sure that no iterators in this or child constructors
716 use the symbol as an implied-DO iterator. Returns nonzero if a
717 duplicate was found. */
720 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
724 for (; c; c = c->next)
728 if (e->expr_type == EXPR_ARRAY
729 && check_duplicate_iterator (e->value.constructor, master))
732 if (c->iterator == NULL)
735 if (c->iterator->var->symtree->n.sym == master)
737 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
738 "same name", master->name, &c->where);
748 /* Forward declaration because these functions are mutually recursive. */
749 static match match_array_cons_element (gfc_constructor **);
751 /* Match a list of array elements. */
754 match_array_list (gfc_constructor **result)
756 gfc_constructor *p, *head, *tail, *new_cons;
763 old_loc = gfc_current_locus;
765 if (gfc_match_char ('(') == MATCH_NO)
768 memset (&iter, '\0', sizeof (gfc_iterator));
771 m = match_array_cons_element (&head);
777 if (gfc_match_char (',') != MATCH_YES)
785 m = gfc_match_iterator (&iter, 0);
788 if (m == MATCH_ERROR)
791 m = match_array_cons_element (&new_cons);
792 if (m == MATCH_ERROR)
799 goto cleanup; /* Could be a complex constant */
802 tail->next = new_cons;
805 if (gfc_match_char (',') != MATCH_YES)
814 if (gfc_match_char (')') != MATCH_YES)
817 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
824 e->expr_type = EXPR_ARRAY;
826 e->value.constructor = head;
828 p = gfc_get_constructor ();
829 p->where = gfc_current_locus;
830 p->iterator = gfc_get_iterator ();
839 gfc_error ("Syntax error in array constructor at %C");
843 gfc_free_constructor (head);
844 gfc_free_iterator (&iter, 0);
845 gfc_current_locus = old_loc;
850 /* Match a single element of an array constructor, which can be a
851 single expression or a list of elements. */
854 match_array_cons_element (gfc_constructor **result)
860 m = match_array_list (result);
864 m = gfc_match_expr (&expr);
868 p = gfc_get_constructor ();
869 p->where = gfc_current_locus;
877 /* Match an array constructor. */
880 gfc_match_array_constructor (gfc_expr **result)
882 gfc_constructor *head, *tail, *new_cons;
887 const char *end_delim;
890 if (gfc_match (" (/") == MATCH_NO)
892 if (gfc_match (" [") == MATCH_NO)
896 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
897 "style array constructors at %C") == FAILURE)
905 where = gfc_current_locus;
909 /* Try to match an optional "type-spec ::" */
910 if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
912 seen_ts = (gfc_match (" ::") == MATCH_YES);
916 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
917 "including type specification at %C") == FAILURE)
923 gfc_current_locus = where;
925 if (gfc_match (end_delim) == MATCH_YES)
931 gfc_error ("Empty array constructor at %C is not allowed");
938 m = match_array_cons_element (&new_cons);
939 if (m == MATCH_ERROR)
947 tail->next = new_cons;
951 if (gfc_match_char (',') == MATCH_NO)
955 if (gfc_match (end_delim) == MATCH_NO)
959 expr = gfc_get_expr ();
961 expr->expr_type = EXPR_ARRAY;
963 expr->value.constructor = head;
964 /* Size must be calculated at resolution time. */
969 expr->ts.type = BT_UNKNOWN;
972 expr->ts.u.cl->length_from_typespec = seen_ts;
981 gfc_error ("Syntax error in array constructor at %C");
984 gfc_free_constructor (head);
990 /************** Check array constructors for correctness **************/
992 /* Given an expression, compare it's type with the type of the current
993 constructor. Returns nonzero if an error was issued. The
994 cons_state variable keeps track of whether the type of the
995 constructor being read or resolved is known to be good, bad or just
998 static gfc_typespec constructor_ts;
1000 { CONS_START, CONS_GOOD, CONS_BAD }
1004 check_element_type (gfc_expr *expr, bool convert)
1006 if (cons_state == CONS_BAD)
1007 return 0; /* Suppress further errors */
1009 if (cons_state == CONS_START)
1011 if (expr->ts.type == BT_UNKNOWN)
1012 cons_state = CONS_BAD;
1015 cons_state = CONS_GOOD;
1016 constructor_ts = expr->ts;
1022 if (gfc_compare_types (&constructor_ts, &expr->ts))
1026 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1028 gfc_error ("Element in %s array constructor at %L is %s",
1029 gfc_typename (&constructor_ts), &expr->where,
1030 gfc_typename (&expr->ts));
1032 cons_state = CONS_BAD;
1037 /* Recursive work function for gfc_check_constructor_type(). */
1040 check_constructor_type (gfc_constructor *c, bool convert)
1044 for (; c; c = c->next)
1048 if (e->expr_type == EXPR_ARRAY)
1050 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1056 if (check_element_type (e, convert))
1064 /* Check that all elements of an array constructor are the same type.
1065 On FAILURE, an error has been generated. */
1068 gfc_check_constructor_type (gfc_expr *e)
1072 if (e->ts.type != BT_UNKNOWN)
1074 cons_state = CONS_GOOD;
1075 constructor_ts = e->ts;
1079 cons_state = CONS_START;
1080 gfc_clear_ts (&constructor_ts);
1083 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1084 typespec, and we will now convert the values on the fly. */
1085 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1086 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1087 e->ts = constructor_ts;
1094 typedef struct cons_stack
1096 gfc_iterator *iterator;
1097 struct cons_stack *previous;
1101 static cons_stack *base;
1103 static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
1105 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1106 that that variable is an iteration variables. */
1109 gfc_check_iter_variable (gfc_expr *expr)
1114 sym = expr->symtree->n.sym;
1116 for (c = base; c; c = c->previous)
1117 if (sym == c->iterator->var->symtree->n.sym)
1124 /* Recursive work function for gfc_check_constructor(). This amounts
1125 to calling the check function for each expression in the
1126 constructor, giving variables with the names of iterators a pass. */
1129 check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
1135 for (; c; c = c->next)
1139 if (e->expr_type != EXPR_ARRAY)
1141 if ((*check_function) (e) == FAILURE)
1146 element.previous = base;
1147 element.iterator = c->iterator;
1150 t = check_constructor (e->value.constructor, check_function);
1151 base = element.previous;
1157 /* Nothing went wrong, so all OK. */
1162 /* Checks a constructor to see if it is a particular kind of
1163 expression -- specification, restricted, or initialization as
1164 determined by the check_function. */
1167 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1169 cons_stack *base_save;
1175 t = check_constructor (expr->value.constructor, check_function);
1183 /**************** Simplification of array constructors ****************/
1185 iterator_stack *iter_stack;
1189 gfc_constructor *new_head, *new_tail;
1190 int extract_count, extract_n;
1191 gfc_expr *extracted;
1195 gfc_component *component;
1198 gfc_try (*expand_work_function) (gfc_expr *);
1202 static expand_info current_expand;
1204 static gfc_try expand_constructor (gfc_constructor *);
1207 /* Work function that counts the number of elements present in a
1211 count_elements (gfc_expr *e)
1216 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1219 if (gfc_array_size (e, &result) == FAILURE)
1225 mpz_add (*current_expand.count, *current_expand.count, result);
1234 /* Work function that extracts a particular element from an array
1235 constructor, freeing the rest. */
1238 extract_element (gfc_expr *e)
1242 { /* Something unextractable */
1247 if (current_expand.extract_count == current_expand.extract_n)
1248 current_expand.extracted = e;
1252 current_expand.extract_count++;
1257 /* Work function that constructs a new constructor out of the old one,
1258 stringing new elements together. */
1261 expand (gfc_expr *e)
1263 if (current_expand.new_head == NULL)
1264 current_expand.new_head = current_expand.new_tail =
1265 gfc_get_constructor ();
1268 current_expand.new_tail->next = gfc_get_constructor ();
1269 current_expand.new_tail = current_expand.new_tail->next;
1272 current_expand.new_tail->where = e->where;
1273 current_expand.new_tail->expr = e;
1275 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1276 current_expand.new_tail->n.component = current_expand.component;
1277 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1282 /* Given an initialization expression that is a variable reference,
1283 substitute the current value of the iteration variable. */
1286 gfc_simplify_iterator_var (gfc_expr *e)
1290 for (p = iter_stack; p; p = p->prev)
1291 if (e->symtree == p->variable)
1295 return; /* Variable not found */
1297 gfc_replace_expr (e, gfc_int_expr (0));
1299 mpz_set (e->value.integer, p->value);
1305 /* Expand an expression with that is inside of a constructor,
1306 recursing into other constructors if present. */
1309 expand_expr (gfc_expr *e)
1311 if (e->expr_type == EXPR_ARRAY)
1312 return expand_constructor (e->value.constructor);
1314 e = gfc_copy_expr (e);
1316 if (gfc_simplify_expr (e, 1) == FAILURE)
1322 return current_expand.expand_work_function (e);
1327 expand_iterator (gfc_constructor *c)
1329 gfc_expr *start, *end, *step;
1330 iterator_stack frame;
1339 mpz_init (frame.value);
1342 start = gfc_copy_expr (c->iterator->start);
1343 if (gfc_simplify_expr (start, 1) == FAILURE)
1346 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1349 end = gfc_copy_expr (c->iterator->end);
1350 if (gfc_simplify_expr (end, 1) == FAILURE)
1353 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1356 step = gfc_copy_expr (c->iterator->step);
1357 if (gfc_simplify_expr (step, 1) == FAILURE)
1360 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1363 if (mpz_sgn (step->value.integer) == 0)
1365 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1369 /* Calculate the trip count of the loop. */
1370 mpz_sub (trip, end->value.integer, start->value.integer);
1371 mpz_add (trip, trip, step->value.integer);
1372 mpz_tdiv_q (trip, trip, step->value.integer);
1374 mpz_set (frame.value, start->value.integer);
1376 frame.prev = iter_stack;
1377 frame.variable = c->iterator->var->symtree;
1378 iter_stack = &frame;
1380 while (mpz_sgn (trip) > 0)
1382 if (expand_expr (c->expr) == FAILURE)
1385 mpz_add (frame.value, frame.value, step->value.integer);
1386 mpz_sub_ui (trip, trip, 1);
1392 gfc_free_expr (start);
1393 gfc_free_expr (end);
1394 gfc_free_expr (step);
1397 mpz_clear (frame.value);
1399 iter_stack = frame.prev;
1405 /* Expand a constructor into constant constructors without any
1406 iterators, calling the work function for each of the expanded
1407 expressions. The work function needs to either save or free the
1408 passed expression. */
1411 expand_constructor (gfc_constructor *c)
1415 for (; c; c = c->next)
1417 if (c->iterator != NULL)
1419 if (expand_iterator (c) == FAILURE)
1426 if (e->expr_type == EXPR_ARRAY)
1428 if (expand_constructor (e->value.constructor) == FAILURE)
1434 e = gfc_copy_expr (e);
1435 if (gfc_simplify_expr (e, 1) == FAILURE)
1440 current_expand.offset = &c->n.offset;
1441 current_expand.component = c->n.component;
1442 current_expand.repeat = &c->repeat;
1443 if (current_expand.expand_work_function (e) == FAILURE)
1450 /* Top level subroutine for expanding constructors. We only expand
1451 constructor if they are small enough. */
1454 gfc_expand_constructor (gfc_expr *e)
1456 expand_info expand_save;
1460 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1467 expand_save = current_expand;
1468 current_expand.new_head = current_expand.new_tail = NULL;
1472 current_expand.expand_work_function = expand;
1474 if (expand_constructor (e->value.constructor) == FAILURE)
1476 gfc_free_constructor (current_expand.new_head);
1481 gfc_free_constructor (e->value.constructor);
1482 e->value.constructor = current_expand.new_head;
1487 current_expand = expand_save;
1493 /* Work function for checking that an element of a constructor is a
1494 constant, after removal of any iteration variables. We return
1495 FAILURE if not so. */
1498 constant_element (gfc_expr *e)
1502 rv = gfc_is_constant_expr (e);
1505 return rv ? SUCCESS : FAILURE;
1509 /* Given an array constructor, determine if the constructor is
1510 constant or not by expanding it and making sure that all elements
1511 are constants. This is a bit of a hack since something like (/ (i,
1512 i=1,100000000) /) will take a while as* opposed to a more clever
1513 function that traverses the expression tree. FIXME. */
1516 gfc_constant_ac (gfc_expr *e)
1518 expand_info expand_save;
1522 expand_save = current_expand;
1523 current_expand.expand_work_function = constant_element;
1525 rc = expand_constructor (e->value.constructor);
1527 current_expand = expand_save;
1535 /* Returns nonzero if an array constructor has been completely
1536 expanded (no iterators) and zero if iterators are present. */
1539 gfc_expanded_ac (gfc_expr *e)
1543 if (e->expr_type == EXPR_ARRAY)
1544 for (p = e->value.constructor; p; p = p->next)
1545 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1552 /*************** Type resolution of array constructors ***************/
1554 /* Recursive array list resolution function. All of the elements must
1555 be of the same type. */
1558 resolve_array_list (gfc_constructor *p)
1564 for (; p; p = p->next)
1566 if (p->iterator != NULL
1567 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1570 if (gfc_resolve_expr (p->expr) == FAILURE)
1577 /* Resolve character array constructor. If it has a specified constant character
1578 length, pad/truncate the elements here; if the length is not specified and
1579 all elements are of compile-time known length, emit an error as this is
1583 gfc_resolve_character_array_constructor (gfc_expr *expr)
1588 gcc_assert (expr->expr_type == EXPR_ARRAY);
1589 gcc_assert (expr->ts.type == BT_CHARACTER);
1591 if (expr->ts.u.cl == NULL)
1593 for (p = expr->value.constructor; p; p = p->next)
1594 if (p->expr->ts.u.cl != NULL)
1596 /* Ensure that if there is a char_len around that it is
1597 used; otherwise the middle-end confuses them! */
1598 expr->ts.u.cl = p->expr->ts.u.cl;
1602 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns);
1609 if (expr->ts.u.cl->length == NULL)
1611 /* Check that all constant string elements have the same length until
1612 we reach the end or find a variable-length one. */
1614 for (p = expr->value.constructor; p; p = p->next)
1616 int current_length = -1;
1618 for (ref = p->expr->ref; ref; ref = ref->next)
1619 if (ref->type == REF_SUBSTRING
1620 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1621 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1624 if (p->expr->expr_type == EXPR_CONSTANT)
1625 current_length = p->expr->value.character.length;
1629 j = mpz_get_ui (ref->u.ss.end->value.integer)
1630 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1631 current_length = (int) j;
1633 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1634 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1637 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1638 current_length = (int) j;
1643 gcc_assert (current_length != -1);
1645 if (found_length == -1)
1646 found_length = current_length;
1647 else if (found_length != current_length)
1649 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1650 " constructor at %L", found_length, current_length,
1655 gcc_assert (found_length == current_length);
1658 gcc_assert (found_length != -1);
1660 /* Update the character length of the array constructor. */
1661 expr->ts.u.cl->length = gfc_int_expr (found_length);
1665 /* We've got a character length specified. It should be an integer,
1666 otherwise an error is signalled elsewhere. */
1667 gcc_assert (expr->ts.u.cl->length);
1669 /* If we've got a constant character length, pad according to this.
1670 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1671 max_length only if they pass. */
1672 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1674 /* Now pad/truncate the elements accordingly to the specified character
1675 length. This is ok inside this conditional, as in the case above
1676 (without typespec) all elements are verified to have the same length
1678 if (found_length != -1)
1679 for (p = expr->value.constructor; p; p = p->next)
1680 if (p->expr->expr_type == EXPR_CONSTANT)
1682 gfc_expr *cl = NULL;
1683 int current_length = -1;
1686 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1688 cl = p->expr->ts.u.cl->length;
1689 gfc_extract_int (cl, ¤t_length);
1692 /* If gfc_extract_int above set current_length, we implicitly
1693 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1695 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1698 || (current_length != -1 && current_length < found_length))
1699 gfc_set_constant_character_len (found_length, p->expr,
1700 has_ts ? -1 : found_length);
1708 /* Resolve all of the expressions in an array list. */
1711 gfc_resolve_array_constructor (gfc_expr *expr)
1715 t = resolve_array_list (expr->value.constructor);
1717 t = gfc_check_constructor_type (expr);
1719 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1720 the call to this function, so we don't need to call it here; if it was
1721 called twice, an error message there would be duplicated. */
1727 /* Copy an iterator structure. */
1729 static gfc_iterator *
1730 copy_iterator (gfc_iterator *src)
1737 dest = gfc_get_iterator ();
1739 dest->var = gfc_copy_expr (src->var);
1740 dest->start = gfc_copy_expr (src->start);
1741 dest->end = gfc_copy_expr (src->end);
1742 dest->step = gfc_copy_expr (src->step);
1748 /* Copy a constructor structure. */
1751 gfc_copy_constructor (gfc_constructor *src)
1753 gfc_constructor *dest;
1754 gfc_constructor *tail;
1763 dest = tail = gfc_get_constructor ();
1766 tail->next = gfc_get_constructor ();
1769 tail->where = src->where;
1770 tail->expr = gfc_copy_expr (src->expr);
1771 tail->iterator = copy_iterator (src->iterator);
1772 mpz_set (tail->n.offset, src->n.offset);
1773 tail->n.component = src->n.component;
1774 mpz_set (tail->repeat, src->repeat);
1782 /* Given an array expression and an element number (starting at zero),
1783 return a pointer to the array element. NULL is returned if the
1784 size of the array has been exceeded. The expression node returned
1785 remains a part of the array and should not be freed. Access is not
1786 efficient at all, but this is another place where things do not
1787 have to be particularly fast. */
1790 gfc_get_array_element (gfc_expr *array, int element)
1792 expand_info expand_save;
1796 expand_save = current_expand;
1797 current_expand.extract_n = element;
1798 current_expand.expand_work_function = extract_element;
1799 current_expand.extracted = NULL;
1800 current_expand.extract_count = 0;
1804 rc = expand_constructor (array->value.constructor);
1805 e = current_expand.extracted;
1806 current_expand = expand_save;
1815 /********* Subroutines for determining the size of an array *********/
1817 /* These are needed just to accommodate RESHAPE(). There are no
1818 diagnostics here, we just return a negative number if something
1822 /* Get the size of single dimension of an array specification. The
1823 array is guaranteed to be one dimensional. */
1826 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1831 if (dimen < 0 || dimen > as->rank - 1)
1832 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1834 if (as->type != AS_EXPLICIT
1835 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1836 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1837 || as->lower[dimen]->ts.type != BT_INTEGER
1838 || as->upper[dimen]->ts.type != BT_INTEGER)
1843 mpz_sub (*result, as->upper[dimen]->value.integer,
1844 as->lower[dimen]->value.integer);
1846 mpz_add_ui (*result, *result, 1);
1853 spec_size (gfc_array_spec *as, mpz_t *result)
1858 mpz_init_set_ui (*result, 1);
1860 for (d = 0; d < as->rank; d++)
1862 if (spec_dimen_size (as, d, &size) == FAILURE)
1864 mpz_clear (*result);
1868 mpz_mul (*result, *result, size);
1876 /* Get the number of elements in an array section. */
1879 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1881 mpz_t upper, lower, stride;
1884 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1885 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1887 switch (ar->dimen_type[dimen])
1891 mpz_set_ui (*result, 1);
1896 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1905 if (ar->start[dimen] == NULL)
1907 if (ar->as->lower[dimen] == NULL
1908 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1910 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1914 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1916 mpz_set (lower, ar->start[dimen]->value.integer);
1919 if (ar->end[dimen] == NULL)
1921 if (ar->as->upper[dimen] == NULL
1922 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1924 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1928 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1930 mpz_set (upper, ar->end[dimen]->value.integer);
1933 if (ar->stride[dimen] == NULL)
1934 mpz_set_ui (stride, 1);
1937 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1939 mpz_set (stride, ar->stride[dimen]->value.integer);
1943 mpz_sub (*result, upper, lower);
1944 mpz_add (*result, *result, stride);
1945 mpz_div (*result, *result, stride);
1947 /* Zero stride caught earlier. */
1948 if (mpz_cmp_ui (*result, 0) < 0)
1949 mpz_set_ui (*result, 0);
1959 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
1967 ref_size (gfc_array_ref *ar, mpz_t *result)
1972 mpz_init_set_ui (*result, 1);
1974 for (d = 0; d < ar->dimen; d++)
1976 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
1978 mpz_clear (*result);
1982 mpz_mul (*result, *result, size);
1990 /* Given an array expression and a dimension, figure out how many
1991 elements it has along that dimension. Returns SUCCESS if we were
1992 able to return a result in the 'result' variable, FAILURE
1996 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2001 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2002 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2004 switch (array->expr_type)
2008 for (ref = array->ref; ref; ref = ref->next)
2010 if (ref->type != REF_ARRAY)
2013 if (ref->u.ar.type == AR_FULL)
2014 return spec_dimen_size (ref->u.ar.as, dimen, result);
2016 if (ref->u.ar.type == AR_SECTION)
2018 for (i = 0; dimen >= 0; i++)
2019 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2022 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2026 if (array->shape && array->shape[dimen])
2028 mpz_init_set (*result, array->shape[dimen]);
2032 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
2038 if (array->shape == NULL) {
2039 /* Expressions with rank > 1 should have "shape" properly set */
2040 if ( array->rank != 1 )
2041 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2042 return gfc_array_size(array, result);
2047 if (array->shape == NULL)
2050 mpz_init_set (*result, array->shape[dimen]);
2059 /* Given an array expression, figure out how many elements are in the
2060 array. Returns SUCCESS if this is possible, and sets the 'result'
2061 variable. Otherwise returns FAILURE. */
2064 gfc_array_size (gfc_expr *array, mpz_t *result)
2066 expand_info expand_save;
2071 switch (array->expr_type)
2074 gfc_push_suppress_errors ();
2076 expand_save = current_expand;
2078 current_expand.count = result;
2079 mpz_init_set_ui (*result, 0);
2081 current_expand.expand_work_function = count_elements;
2084 t = expand_constructor (array->value.constructor);
2086 gfc_pop_suppress_errors ();
2089 mpz_clear (*result);
2090 current_expand = expand_save;
2094 for (ref = array->ref; ref; ref = ref->next)
2096 if (ref->type != REF_ARRAY)
2099 if (ref->u.ar.type == AR_FULL)
2100 return spec_size (ref->u.ar.as, result);
2102 if (ref->u.ar.type == AR_SECTION)
2103 return ref_size (&ref->u.ar, result);
2106 return spec_size (array->symtree->n.sym->as, result);
2110 if (array->rank == 0 || array->shape == NULL)
2113 mpz_init_set_ui (*result, 1);
2115 for (i = 0; i < array->rank; i++)
2116 mpz_mul (*result, *result, array->shape[i]);
2125 /* Given an array reference, return the shape of the reference in an
2126 array of mpz_t integers. */
2129 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2139 for (; d < ar->as->rank; d++)
2140 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2146 for (i = 0; i < ar->dimen; i++)
2148 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2150 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2163 for (d--; d >= 0; d--)
2164 mpz_clear (shape[d]);
2170 /* Given an array expression, find the array reference structure that
2171 characterizes the reference. */
2174 gfc_find_array_ref (gfc_expr *e)
2178 for (ref = e->ref; ref; ref = ref->next)
2179 if (ref->type == REF_ARRAY
2180 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2184 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2190 /* Find out if an array shape is known at compile time. */
2193 gfc_is_compile_time_shape (gfc_array_spec *as)
2197 if (as->type != AS_EXPLICIT)
2200 for (i = 0; i < as->rank; i++)
2201 if (!gfc_is_constant_expr (as->lower[i])
2202 || !gfc_is_constant_expr (as->upper[i]))