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.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.cl == NULL)
1593 for (p = expr->value.constructor; p; p = p->next)
1594 if (p->expr->ts.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.cl = p->expr->ts.cl;
1602 expr->ts.cl = gfc_get_charlen ();
1603 expr->ts.cl->next = gfc_current_ns->cl_list;
1604 gfc_current_ns->cl_list = expr->ts.cl;
1611 if (expr->ts.cl->length == NULL)
1613 /* Check that all constant string elements have the same length until
1614 we reach the end or find a variable-length one. */
1616 for (p = expr->value.constructor; p; p = p->next)
1618 int current_length = -1;
1620 for (ref = p->expr->ref; ref; ref = ref->next)
1621 if (ref->type == REF_SUBSTRING
1622 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1623 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1626 if (p->expr->expr_type == EXPR_CONSTANT)
1627 current_length = p->expr->value.character.length;
1631 j = mpz_get_ui (ref->u.ss.end->value.integer)
1632 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1633 current_length = (int) j;
1635 else if (p->expr->ts.cl && p->expr->ts.cl->length
1636 && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1639 j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1640 current_length = (int) j;
1645 gcc_assert (current_length != -1);
1647 if (found_length == -1)
1648 found_length = current_length;
1649 else if (found_length != current_length)
1651 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1652 " constructor at %L", found_length, current_length,
1657 gcc_assert (found_length == current_length);
1660 gcc_assert (found_length != -1);
1662 /* Update the character length of the array constructor. */
1663 expr->ts.cl->length = gfc_int_expr (found_length);
1667 /* We've got a character length specified. It should be an integer,
1668 otherwise an error is signalled elsewhere. */
1669 gcc_assert (expr->ts.cl->length);
1671 /* If we've got a constant character length, pad according to this.
1672 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1673 max_length only if they pass. */
1674 gfc_extract_int (expr->ts.cl->length, &found_length);
1676 /* Now pad/truncate the elements accordingly to the specified character
1677 length. This is ok inside this conditional, as in the case above
1678 (without typespec) all elements are verified to have the same length
1680 if (found_length != -1)
1681 for (p = expr->value.constructor; p; p = p->next)
1682 if (p->expr->expr_type == EXPR_CONSTANT)
1684 gfc_expr *cl = NULL;
1685 int current_length = -1;
1688 if (p->expr->ts.cl && p->expr->ts.cl->length)
1690 cl = p->expr->ts.cl->length;
1691 gfc_extract_int (cl, ¤t_length);
1694 /* If gfc_extract_int above set current_length, we implicitly
1695 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1697 has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
1700 || (current_length != -1 && current_length < found_length))
1701 gfc_set_constant_character_len (found_length, p->expr,
1702 has_ts ? -1 : found_length);
1710 /* Resolve all of the expressions in an array list. */
1713 gfc_resolve_array_constructor (gfc_expr *expr)
1717 t = resolve_array_list (expr->value.constructor);
1719 t = gfc_check_constructor_type (expr);
1721 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1722 the call to this function, so we don't need to call it here; if it was
1723 called twice, an error message there would be duplicated. */
1729 /* Copy an iterator structure. */
1731 static gfc_iterator *
1732 copy_iterator (gfc_iterator *src)
1739 dest = gfc_get_iterator ();
1741 dest->var = gfc_copy_expr (src->var);
1742 dest->start = gfc_copy_expr (src->start);
1743 dest->end = gfc_copy_expr (src->end);
1744 dest->step = gfc_copy_expr (src->step);
1750 /* Copy a constructor structure. */
1753 gfc_copy_constructor (gfc_constructor *src)
1755 gfc_constructor *dest;
1756 gfc_constructor *tail;
1765 dest = tail = gfc_get_constructor ();
1768 tail->next = gfc_get_constructor ();
1771 tail->where = src->where;
1772 tail->expr = gfc_copy_expr (src->expr);
1773 tail->iterator = copy_iterator (src->iterator);
1774 mpz_set (tail->n.offset, src->n.offset);
1775 tail->n.component = src->n.component;
1776 mpz_set (tail->repeat, src->repeat);
1784 /* Given an array expression and an element number (starting at zero),
1785 return a pointer to the array element. NULL is returned if the
1786 size of the array has been exceeded. The expression node returned
1787 remains a part of the array and should not be freed. Access is not
1788 efficient at all, but this is another place where things do not
1789 have to be particularly fast. */
1792 gfc_get_array_element (gfc_expr *array, int element)
1794 expand_info expand_save;
1798 expand_save = current_expand;
1799 current_expand.extract_n = element;
1800 current_expand.expand_work_function = extract_element;
1801 current_expand.extracted = NULL;
1802 current_expand.extract_count = 0;
1806 rc = expand_constructor (array->value.constructor);
1807 e = current_expand.extracted;
1808 current_expand = expand_save;
1817 /********* Subroutines for determining the size of an array *********/
1819 /* These are needed just to accommodate RESHAPE(). There are no
1820 diagnostics here, we just return a negative number if something
1824 /* Get the size of single dimension of an array specification. The
1825 array is guaranteed to be one dimensional. */
1828 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1833 if (dimen < 0 || dimen > as->rank - 1)
1834 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1836 if (as->type != AS_EXPLICIT
1837 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1838 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1839 || as->lower[dimen]->ts.type != BT_INTEGER
1840 || as->upper[dimen]->ts.type != BT_INTEGER)
1845 mpz_sub (*result, as->upper[dimen]->value.integer,
1846 as->lower[dimen]->value.integer);
1848 mpz_add_ui (*result, *result, 1);
1855 spec_size (gfc_array_spec *as, mpz_t *result)
1860 mpz_init_set_ui (*result, 1);
1862 for (d = 0; d < as->rank; d++)
1864 if (spec_dimen_size (as, d, &size) == FAILURE)
1866 mpz_clear (*result);
1870 mpz_mul (*result, *result, size);
1878 /* Get the number of elements in an array section. */
1881 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1883 mpz_t upper, lower, stride;
1886 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1887 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1889 switch (ar->dimen_type[dimen])
1893 mpz_set_ui (*result, 1);
1898 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1907 if (ar->start[dimen] == NULL)
1909 if (ar->as->lower[dimen] == NULL
1910 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1912 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1916 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1918 mpz_set (lower, ar->start[dimen]->value.integer);
1921 if (ar->end[dimen] == NULL)
1923 if (ar->as->upper[dimen] == NULL
1924 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1926 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1930 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1932 mpz_set (upper, ar->end[dimen]->value.integer);
1935 if (ar->stride[dimen] == NULL)
1936 mpz_set_ui (stride, 1);
1939 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1941 mpz_set (stride, ar->stride[dimen]->value.integer);
1945 mpz_sub (*result, upper, lower);
1946 mpz_add (*result, *result, stride);
1947 mpz_div (*result, *result, stride);
1949 /* Zero stride caught earlier. */
1950 if (mpz_cmp_ui (*result, 0) < 0)
1951 mpz_set_ui (*result, 0);
1961 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
1969 ref_size (gfc_array_ref *ar, mpz_t *result)
1974 mpz_init_set_ui (*result, 1);
1976 for (d = 0; d < ar->dimen; d++)
1978 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
1980 mpz_clear (*result);
1984 mpz_mul (*result, *result, size);
1992 /* Given an array expression and a dimension, figure out how many
1993 elements it has along that dimension. Returns SUCCESS if we were
1994 able to return a result in the 'result' variable, FAILURE
1998 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2003 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2004 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2006 switch (array->expr_type)
2010 for (ref = array->ref; ref; ref = ref->next)
2012 if (ref->type != REF_ARRAY)
2015 if (ref->u.ar.type == AR_FULL)
2016 return spec_dimen_size (ref->u.ar.as, dimen, result);
2018 if (ref->u.ar.type == AR_SECTION)
2020 for (i = 0; dimen >= 0; i++)
2021 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2024 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2028 if (array->shape && array->shape[dimen])
2030 mpz_init_set (*result, array->shape[dimen]);
2034 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
2040 if (array->shape == NULL) {
2041 /* Expressions with rank > 1 should have "shape" properly set */
2042 if ( array->rank != 1 )
2043 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2044 return gfc_array_size(array, result);
2049 if (array->shape == NULL)
2052 mpz_init_set (*result, array->shape[dimen]);
2061 /* Given an array expression, figure out how many elements are in the
2062 array. Returns SUCCESS if this is possible, and sets the 'result'
2063 variable. Otherwise returns FAILURE. */
2066 gfc_array_size (gfc_expr *array, mpz_t *result)
2068 expand_info expand_save;
2073 switch (array->expr_type)
2076 gfc_push_suppress_errors ();
2078 expand_save = current_expand;
2080 current_expand.count = result;
2081 mpz_init_set_ui (*result, 0);
2083 current_expand.expand_work_function = count_elements;
2086 t = expand_constructor (array->value.constructor);
2088 gfc_pop_suppress_errors ();
2091 mpz_clear (*result);
2092 current_expand = expand_save;
2096 for (ref = array->ref; ref; ref = ref->next)
2098 if (ref->type != REF_ARRAY)
2101 if (ref->u.ar.type == AR_FULL)
2102 return spec_size (ref->u.ar.as, result);
2104 if (ref->u.ar.type == AR_SECTION)
2105 return ref_size (&ref->u.ar, result);
2108 return spec_size (array->symtree->n.sym->as, result);
2112 if (array->rank == 0 || array->shape == NULL)
2115 mpz_init_set_ui (*result, 1);
2117 for (i = 0; i < array->rank; i++)
2118 mpz_mul (*result, *result, array->shape[i]);
2127 /* Given an array reference, return the shape of the reference in an
2128 array of mpz_t integers. */
2131 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2141 for (; d < ar->as->rank; d++)
2142 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2148 for (i = 0; i < ar->dimen; i++)
2150 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2152 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2165 for (d--; d >= 0; d--)
2166 mpz_clear (shape[d]);
2172 /* Given an array expression, find the array reference structure that
2173 characterizes the reference. */
2176 gfc_find_array_ref (gfc_expr *e)
2180 for (ref = e->ref; ref; ref = ref->next)
2181 if (ref->type == REF_ARRAY
2182 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2186 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2192 /* Find out if an array shape is known at compile time. */
2195 gfc_is_compile_time_shape (gfc_array_spec *as)
2199 if (as->type != AS_EXPLICIT)
2202 for (i = 0; i < as->rank; i++)
2203 if (!gfc_is_constant_expr (as->lower[i])
2204 || !gfc_is_constant_expr (as->upper[i]))