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
1526 && !e->value.constructor->iterator)
1528 /* Expand the constructor. */
1530 expand_save = current_expand;
1531 current_expand.expand_work_function = is_constant_element;
1533 rc = expand_constructor (e->value.constructor);
1535 current_expand = expand_save;
1539 /* No need to expand this further. */
1540 for (con = e->value.constructor; con; con = con->next)
1542 if (con->expr->expr_type == EXPR_CONSTANT)
1546 if (!gfc_is_constant_expr (con->expr))
1559 /* Returns nonzero if an array constructor has been completely
1560 expanded (no iterators) and zero if iterators are present. */
1563 gfc_expanded_ac (gfc_expr *e)
1567 if (e->expr_type == EXPR_ARRAY)
1568 for (p = e->value.constructor; p; p = p->next)
1569 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1576 /*************** Type resolution of array constructors ***************/
1578 /* Recursive array list resolution function. All of the elements must
1579 be of the same type. */
1582 resolve_array_list (gfc_constructor *p)
1588 for (; p; p = p->next)
1590 if (p->iterator != NULL
1591 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1594 if (gfc_resolve_expr (p->expr) == FAILURE)
1601 /* Resolve character array constructor. If it has a specified constant character
1602 length, pad/truncate the elements here; if the length is not specified and
1603 all elements are of compile-time known length, emit an error as this is
1607 gfc_resolve_character_array_constructor (gfc_expr *expr)
1612 gcc_assert (expr->expr_type == EXPR_ARRAY);
1613 gcc_assert (expr->ts.type == BT_CHARACTER);
1615 if (expr->ts.u.cl == NULL)
1617 for (p = expr->value.constructor; p; p = p->next)
1618 if (p->expr->ts.u.cl != NULL)
1620 /* Ensure that if there is a char_len around that it is
1621 used; otherwise the middle-end confuses them! */
1622 expr->ts.u.cl = p->expr->ts.u.cl;
1626 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1633 if (expr->ts.u.cl->length == NULL)
1635 /* Check that all constant string elements have the same length until
1636 we reach the end or find a variable-length one. */
1638 for (p = expr->value.constructor; p; p = p->next)
1640 int current_length = -1;
1642 for (ref = p->expr->ref; ref; ref = ref->next)
1643 if (ref->type == REF_SUBSTRING
1644 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1645 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1648 if (p->expr->expr_type == EXPR_CONSTANT)
1649 current_length = p->expr->value.character.length;
1653 j = mpz_get_ui (ref->u.ss.end->value.integer)
1654 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1655 current_length = (int) j;
1657 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1658 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1661 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1662 current_length = (int) j;
1667 gcc_assert (current_length != -1);
1669 if (found_length == -1)
1670 found_length = current_length;
1671 else if (found_length != current_length)
1673 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1674 " constructor at %L", found_length, current_length,
1679 gcc_assert (found_length == current_length);
1682 gcc_assert (found_length != -1);
1684 /* Update the character length of the array constructor. */
1685 expr->ts.u.cl->length = gfc_int_expr (found_length);
1689 /* We've got a character length specified. It should be an integer,
1690 otherwise an error is signalled elsewhere. */
1691 gcc_assert (expr->ts.u.cl->length);
1693 /* If we've got a constant character length, pad according to this.
1694 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1695 max_length only if they pass. */
1696 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1698 /* Now pad/truncate the elements accordingly to the specified character
1699 length. This is ok inside this conditional, as in the case above
1700 (without typespec) all elements are verified to have the same length
1702 if (found_length != -1)
1703 for (p = expr->value.constructor; p; p = p->next)
1704 if (p->expr->expr_type == EXPR_CONSTANT)
1706 gfc_expr *cl = NULL;
1707 int current_length = -1;
1710 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1712 cl = p->expr->ts.u.cl->length;
1713 gfc_extract_int (cl, ¤t_length);
1716 /* If gfc_extract_int above set current_length, we implicitly
1717 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1719 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1722 || (current_length != -1 && current_length < found_length))
1723 gfc_set_constant_character_len (found_length, p->expr,
1724 has_ts ? -1 : found_length);
1732 /* Resolve all of the expressions in an array list. */
1735 gfc_resolve_array_constructor (gfc_expr *expr)
1739 t = resolve_array_list (expr->value.constructor);
1741 t = gfc_check_constructor_type (expr);
1743 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1744 the call to this function, so we don't need to call it here; if it was
1745 called twice, an error message there would be duplicated. */
1751 /* Copy an iterator structure. */
1753 static gfc_iterator *
1754 copy_iterator (gfc_iterator *src)
1761 dest = gfc_get_iterator ();
1763 dest->var = gfc_copy_expr (src->var);
1764 dest->start = gfc_copy_expr (src->start);
1765 dest->end = gfc_copy_expr (src->end);
1766 dest->step = gfc_copy_expr (src->step);
1772 /* Copy a constructor structure. */
1775 gfc_copy_constructor (gfc_constructor *src)
1777 gfc_constructor *dest;
1778 gfc_constructor *tail;
1787 dest = tail = gfc_get_constructor ();
1790 tail->next = gfc_get_constructor ();
1793 tail->where = src->where;
1794 tail->expr = gfc_copy_expr (src->expr);
1795 tail->iterator = copy_iterator (src->iterator);
1796 mpz_set (tail->n.offset, src->n.offset);
1797 tail->n.component = src->n.component;
1798 mpz_set (tail->repeat, src->repeat);
1806 /* Given an array expression and an element number (starting at zero),
1807 return a pointer to the array element. NULL is returned if the
1808 size of the array has been exceeded. The expression node returned
1809 remains a part of the array and should not be freed. Access is not
1810 efficient at all, but this is another place where things do not
1811 have to be particularly fast. */
1814 gfc_get_array_element (gfc_expr *array, int element)
1816 expand_info expand_save;
1820 expand_save = current_expand;
1821 current_expand.extract_n = element;
1822 current_expand.expand_work_function = extract_element;
1823 current_expand.extracted = NULL;
1824 current_expand.extract_count = 0;
1828 rc = expand_constructor (array->value.constructor);
1829 e = current_expand.extracted;
1830 current_expand = expand_save;
1839 /********* Subroutines for determining the size of an array *********/
1841 /* These are needed just to accommodate RESHAPE(). There are no
1842 diagnostics here, we just return a negative number if something
1846 /* Get the size of single dimension of an array specification. The
1847 array is guaranteed to be one dimensional. */
1850 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1855 if (dimen < 0 || dimen > as->rank - 1)
1856 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1858 if (as->type != AS_EXPLICIT
1859 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1860 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1861 || as->lower[dimen]->ts.type != BT_INTEGER
1862 || as->upper[dimen]->ts.type != BT_INTEGER)
1867 mpz_sub (*result, as->upper[dimen]->value.integer,
1868 as->lower[dimen]->value.integer);
1870 mpz_add_ui (*result, *result, 1);
1877 spec_size (gfc_array_spec *as, mpz_t *result)
1882 mpz_init_set_ui (*result, 1);
1884 for (d = 0; d < as->rank; d++)
1886 if (spec_dimen_size (as, d, &size) == FAILURE)
1888 mpz_clear (*result);
1892 mpz_mul (*result, *result, size);
1900 /* Get the number of elements in an array section. */
1903 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1905 mpz_t upper, lower, stride;
1908 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1909 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1911 switch (ar->dimen_type[dimen])
1915 mpz_set_ui (*result, 1);
1920 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1929 if (ar->start[dimen] == NULL)
1931 if (ar->as->lower[dimen] == NULL
1932 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1934 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1938 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1940 mpz_set (lower, ar->start[dimen]->value.integer);
1943 if (ar->end[dimen] == NULL)
1945 if (ar->as->upper[dimen] == NULL
1946 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1948 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1952 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1954 mpz_set (upper, ar->end[dimen]->value.integer);
1957 if (ar->stride[dimen] == NULL)
1958 mpz_set_ui (stride, 1);
1961 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1963 mpz_set (stride, ar->stride[dimen]->value.integer);
1967 mpz_sub (*result, upper, lower);
1968 mpz_add (*result, *result, stride);
1969 mpz_div (*result, *result, stride);
1971 /* Zero stride caught earlier. */
1972 if (mpz_cmp_ui (*result, 0) < 0)
1973 mpz_set_ui (*result, 0);
1983 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
1991 ref_size (gfc_array_ref *ar, mpz_t *result)
1996 mpz_init_set_ui (*result, 1);
1998 for (d = 0; d < ar->dimen; d++)
2000 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2002 mpz_clear (*result);
2006 mpz_mul (*result, *result, size);
2014 /* Given an array expression and a dimension, figure out how many
2015 elements it has along that dimension. Returns SUCCESS if we were
2016 able to return a result in the 'result' variable, FAILURE
2020 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2025 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2026 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2028 switch (array->expr_type)
2032 for (ref = array->ref; ref; ref = ref->next)
2034 if (ref->type != REF_ARRAY)
2037 if (ref->u.ar.type == AR_FULL)
2038 return spec_dimen_size (ref->u.ar.as, dimen, result);
2040 if (ref->u.ar.type == AR_SECTION)
2042 for (i = 0; dimen >= 0; i++)
2043 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2046 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2050 if (array->shape && array->shape[dimen])
2052 mpz_init_set (*result, array->shape[dimen]);
2056 if (array->symtree->n.sym->attr.generic
2057 && array->value.function.esym != NULL)
2059 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2063 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2070 if (array->shape == NULL) {
2071 /* Expressions with rank > 1 should have "shape" properly set */
2072 if ( array->rank != 1 )
2073 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2074 return gfc_array_size(array, result);
2079 if (array->shape == NULL)
2082 mpz_init_set (*result, array->shape[dimen]);
2091 /* Given an array expression, figure out how many elements are in the
2092 array. Returns SUCCESS if this is possible, and sets the 'result'
2093 variable. Otherwise returns FAILURE. */
2096 gfc_array_size (gfc_expr *array, mpz_t *result)
2098 expand_info expand_save;
2103 switch (array->expr_type)
2106 gfc_push_suppress_errors ();
2108 expand_save = current_expand;
2110 current_expand.count = result;
2111 mpz_init_set_ui (*result, 0);
2113 current_expand.expand_work_function = count_elements;
2116 t = expand_constructor (array->value.constructor);
2118 gfc_pop_suppress_errors ();
2121 mpz_clear (*result);
2122 current_expand = expand_save;
2126 for (ref = array->ref; ref; ref = ref->next)
2128 if (ref->type != REF_ARRAY)
2131 if (ref->u.ar.type == AR_FULL)
2132 return spec_size (ref->u.ar.as, result);
2134 if (ref->u.ar.type == AR_SECTION)
2135 return ref_size (&ref->u.ar, result);
2138 return spec_size (array->symtree->n.sym->as, result);
2142 if (array->rank == 0 || array->shape == NULL)
2145 mpz_init_set_ui (*result, 1);
2147 for (i = 0; i < array->rank; i++)
2148 mpz_mul (*result, *result, array->shape[i]);
2157 /* Given an array reference, return the shape of the reference in an
2158 array of mpz_t integers. */
2161 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2171 for (; d < ar->as->rank; d++)
2172 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2178 for (i = 0; i < ar->dimen; i++)
2180 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2182 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2195 for (d--; d >= 0; d--)
2196 mpz_clear (shape[d]);
2202 /* Given an array expression, find the array reference structure that
2203 characterizes the reference. */
2206 gfc_find_array_ref (gfc_expr *e)
2210 for (ref = e->ref; ref; ref = ref->next)
2211 if (ref->type == REF_ARRAY
2212 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2216 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2222 /* Find out if an array shape is known at compile time. */
2225 gfc_is_compile_time_shape (gfc_array_spec *as)
2229 if (as->type != AS_EXPLICIT)
2232 for (i = 0; i < as->rank; i++)
2233 if (!gfc_is_constant_expr (as->lower[i])
2234 || !gfc_is_constant_expr (as->upper[i]))