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; 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_decl_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)
1241 { /* Something unextractable */
1246 if (current_expand.extract_count == current_expand.extract_n)
1247 current_expand.extracted = e;
1251 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 is_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;
1520 gfc_constructor * con;
1524 if (e->value.constructor
1525 && e->value.constructor->expr->expr_type == EXPR_ARRAY)
1527 /* Expand the constructor. */
1529 expand_save = current_expand;
1530 current_expand.expand_work_function = is_constant_element;
1532 rc = expand_constructor (e->value.constructor);
1534 current_expand = expand_save;
1538 /* No need to expand this further. */
1539 for (con = e->value.constructor; con; con = con->next)
1541 if (con->expr->expr_type == EXPR_CONSTANT)
1545 if (!gfc_is_constant_expr (con->expr))
1558 /* Returns nonzero if an array constructor has been completely
1559 expanded (no iterators) and zero if iterators are present. */
1562 gfc_expanded_ac (gfc_expr *e)
1566 if (e->expr_type == EXPR_ARRAY)
1567 for (p = e->value.constructor; p; p = p->next)
1568 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1575 /*************** Type resolution of array constructors ***************/
1577 /* Recursive array list resolution function. All of the elements must
1578 be of the same type. */
1581 resolve_array_list (gfc_constructor *p)
1587 for (; p; p = p->next)
1589 if (p->iterator != NULL
1590 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1593 if (gfc_resolve_expr (p->expr) == FAILURE)
1600 /* Resolve character array constructor. If it has a specified constant character
1601 length, pad/truncate the elements here; if the length is not specified and
1602 all elements are of compile-time known length, emit an error as this is
1606 gfc_resolve_character_array_constructor (gfc_expr *expr)
1611 gcc_assert (expr->expr_type == EXPR_ARRAY);
1612 gcc_assert (expr->ts.type == BT_CHARACTER);
1614 if (expr->ts.u.cl == NULL)
1616 for (p = expr->value.constructor; p; p = p->next)
1617 if (p->expr->ts.u.cl != NULL)
1619 /* Ensure that if there is a char_len around that it is
1620 used; otherwise the middle-end confuses them! */
1621 expr->ts.u.cl = p->expr->ts.u.cl;
1625 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1632 if (expr->ts.u.cl->length == NULL)
1634 /* Check that all constant string elements have the same length until
1635 we reach the end or find a variable-length one. */
1637 for (p = expr->value.constructor; p; p = p->next)
1639 int current_length = -1;
1641 for (ref = p->expr->ref; ref; ref = ref->next)
1642 if (ref->type == REF_SUBSTRING
1643 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1644 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1647 if (p->expr->expr_type == EXPR_CONSTANT)
1648 current_length = p->expr->value.character.length;
1652 j = mpz_get_ui (ref->u.ss.end->value.integer)
1653 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1654 current_length = (int) j;
1656 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1657 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1660 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1661 current_length = (int) j;
1666 gcc_assert (current_length != -1);
1668 if (found_length == -1)
1669 found_length = current_length;
1670 else if (found_length != current_length)
1672 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1673 " constructor at %L", found_length, current_length,
1678 gcc_assert (found_length == current_length);
1681 gcc_assert (found_length != -1);
1683 /* Update the character length of the array constructor. */
1684 expr->ts.u.cl->length = gfc_int_expr (found_length);
1688 /* We've got a character length specified. It should be an integer,
1689 otherwise an error is signalled elsewhere. */
1690 gcc_assert (expr->ts.u.cl->length);
1692 /* If we've got a constant character length, pad according to this.
1693 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1694 max_length only if they pass. */
1695 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1697 /* Now pad/truncate the elements accordingly to the specified character
1698 length. This is ok inside this conditional, as in the case above
1699 (without typespec) all elements are verified to have the same length
1701 if (found_length != -1)
1702 for (p = expr->value.constructor; p; p = p->next)
1703 if (p->expr->expr_type == EXPR_CONSTANT)
1705 gfc_expr *cl = NULL;
1706 int current_length = -1;
1709 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1711 cl = p->expr->ts.u.cl->length;
1712 gfc_extract_int (cl, ¤t_length);
1715 /* If gfc_extract_int above set current_length, we implicitly
1716 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1718 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1721 || (current_length != -1 && current_length < found_length))
1722 gfc_set_constant_character_len (found_length, p->expr,
1723 has_ts ? -1 : found_length);
1731 /* Resolve all of the expressions in an array list. */
1734 gfc_resolve_array_constructor (gfc_expr *expr)
1738 t = resolve_array_list (expr->value.constructor);
1740 t = gfc_check_constructor_type (expr);
1742 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1743 the call to this function, so we don't need to call it here; if it was
1744 called twice, an error message there would be duplicated. */
1750 /* Copy an iterator structure. */
1752 static gfc_iterator *
1753 copy_iterator (gfc_iterator *src)
1760 dest = gfc_get_iterator ();
1762 dest->var = gfc_copy_expr (src->var);
1763 dest->start = gfc_copy_expr (src->start);
1764 dest->end = gfc_copy_expr (src->end);
1765 dest->step = gfc_copy_expr (src->step);
1771 /* Copy a constructor structure. */
1774 gfc_copy_constructor (gfc_constructor *src)
1776 gfc_constructor *dest;
1777 gfc_constructor *tail;
1786 dest = tail = gfc_get_constructor ();
1789 tail->next = gfc_get_constructor ();
1792 tail->where = src->where;
1793 tail->expr = gfc_copy_expr (src->expr);
1794 tail->iterator = copy_iterator (src->iterator);
1795 mpz_set (tail->n.offset, src->n.offset);
1796 tail->n.component = src->n.component;
1797 mpz_set (tail->repeat, src->repeat);
1805 /* Given an array expression and an element number (starting at zero),
1806 return a pointer to the array element. NULL is returned if the
1807 size of the array has been exceeded. The expression node returned
1808 remains a part of the array and should not be freed. Access is not
1809 efficient at all, but this is another place where things do not
1810 have to be particularly fast. */
1813 gfc_get_array_element (gfc_expr *array, int element)
1815 expand_info expand_save;
1819 expand_save = current_expand;
1820 current_expand.extract_n = element;
1821 current_expand.expand_work_function = extract_element;
1822 current_expand.extracted = NULL;
1823 current_expand.extract_count = 0;
1827 rc = expand_constructor (array->value.constructor);
1828 e = current_expand.extracted;
1829 current_expand = expand_save;
1838 /********* Subroutines for determining the size of an array *********/
1840 /* These are needed just to accommodate RESHAPE(). There are no
1841 diagnostics here, we just return a negative number if something
1845 /* Get the size of single dimension of an array specification. The
1846 array is guaranteed to be one dimensional. */
1849 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1854 if (dimen < 0 || dimen > as->rank - 1)
1855 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1857 if (as->type != AS_EXPLICIT
1858 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1859 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1860 || as->lower[dimen]->ts.type != BT_INTEGER
1861 || as->upper[dimen]->ts.type != BT_INTEGER)
1866 mpz_sub (*result, as->upper[dimen]->value.integer,
1867 as->lower[dimen]->value.integer);
1869 mpz_add_ui (*result, *result, 1);
1876 spec_size (gfc_array_spec *as, mpz_t *result)
1881 mpz_init_set_ui (*result, 1);
1883 for (d = 0; d < as->rank; d++)
1885 if (spec_dimen_size (as, d, &size) == FAILURE)
1887 mpz_clear (*result);
1891 mpz_mul (*result, *result, size);
1899 /* Get the number of elements in an array section. */
1902 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1904 mpz_t upper, lower, stride;
1907 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1908 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1910 switch (ar->dimen_type[dimen])
1914 mpz_set_ui (*result, 1);
1919 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1928 if (ar->start[dimen] == NULL)
1930 if (ar->as->lower[dimen] == NULL
1931 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1933 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1937 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1939 mpz_set (lower, ar->start[dimen]->value.integer);
1942 if (ar->end[dimen] == NULL)
1944 if (ar->as->upper[dimen] == NULL
1945 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1947 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1951 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1953 mpz_set (upper, ar->end[dimen]->value.integer);
1956 if (ar->stride[dimen] == NULL)
1957 mpz_set_ui (stride, 1);
1960 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1962 mpz_set (stride, ar->stride[dimen]->value.integer);
1966 mpz_sub (*result, upper, lower);
1967 mpz_add (*result, *result, stride);
1968 mpz_div (*result, *result, stride);
1970 /* Zero stride caught earlier. */
1971 if (mpz_cmp_ui (*result, 0) < 0)
1972 mpz_set_ui (*result, 0);
1982 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
1990 ref_size (gfc_array_ref *ar, mpz_t *result)
1995 mpz_init_set_ui (*result, 1);
1997 for (d = 0; d < ar->dimen; d++)
1999 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2001 mpz_clear (*result);
2005 mpz_mul (*result, *result, size);
2013 /* Given an array expression and a dimension, figure out how many
2014 elements it has along that dimension. Returns SUCCESS if we were
2015 able to return a result in the 'result' variable, FAILURE
2019 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2024 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2025 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2027 switch (array->expr_type)
2031 for (ref = array->ref; ref; ref = ref->next)
2033 if (ref->type != REF_ARRAY)
2036 if (ref->u.ar.type == AR_FULL)
2037 return spec_dimen_size (ref->u.ar.as, dimen, result);
2039 if (ref->u.ar.type == AR_SECTION)
2041 for (i = 0; dimen >= 0; i++)
2042 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2045 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2049 if (array->shape && array->shape[dimen])
2051 mpz_init_set (*result, array->shape[dimen]);
2055 if (array->symtree->n.sym->attr.generic
2056 && array->value.function.esym != NULL)
2058 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2062 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2069 if (array->shape == NULL) {
2070 /* Expressions with rank > 1 should have "shape" properly set */
2071 if ( array->rank != 1 )
2072 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2073 return gfc_array_size(array, result);
2078 if (array->shape == NULL)
2081 mpz_init_set (*result, array->shape[dimen]);
2090 /* Given an array expression, figure out how many elements are in the
2091 array. Returns SUCCESS if this is possible, and sets the 'result'
2092 variable. Otherwise returns FAILURE. */
2095 gfc_array_size (gfc_expr *array, mpz_t *result)
2097 expand_info expand_save;
2102 switch (array->expr_type)
2105 gfc_push_suppress_errors ();
2107 expand_save = current_expand;
2109 current_expand.count = result;
2110 mpz_init_set_ui (*result, 0);
2112 current_expand.expand_work_function = count_elements;
2115 t = expand_constructor (array->value.constructor);
2117 gfc_pop_suppress_errors ();
2120 mpz_clear (*result);
2121 current_expand = expand_save;
2125 for (ref = array->ref; ref; ref = ref->next)
2127 if (ref->type != REF_ARRAY)
2130 if (ref->u.ar.type == AR_FULL)
2131 return spec_size (ref->u.ar.as, result);
2133 if (ref->u.ar.type == AR_SECTION)
2134 return ref_size (&ref->u.ar, result);
2137 return spec_size (array->symtree->n.sym->as, result);
2141 if (array->rank == 0 || array->shape == NULL)
2144 mpz_init_set_ui (*result, 1);
2146 for (i = 0; i < array->rank; i++)
2147 mpz_mul (*result, *result, array->shape[i]);
2156 /* Given an array reference, return the shape of the reference in an
2157 array of mpz_t integers. */
2160 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2170 for (; d < ar->as->rank; d++)
2171 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2177 for (i = 0; i < ar->dimen; i++)
2179 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2181 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2194 for (d--; d >= 0; d--)
2195 mpz_clear (shape[d]);
2201 /* Given an array expression, find the array reference structure that
2202 characterizes the reference. */
2205 gfc_find_array_ref (gfc_expr *e)
2209 for (ref = e->ref; ref; ref = ref->next)
2210 if (ref->type == REF_ARRAY
2211 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2215 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2221 /* Find out if an array shape is known at compile time. */
2224 gfc_is_compile_time_shape (gfc_array_spec *as)
2228 if (as->type != AS_EXPLICIT)
2231 for (i = 0; i < as->rank; i++)
2232 if (!gfc_is_constant_expr (as->lower[i])
2233 || !gfc_is_constant_expr (as->upper[i]))