2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
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 /* This parameter is the size of the largest array constructor that we
28 will expand to an array constructor without iterators.
29 Constructors larger than this will remain in the iterator form. */
31 #define GFC_MAX_AC_EXPAND 65535
34 /**************** Array reference matching subroutines *****************/
36 /* Copy an array reference structure. */
39 gfc_copy_array_ref (gfc_array_ref *src)
47 dest = gfc_get_array_ref ();
51 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
53 dest->start[i] = gfc_copy_expr (src->start[i]);
54 dest->end[i] = gfc_copy_expr (src->end[i]);
55 dest->stride[i] = gfc_copy_expr (src->stride[i]);
58 dest->offset = gfc_copy_expr (src->offset);
64 /* Match a single dimension of an array reference. This can be a
65 single element or an array section. Any modifications we've made
66 to the ar structure are cleaned up by the caller. If the init
67 is set, we require the subscript to be a valid initialization
71 match_subscript (gfc_array_ref *ar, int init)
78 ar->c_where[i] = gfc_current_locus;
79 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
81 /* We can't be sure of the difference between DIMEN_ELEMENT and
82 DIMEN_VECTOR until we know the type of the element itself at
85 ar->dimen_type[i] = DIMEN_UNKNOWN;
87 if (gfc_match_char (':') == MATCH_YES)
90 /* Get start element. */
92 m = gfc_match_init_expr (&ar->start[i]);
94 m = gfc_match_expr (&ar->start[i]);
97 gfc_error ("Expected array subscript at %C");
101 if (gfc_match_char (':') == MATCH_NO)
104 /* Get an optional end element. Because we've seen the colon, we
105 definitely have a range along this dimension. */
107 ar->dimen_type[i] = DIMEN_RANGE;
110 m = gfc_match_init_expr (&ar->end[i]);
112 m = gfc_match_expr (&ar->end[i]);
114 if (m == MATCH_ERROR)
117 /* See if we have an optional stride. */
118 if (gfc_match_char (':') == MATCH_YES)
120 m = init ? gfc_match_init_expr (&ar->stride[i])
121 : gfc_match_expr (&ar->stride[i]);
124 gfc_error ("Expected array subscript stride at %C");
133 /* Match an array reference, whether it is the whole array or a
134 particular elements or a section. If init is set, the reference has
135 to consist of init expressions. */
138 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
142 memset (ar, '\0', sizeof (ar));
144 ar->where = gfc_current_locus;
147 if (gfc_match_char ('(') != MATCH_YES)
154 ar->type = AR_UNKNOWN;
156 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
158 m = match_subscript (ar, init);
159 if (m == MATCH_ERROR)
162 if (gfc_match_char (')') == MATCH_YES)
165 if (gfc_match_char (',') != MATCH_YES)
167 gfc_error ("Invalid form of array reference at %C");
172 gfc_error ("Array reference at %C cannot have more than %d dimensions",
185 /************** Array specification matching subroutines ***************/
187 /* Free all of the expressions associated with array bounds
191 gfc_free_array_spec (gfc_array_spec *as)
198 for (i = 0; i < as->rank; i++)
200 gfc_free_expr (as->lower[i]);
201 gfc_free_expr (as->upper[i]);
208 /* Take an array bound, resolves the expression, that make up the
209 shape and check associated constraints. */
212 resolve_array_bound (gfc_expr *e, int check_constant)
217 if (gfc_resolve_expr (e) == FAILURE
218 || gfc_specification_expr (e) == FAILURE)
221 if (check_constant && gfc_is_constant_expr (e) == 0)
223 gfc_error ("Variable '%s' at %L in this context must be constant",
224 e->symtree->n.sym->name, &e->where);
232 /* Takes an array specification, resolves the expressions that make up
233 the shape and make sure everything is integral. */
236 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
244 for (i = 0; i < as->rank; i++)
247 if (resolve_array_bound (e, check_constant) == FAILURE)
251 if (resolve_array_bound (e, check_constant) == FAILURE)
259 /* Match a single array element specification. The return values as
260 well as the upper and lower bounds of the array spec are filled
261 in according to what we see on the input. The caller makes sure
262 individual specifications make sense as a whole.
265 Parsed Lower Upper Returned
266 ------------------------------------
267 : NULL NULL AS_DEFERRED (*)
269 x: x NULL AS_ASSUMED_SHAPE
271 x:* x NULL AS_ASSUMED_SIZE
272 * 1 NULL AS_ASSUMED_SIZE
274 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
275 is fixed during the resolution of formal interfaces.
277 Anything else AS_UNKNOWN. */
280 match_array_element_spec (gfc_array_spec *as)
282 gfc_expr **upper, **lower;
285 lower = &as->lower[as->rank - 1];
286 upper = &as->upper[as->rank - 1];
288 if (gfc_match_char ('*') == MATCH_YES)
290 *lower = gfc_int_expr (1);
291 return AS_ASSUMED_SIZE;
294 if (gfc_match_char (':') == MATCH_YES)
297 m = gfc_match_expr (upper);
299 gfc_error ("Expected expression in array specification at %C");
303 if (gfc_match_char (':') == MATCH_NO)
305 *lower = gfc_int_expr (1);
312 if (gfc_match_char ('*') == MATCH_YES)
313 return AS_ASSUMED_SIZE;
315 m = gfc_match_expr (upper);
316 if (m == MATCH_ERROR)
319 return AS_ASSUMED_SHAPE;
321 /* If the size is negative in this dimension, set it to zero. */
322 if ((*lower)->expr_type == EXPR_CONSTANT
323 && (*upper)->expr_type == EXPR_CONSTANT
324 && mpz_cmp ((*upper)->value.integer, (*lower)->value.integer) < 0)
326 gfc_free_expr (*upper);
327 *upper = gfc_copy_expr (*lower);
328 mpz_sub_ui ((*upper)->value.integer, (*upper)->value.integer, 1);
334 /* Matches an array specification, incidentally figuring out what sort
338 gfc_match_array_spec (gfc_array_spec **asp)
340 array_type current_type;
344 if (gfc_match_char ('(') != MATCH_YES)
350 as = gfc_get_array_spec ();
352 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
362 current_type = match_array_element_spec (as);
366 if (current_type == AS_UNKNOWN)
368 as->type = current_type;
372 { /* See how current spec meshes with the existing. */
377 if (current_type == AS_ASSUMED_SIZE)
379 as->type = AS_ASSUMED_SIZE;
383 if (current_type == AS_EXPLICIT)
386 gfc_error ("Bad array specification for an explicitly shaped "
391 case AS_ASSUMED_SHAPE:
392 if ((current_type == AS_ASSUMED_SHAPE)
393 || (current_type == AS_DEFERRED))
396 gfc_error ("Bad array specification for assumed shape "
401 if (current_type == AS_DEFERRED)
404 if (current_type == AS_ASSUMED_SHAPE)
406 as->type = AS_ASSUMED_SHAPE;
410 gfc_error ("Bad specification for deferred shape array at %C");
413 case AS_ASSUMED_SIZE:
414 gfc_error ("Bad specification for assumed size array at %C");
418 if (gfc_match_char (')') == MATCH_YES)
421 if (gfc_match_char (',') != MATCH_YES)
423 gfc_error ("Expected another dimension in array declaration at %C");
427 if (as->rank >= GFC_MAX_DIMENSIONS)
429 gfc_error ("Array specification at %C has more than %d dimensions",
437 /* If a lower bounds of an assumed shape array is blank, put in one. */
438 if (as->type == AS_ASSUMED_SHAPE)
440 for (i = 0; i < as->rank; i++)
442 if (as->lower[i] == NULL)
443 as->lower[i] = gfc_int_expr (1);
450 /* Something went wrong. */
451 gfc_free_array_spec (as);
456 /* Given a symbol and an array specification, modify the symbol to
457 have that array specification. The error locus is needed in case
458 something goes wrong. On failure, the caller must free the spec. */
461 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
466 if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
475 /* Copy an array specification. */
478 gfc_copy_array_spec (gfc_array_spec *src)
480 gfc_array_spec *dest;
486 dest = gfc_get_array_spec ();
490 for (i = 0; i < dest->rank; i++)
492 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
493 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
500 /* Returns nonzero if the two expressions are equal. Only handles integer
504 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
506 if (bound1 == NULL || bound2 == NULL
507 || bound1->expr_type != EXPR_CONSTANT
508 || bound2->expr_type != EXPR_CONSTANT
509 || bound1->ts.type != BT_INTEGER
510 || bound2->ts.type != BT_INTEGER)
511 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
513 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
520 /* Compares two array specifications. They must be constant or deferred
524 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
528 if (as1 == NULL && as2 == NULL)
531 if (as1 == NULL || as2 == NULL)
534 if (as1->rank != as2->rank)
540 if (as1->type != as2->type)
543 if (as1->type == AS_EXPLICIT)
544 for (i = 0; i < as1->rank; i++)
546 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
549 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
557 /****************** Array constructor functions ******************/
559 /* Start an array constructor. The constructor starts with zero
560 elements and should be appended to by gfc_append_constructor(). */
563 gfc_start_constructor (bt type, int kind, locus *where)
567 result = gfc_get_expr ();
569 result->expr_type = EXPR_ARRAY;
572 result->ts.type = type;
573 result->ts.kind = kind;
574 result->where = *where;
579 /* Given an array constructor expression, append the new expression
580 node onto the constructor. */
583 gfc_append_constructor (gfc_expr *base, gfc_expr *new)
587 if (base->value.constructor == NULL)
588 base->value.constructor = c = gfc_get_constructor ();
591 c = base->value.constructor;
595 c->next = gfc_get_constructor ();
601 if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind)
602 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
606 /* Given an array constructor expression, insert the new expression's
607 constructor onto the base's one according to the offset. */
610 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
612 gfc_constructor *c, *pre;
616 type = base->expr_type;
618 if (base->value.constructor == NULL)
619 base->value.constructor = c1;
622 c = pre = base->value.constructor;
625 if (type == EXPR_ARRAY)
627 t = mpz_cmp (c->n.offset, c1->n.offset);
635 gfc_error ("duplicated initializer");
656 base->value.constructor = c1;
662 /* Get a new constructor. */
665 gfc_get_constructor (void)
669 c = gfc_getmem (sizeof(gfc_constructor));
673 mpz_init_set_si (c->n.offset, 0);
674 mpz_init_set_si (c->repeat, 0);
679 /* Free chains of gfc_constructor structures. */
682 gfc_free_constructor (gfc_constructor *p)
684 gfc_constructor *next;
694 gfc_free_expr (p->expr);
695 if (p->iterator != NULL)
696 gfc_free_iterator (p->iterator, 1);
697 mpz_clear (p->n.offset);
698 mpz_clear (p->repeat);
704 /* Given an expression node that might be an array constructor and a
705 symbol, make sure that no iterators in this or child constructors
706 use the symbol as an implied-DO iterator. Returns nonzero if a
707 duplicate was found. */
710 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
714 for (; c; c = c->next)
718 if (e->expr_type == EXPR_ARRAY
719 && check_duplicate_iterator (e->value.constructor, master))
722 if (c->iterator == NULL)
725 if (c->iterator->var->symtree->n.sym == master)
727 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
728 "same name", master->name, &c->where);
738 /* Forward declaration because these functions are mutually recursive. */
739 static match match_array_cons_element (gfc_constructor **);
741 /* Match a list of array elements. */
744 match_array_list (gfc_constructor **result)
746 gfc_constructor *p, *head, *tail, *new;
753 old_loc = gfc_current_locus;
755 if (gfc_match_char ('(') == MATCH_NO)
758 memset (&iter, '\0', sizeof (gfc_iterator));
761 m = match_array_cons_element (&head);
767 if (gfc_match_char (',') != MATCH_YES)
775 m = gfc_match_iterator (&iter, 0);
778 if (m == MATCH_ERROR)
781 m = match_array_cons_element (&new);
782 if (m == MATCH_ERROR)
789 goto cleanup; /* Could be a complex constant */
795 if (gfc_match_char (',') != MATCH_YES)
804 if (gfc_match_char (')') != MATCH_YES)
807 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
814 e->expr_type = EXPR_ARRAY;
816 e->value.constructor = head;
818 p = gfc_get_constructor ();
819 p->where = gfc_current_locus;
820 p->iterator = gfc_get_iterator ();
829 gfc_error ("Syntax error in array constructor at %C");
833 gfc_free_constructor (head);
834 gfc_free_iterator (&iter, 0);
835 gfc_current_locus = old_loc;
840 /* Match a single element of an array constructor, which can be a
841 single expression or a list of elements. */
844 match_array_cons_element (gfc_constructor **result)
850 m = match_array_list (result);
854 m = gfc_match_expr (&expr);
858 p = gfc_get_constructor ();
859 p->where = gfc_current_locus;
867 /* Match an array constructor. */
870 gfc_match_array_constructor (gfc_expr **result)
872 gfc_constructor *head, *tail, *new;
876 const char *end_delim;
878 if (gfc_match (" (/") == MATCH_NO)
880 if (gfc_match (" [") == MATCH_NO)
884 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
885 "style array constructors at %C") == FAILURE)
893 where = gfc_current_locus;
896 if (gfc_match (end_delim) == MATCH_YES)
898 gfc_error ("Empty array constructor at %C is not allowed");
904 m = match_array_cons_element (&new);
905 if (m == MATCH_ERROR)
917 if (gfc_match_char (',') == MATCH_NO)
921 if (gfc_match (end_delim) == MATCH_NO)
924 expr = gfc_get_expr ();
926 expr->expr_type = EXPR_ARRAY;
928 expr->value.constructor = head;
929 /* Size must be calculated at resolution time. */
938 gfc_error ("Syntax error in array constructor at %C");
941 gfc_free_constructor (head);
947 /************** Check array constructors for correctness **************/
949 /* Given an expression, compare it's type with the type of the current
950 constructor. Returns nonzero if an error was issued. The
951 cons_state variable keeps track of whether the type of the
952 constructor being read or resolved is known to be good, bad or just
955 static gfc_typespec constructor_ts;
957 { CONS_START, CONS_GOOD, CONS_BAD }
961 check_element_type (gfc_expr *expr)
963 if (cons_state == CONS_BAD)
964 return 0; /* Suppress further errors */
966 if (cons_state == CONS_START)
968 if (expr->ts.type == BT_UNKNOWN)
969 cons_state = CONS_BAD;
972 cons_state = CONS_GOOD;
973 constructor_ts = expr->ts;
979 if (gfc_compare_types (&constructor_ts, &expr->ts))
982 gfc_error ("Element in %s array constructor at %L is %s",
983 gfc_typename (&constructor_ts), &expr->where,
984 gfc_typename (&expr->ts));
986 cons_state = CONS_BAD;
991 /* Recursive work function for gfc_check_constructor_type(). */
994 check_constructor_type (gfc_constructor *c)
998 for (; c; c = c->next)
1002 if (e->expr_type == EXPR_ARRAY)
1004 if (check_constructor_type (e->value.constructor) == FAILURE)
1010 if (check_element_type (e))
1018 /* Check that all elements of an array constructor are the same type.
1019 On FAILURE, an error has been generated. */
1022 gfc_check_constructor_type (gfc_expr *e)
1026 cons_state = CONS_START;
1027 gfc_clear_ts (&constructor_ts);
1029 t = check_constructor_type (e->value.constructor);
1030 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1031 e->ts = constructor_ts;
1038 typedef struct cons_stack
1040 gfc_iterator *iterator;
1041 struct cons_stack *previous;
1045 static cons_stack *base;
1047 static try check_constructor (gfc_constructor *, try (*) (gfc_expr *));
1049 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1050 that that variable is an iteration variables. */
1053 gfc_check_iter_variable (gfc_expr *expr)
1058 sym = expr->symtree->n.sym;
1060 for (c = base; c; c = c->previous)
1061 if (sym == c->iterator->var->symtree->n.sym)
1068 /* Recursive work function for gfc_check_constructor(). This amounts
1069 to calling the check function for each expression in the
1070 constructor, giving variables with the names of iterators a pass. */
1073 check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *))
1079 for (; c; c = c->next)
1083 if (e->expr_type != EXPR_ARRAY)
1085 if ((*check_function) (e) == FAILURE)
1090 element.previous = base;
1091 element.iterator = c->iterator;
1094 t = check_constructor (e->value.constructor, check_function);
1095 base = element.previous;
1101 /* Nothing went wrong, so all OK. */
1106 /* Checks a constructor to see if it is a particular kind of
1107 expression -- specification, restricted, or initialization as
1108 determined by the check_function. */
1111 gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *))
1113 cons_stack *base_save;
1119 t = check_constructor (expr->value.constructor, check_function);
1127 /**************** Simplification of array constructors ****************/
1129 iterator_stack *iter_stack;
1133 gfc_constructor *new_head, *new_tail;
1134 int extract_count, extract_n;
1135 gfc_expr *extracted;
1139 gfc_component *component;
1142 try (*expand_work_function) (gfc_expr *);
1146 static expand_info current_expand;
1148 static try expand_constructor (gfc_constructor *);
1151 /* Work function that counts the number of elements present in a
1155 count_elements (gfc_expr *e)
1160 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1163 if (gfc_array_size (e, &result) == FAILURE)
1169 mpz_add (*current_expand.count, *current_expand.count, result);
1178 /* Work function that extracts a particular element from an array
1179 constructor, freeing the rest. */
1182 extract_element (gfc_expr *e)
1186 { /* Something unextractable */
1191 if (current_expand.extract_count == current_expand.extract_n)
1192 current_expand.extracted = e;
1196 current_expand.extract_count++;
1201 /* Work function that constructs a new constructor out of the old one,
1202 stringing new elements together. */
1205 expand (gfc_expr *e)
1207 if (current_expand.new_head == NULL)
1208 current_expand.new_head = current_expand.new_tail =
1209 gfc_get_constructor ();
1212 current_expand.new_tail->next = gfc_get_constructor ();
1213 current_expand.new_tail = current_expand.new_tail->next;
1216 current_expand.new_tail->where = e->where;
1217 current_expand.new_tail->expr = e;
1219 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1220 current_expand.new_tail->n.component = current_expand.component;
1221 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1226 /* Given an initialization expression that is a variable reference,
1227 substitute the current value of the iteration variable. */
1230 gfc_simplify_iterator_var (gfc_expr *e)
1234 for (p = iter_stack; p; p = p->prev)
1235 if (e->symtree == p->variable)
1239 return; /* Variable not found */
1241 gfc_replace_expr (e, gfc_int_expr (0));
1243 mpz_set (e->value.integer, p->value);
1249 /* Expand an expression with that is inside of a constructor,
1250 recursing into other constructors if present. */
1253 expand_expr (gfc_expr *e)
1255 if (e->expr_type == EXPR_ARRAY)
1256 return expand_constructor (e->value.constructor);
1258 e = gfc_copy_expr (e);
1260 if (gfc_simplify_expr (e, 1) == FAILURE)
1266 return current_expand.expand_work_function (e);
1271 expand_iterator (gfc_constructor *c)
1273 gfc_expr *start, *end, *step;
1274 iterator_stack frame;
1283 mpz_init (frame.value);
1286 start = gfc_copy_expr (c->iterator->start);
1287 if (gfc_simplify_expr (start, 1) == FAILURE)
1290 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1293 end = gfc_copy_expr (c->iterator->end);
1294 if (gfc_simplify_expr (end, 1) == FAILURE)
1297 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1300 step = gfc_copy_expr (c->iterator->step);
1301 if (gfc_simplify_expr (step, 1) == FAILURE)
1304 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1307 if (mpz_sgn (step->value.integer) == 0)
1309 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1313 /* Calculate the trip count of the loop. */
1314 mpz_sub (trip, end->value.integer, start->value.integer);
1315 mpz_add (trip, trip, step->value.integer);
1316 mpz_tdiv_q (trip, trip, step->value.integer);
1318 mpz_set (frame.value, start->value.integer);
1320 frame.prev = iter_stack;
1321 frame.variable = c->iterator->var->symtree;
1322 iter_stack = &frame;
1324 while (mpz_sgn (trip) > 0)
1326 if (expand_expr (c->expr) == FAILURE)
1329 mpz_add (frame.value, frame.value, step->value.integer);
1330 mpz_sub_ui (trip, trip, 1);
1336 gfc_free_expr (start);
1337 gfc_free_expr (end);
1338 gfc_free_expr (step);
1341 mpz_clear (frame.value);
1343 iter_stack = frame.prev;
1349 /* Expand a constructor into constant constructors without any
1350 iterators, calling the work function for each of the expanded
1351 expressions. The work function needs to either save or free the
1352 passed expression. */
1355 expand_constructor (gfc_constructor *c)
1359 for (; c; c = c->next)
1361 if (c->iterator != NULL)
1363 if (expand_iterator (c) == FAILURE)
1370 if (e->expr_type == EXPR_ARRAY)
1372 if (expand_constructor (e->value.constructor) == FAILURE)
1378 e = gfc_copy_expr (e);
1379 if (gfc_simplify_expr (e, 1) == FAILURE)
1384 current_expand.offset = &c->n.offset;
1385 current_expand.component = c->n.component;
1386 current_expand.repeat = &c->repeat;
1387 if (current_expand.expand_work_function (e) == FAILURE)
1394 /* Top level subroutine for expanding constructors. We only expand
1395 constructor if they are small enough. */
1398 gfc_expand_constructor (gfc_expr *e)
1400 expand_info expand_save;
1404 f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1411 expand_save = current_expand;
1412 current_expand.new_head = current_expand.new_tail = NULL;
1416 current_expand.expand_work_function = expand;
1418 if (expand_constructor (e->value.constructor) == FAILURE)
1420 gfc_free_constructor (current_expand.new_head);
1425 gfc_free_constructor (e->value.constructor);
1426 e->value.constructor = current_expand.new_head;
1431 current_expand = expand_save;
1437 /* Work function for checking that an element of a constructor is a
1438 constant, after removal of any iteration variables. We return
1439 FAILURE if not so. */
1442 constant_element (gfc_expr *e)
1446 rv = gfc_is_constant_expr (e);
1449 return rv ? SUCCESS : FAILURE;
1453 /* Given an array constructor, determine if the constructor is
1454 constant or not by expanding it and making sure that all elements
1455 are constants. This is a bit of a hack since something like (/ (i,
1456 i=1,100000000) /) will take a while as* opposed to a more clever
1457 function that traverses the expression tree. FIXME. */
1460 gfc_constant_ac (gfc_expr *e)
1462 expand_info expand_save;
1466 expand_save = current_expand;
1467 current_expand.expand_work_function = constant_element;
1469 rc = expand_constructor (e->value.constructor);
1471 current_expand = expand_save;
1479 /* Returns nonzero if an array constructor has been completely
1480 expanded (no iterators) and zero if iterators are present. */
1483 gfc_expanded_ac (gfc_expr *e)
1487 if (e->expr_type == EXPR_ARRAY)
1488 for (p = e->value.constructor; p; p = p->next)
1489 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1496 /*************** Type resolution of array constructors ***************/
1498 /* Recursive array list resolution function. All of the elements must
1499 be of the same type. */
1502 resolve_array_list (gfc_constructor *p)
1508 for (; p; p = p->next)
1510 if (p->iterator != NULL
1511 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1514 if (gfc_resolve_expr (p->expr) == FAILURE)
1521 /* Resolve character array constructor. If it is a constant character array and
1522 not specified character length, update character length to the maximum of
1523 its element constructors' length. */
1526 gfc_resolve_character_array_constructor (gfc_expr *expr)
1531 gcc_assert (expr->expr_type == EXPR_ARRAY);
1532 gcc_assert (expr->ts.type == BT_CHARACTER);
1536 if (expr->ts.cl == NULL)
1538 for (p = expr->value.constructor; p; p = p->next)
1539 if (p->expr->ts.cl != NULL)
1541 /* Ensure that if there is a char_len around that it is
1542 used; otherwise the middle-end confuses them! */
1543 expr->ts.cl = p->expr->ts.cl;
1547 expr->ts.cl = gfc_get_charlen ();
1548 expr->ts.cl->next = gfc_current_ns->cl_list;
1549 gfc_current_ns->cl_list = expr->ts.cl;
1554 if (expr->ts.cl->length == NULL)
1556 /* Find the maximum length of the elements. Do nothing for variable
1557 array constructor, unless the character length is constant or
1558 there is a constant substring reference. */
1560 for (p = expr->value.constructor; p; p = p->next)
1563 for (ref = p->expr->ref; ref; ref = ref->next)
1564 if (ref->type == REF_SUBSTRING
1565 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1566 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1569 if (p->expr->expr_type == EXPR_CONSTANT)
1570 max_length = MAX (p->expr->value.character.length, max_length);
1574 j = mpz_get_ui (ref->u.ss.end->value.integer)
1575 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1576 max_length = MAX ((int) j, max_length);
1578 else if (p->expr->ts.cl && p->expr->ts.cl->length
1579 && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1582 j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1583 max_length = MAX ((int) j, max_length);
1589 if (max_length != -1)
1591 /* Update the character length of the array constructor. */
1592 expr->ts.cl->length = gfc_int_expr (max_length);
1593 /* Update the element constructors. */
1594 for (p = expr->value.constructor; p; p = p->next)
1595 if (p->expr->expr_type == EXPR_CONSTANT)
1596 gfc_set_constant_character_len (max_length, p->expr, true);
1602 /* Resolve all of the expressions in an array list. */
1605 gfc_resolve_array_constructor (gfc_expr *expr)
1609 t = resolve_array_list (expr->value.constructor);
1611 t = gfc_check_constructor_type (expr);
1612 if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
1613 gfc_resolve_character_array_constructor (expr);
1619 /* Copy an iterator structure. */
1621 static gfc_iterator *
1622 copy_iterator (gfc_iterator *src)
1629 dest = gfc_get_iterator ();
1631 dest->var = gfc_copy_expr (src->var);
1632 dest->start = gfc_copy_expr (src->start);
1633 dest->end = gfc_copy_expr (src->end);
1634 dest->step = gfc_copy_expr (src->step);
1640 /* Copy a constructor structure. */
1643 gfc_copy_constructor (gfc_constructor *src)
1645 gfc_constructor *dest;
1646 gfc_constructor *tail;
1655 dest = tail = gfc_get_constructor ();
1658 tail->next = gfc_get_constructor ();
1661 tail->where = src->where;
1662 tail->expr = gfc_copy_expr (src->expr);
1663 tail->iterator = copy_iterator (src->iterator);
1664 mpz_set (tail->n.offset, src->n.offset);
1665 tail->n.component = src->n.component;
1666 mpz_set (tail->repeat, src->repeat);
1674 /* Given an array expression and an element number (starting at zero),
1675 return a pointer to the array element. NULL is returned if the
1676 size of the array has been exceeded. The expression node returned
1677 remains a part of the array and should not be freed. Access is not
1678 efficient at all, but this is another place where things do not
1679 have to be particularly fast. */
1682 gfc_get_array_element (gfc_expr *array, int element)
1684 expand_info expand_save;
1688 expand_save = current_expand;
1689 current_expand.extract_n = element;
1690 current_expand.expand_work_function = extract_element;
1691 current_expand.extracted = NULL;
1692 current_expand.extract_count = 0;
1696 rc = expand_constructor (array->value.constructor);
1697 e = current_expand.extracted;
1698 current_expand = expand_save;
1707 /********* Subroutines for determining the size of an array *********/
1709 /* These are needed just to accommodate RESHAPE(). There are no
1710 diagnostics here, we just return a negative number if something
1714 /* Get the size of single dimension of an array specification. The
1715 array is guaranteed to be one dimensional. */
1718 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1723 if (dimen < 0 || dimen > as->rank - 1)
1724 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1726 if (as->type != AS_EXPLICIT
1727 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1728 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1729 || as->lower[dimen]->ts.type != BT_INTEGER
1730 || as->upper[dimen]->ts.type != BT_INTEGER)
1735 mpz_sub (*result, as->upper[dimen]->value.integer,
1736 as->lower[dimen]->value.integer);
1738 mpz_add_ui (*result, *result, 1);
1745 spec_size (gfc_array_spec *as, mpz_t *result)
1750 mpz_init_set_ui (*result, 1);
1752 for (d = 0; d < as->rank; d++)
1754 if (spec_dimen_size (as, d, &size) == FAILURE)
1756 mpz_clear (*result);
1760 mpz_mul (*result, *result, size);
1768 /* Get the number of elements in an array section. */
1771 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1773 mpz_t upper, lower, stride;
1776 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1777 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1779 switch (ar->dimen_type[dimen])
1783 mpz_set_ui (*result, 1);
1788 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1797 if (ar->start[dimen] == NULL)
1799 if (ar->as->lower[dimen] == NULL
1800 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1802 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1806 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1808 mpz_set (lower, ar->start[dimen]->value.integer);
1811 if (ar->end[dimen] == NULL)
1813 if (ar->as->upper[dimen] == NULL
1814 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1816 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1820 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1822 mpz_set (upper, ar->end[dimen]->value.integer);
1825 if (ar->stride[dimen] == NULL)
1826 mpz_set_ui (stride, 1);
1829 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1831 mpz_set (stride, ar->stride[dimen]->value.integer);
1835 mpz_sub (*result, upper, lower);
1836 mpz_add (*result, *result, stride);
1837 mpz_div (*result, *result, stride);
1839 /* Zero stride caught earlier. */
1840 if (mpz_cmp_ui (*result, 0) < 0)
1841 mpz_set_ui (*result, 0);
1851 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1859 ref_size (gfc_array_ref *ar, mpz_t *result)
1864 mpz_init_set_ui (*result, 1);
1866 for (d = 0; d < ar->dimen; d++)
1868 if (ref_dimen_size (ar, d, &size) == FAILURE)
1870 mpz_clear (*result);
1874 mpz_mul (*result, *result, size);
1882 /* Given an array expression and a dimension, figure out how many
1883 elements it has along that dimension. Returns SUCCESS if we were
1884 able to return a result in the 'result' variable, FAILURE
1888 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
1893 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1894 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1896 switch (array->expr_type)
1900 for (ref = array->ref; ref; ref = ref->next)
1902 if (ref->type != REF_ARRAY)
1905 if (ref->u.ar.type == AR_FULL)
1906 return spec_dimen_size (ref->u.ar.as, dimen, result);
1908 if (ref->u.ar.type == AR_SECTION)
1910 for (i = 0; dimen >= 0; i++)
1911 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1914 return ref_dimen_size (&ref->u.ar, i - 1, result);
1918 if (array->shape && array->shape[dimen])
1920 mpz_init_set (*result, array->shape[dimen]);
1924 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
1930 if (array->shape == NULL) {
1931 /* Expressions with rank > 1 should have "shape" properly set */
1932 if ( array->rank != 1 )
1933 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1934 return gfc_array_size(array, result);
1939 if (array->shape == NULL)
1942 mpz_init_set (*result, array->shape[dimen]);
1951 /* Given an array expression, figure out how many elements are in the
1952 array. Returns SUCCESS if this is possible, and sets the 'result'
1953 variable. Otherwise returns FAILURE. */
1956 gfc_array_size (gfc_expr *array, mpz_t *result)
1958 expand_info expand_save;
1963 switch (array->expr_type)
1966 flag = gfc_suppress_error;
1967 gfc_suppress_error = 1;
1969 expand_save = current_expand;
1971 current_expand.count = result;
1972 mpz_init_set_ui (*result, 0);
1974 current_expand.expand_work_function = count_elements;
1977 t = expand_constructor (array->value.constructor);
1978 gfc_suppress_error = flag;
1981 mpz_clear (*result);
1982 current_expand = expand_save;
1986 for (ref = array->ref; ref; ref = ref->next)
1988 if (ref->type != REF_ARRAY)
1991 if (ref->u.ar.type == AR_FULL)
1992 return spec_size (ref->u.ar.as, result);
1994 if (ref->u.ar.type == AR_SECTION)
1995 return ref_size (&ref->u.ar, result);
1998 return spec_size (array->symtree->n.sym->as, result);
2002 if (array->rank == 0 || array->shape == NULL)
2005 mpz_init_set_ui (*result, 1);
2007 for (i = 0; i < array->rank; i++)
2008 mpz_mul (*result, *result, array->shape[i]);
2017 /* Given an array reference, return the shape of the reference in an
2018 array of mpz_t integers. */
2021 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2031 for (; d < ar->as->rank; d++)
2032 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2038 for (i = 0; i < ar->dimen; i++)
2040 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2042 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2055 for (d--; d >= 0; d--)
2056 mpz_clear (shape[d]);
2062 /* Given an array expression, find the array reference structure that
2063 characterizes the reference. */
2066 gfc_find_array_ref (gfc_expr *e)
2070 for (ref = e->ref; ref; ref = ref->next)
2071 if (ref->type == REF_ARRAY
2072 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2076 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2082 /* Find out if an array shape is known at compile time. */
2085 gfc_is_compile_time_shape (gfc_array_spec *as)
2089 if (as->type != AS_EXPLICIT)
2092 for (i = 0; i < as->rank; i++)
2093 if (!gfc_is_constant_expr (as->lower[i])
2094 || !gfc_is_constant_expr (as->upper[i]))