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);
1285 start = gfc_copy_expr (c->iterator->start);
1286 if (gfc_simplify_expr (start, 1) == FAILURE)
1289 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1292 end = gfc_copy_expr (c->iterator->end);
1293 if (gfc_simplify_expr (end, 1) == FAILURE)
1296 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1299 step = gfc_copy_expr (c->iterator->step);
1300 if (gfc_simplify_expr (step, 1) == FAILURE)
1303 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1306 if (mpz_sgn (step->value.integer) == 0)
1308 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1312 /* Calculate the trip count of the loop. */
1313 mpz_sub (trip, end->value.integer, start->value.integer);
1314 mpz_add (trip, trip, step->value.integer);
1315 mpz_tdiv_q (trip, trip, step->value.integer);
1317 mpz_set (frame.value, start->value.integer);
1319 frame.prev = iter_stack;
1320 frame.variable = c->iterator->var->symtree;
1321 iter_stack = &frame;
1323 while (mpz_sgn (trip) > 0)
1325 if (expand_expr (c->expr) == FAILURE)
1328 mpz_add (frame.value, frame.value, step->value.integer);
1329 mpz_sub_ui (trip, trip, 1);
1335 gfc_free_expr (start);
1336 gfc_free_expr (end);
1337 gfc_free_expr (step);
1340 mpz_clear (frame.value);
1342 iter_stack = frame.prev;
1348 /* Expand a constructor into constant constructors without any
1349 iterators, calling the work function for each of the expanded
1350 expressions. The work function needs to either save or free the
1351 passed expression. */
1354 expand_constructor (gfc_constructor *c)
1358 for (; c; c = c->next)
1360 if (c->iterator != NULL)
1362 if (expand_iterator (c) == FAILURE)
1369 if (e->expr_type == EXPR_ARRAY)
1371 if (expand_constructor (e->value.constructor) == FAILURE)
1377 e = gfc_copy_expr (e);
1378 if (gfc_simplify_expr (e, 1) == FAILURE)
1383 current_expand.offset = &c->n.offset;
1384 current_expand.component = c->n.component;
1385 current_expand.repeat = &c->repeat;
1386 if (current_expand.expand_work_function (e) == FAILURE)
1393 /* Top level subroutine for expanding constructors. We only expand
1394 constructor if they are small enough. */
1397 gfc_expand_constructor (gfc_expr *e)
1399 expand_info expand_save;
1403 f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1410 expand_save = current_expand;
1411 current_expand.new_head = current_expand.new_tail = NULL;
1415 current_expand.expand_work_function = expand;
1417 if (expand_constructor (e->value.constructor) == FAILURE)
1419 gfc_free_constructor (current_expand.new_head);
1424 gfc_free_constructor (e->value.constructor);
1425 e->value.constructor = current_expand.new_head;
1430 current_expand = expand_save;
1436 /* Work function for checking that an element of a constructor is a
1437 constant, after removal of any iteration variables. We return
1438 FAILURE if not so. */
1441 constant_element (gfc_expr *e)
1445 rv = gfc_is_constant_expr (e);
1448 return rv ? SUCCESS : FAILURE;
1452 /* Given an array constructor, determine if the constructor is
1453 constant or not by expanding it and making sure that all elements
1454 are constants. This is a bit of a hack since something like (/ (i,
1455 i=1,100000000) /) will take a while as* opposed to a more clever
1456 function that traverses the expression tree. FIXME. */
1459 gfc_constant_ac (gfc_expr *e)
1461 expand_info expand_save;
1465 expand_save = current_expand;
1466 current_expand.expand_work_function = constant_element;
1468 rc = expand_constructor (e->value.constructor);
1470 current_expand = expand_save;
1478 /* Returns nonzero if an array constructor has been completely
1479 expanded (no iterators) and zero if iterators are present. */
1482 gfc_expanded_ac (gfc_expr *e)
1486 if (e->expr_type == EXPR_ARRAY)
1487 for (p = e->value.constructor; p; p = p->next)
1488 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1495 /*************** Type resolution of array constructors ***************/
1497 /* Recursive array list resolution function. All of the elements must
1498 be of the same type. */
1501 resolve_array_list (gfc_constructor *p)
1507 for (; p; p = p->next)
1509 if (p->iterator != NULL
1510 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1513 if (gfc_resolve_expr (p->expr) == FAILURE)
1520 /* Resolve character array constructor. If it is a constant character array and
1521 not specified character length, update character length to the maximum of
1522 its element constructors' length. */
1525 gfc_resolve_character_array_constructor (gfc_expr *expr)
1530 gcc_assert (expr->expr_type == EXPR_ARRAY);
1531 gcc_assert (expr->ts.type == BT_CHARACTER);
1535 if (expr->ts.cl == NULL)
1537 for (p = expr->value.constructor; p; p = p->next)
1538 if (p->expr->ts.cl != NULL)
1540 /* Ensure that if there is a char_len around that it is
1541 used; otherwise the middle-end confuses them! */
1542 expr->ts.cl = p->expr->ts.cl;
1546 expr->ts.cl = gfc_get_charlen ();
1547 expr->ts.cl->next = gfc_current_ns->cl_list;
1548 gfc_current_ns->cl_list = expr->ts.cl;
1553 if (expr->ts.cl->length == NULL)
1555 /* Find the maximum length of the elements. Do nothing for variable
1556 array constructor, unless the character length is constant or
1557 there is a constant substring reference. */
1559 for (p = expr->value.constructor; p; p = p->next)
1562 for (ref = p->expr->ref; ref; ref = ref->next)
1563 if (ref->type == REF_SUBSTRING
1564 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1565 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1568 if (p->expr->expr_type == EXPR_CONSTANT)
1569 max_length = MAX (p->expr->value.character.length, max_length);
1573 j = mpz_get_ui (ref->u.ss.end->value.integer)
1574 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1575 max_length = MAX ((int) j, max_length);
1577 else if (p->expr->ts.cl && p->expr->ts.cl->length
1578 && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1581 j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1582 max_length = MAX ((int) j, max_length);
1588 if (max_length != -1)
1590 /* Update the character length of the array constructor. */
1591 expr->ts.cl->length = gfc_int_expr (max_length);
1592 /* Update the element constructors. */
1593 for (p = expr->value.constructor; p; p = p->next)
1594 if (p->expr->expr_type == EXPR_CONSTANT)
1595 gfc_set_constant_character_len (max_length, p->expr, true);
1601 /* Resolve all of the expressions in an array list. */
1604 gfc_resolve_array_constructor (gfc_expr *expr)
1608 t = resolve_array_list (expr->value.constructor);
1610 t = gfc_check_constructor_type (expr);
1611 if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
1612 gfc_resolve_character_array_constructor (expr);
1618 /* Copy an iterator structure. */
1620 static gfc_iterator *
1621 copy_iterator (gfc_iterator *src)
1628 dest = gfc_get_iterator ();
1630 dest->var = gfc_copy_expr (src->var);
1631 dest->start = gfc_copy_expr (src->start);
1632 dest->end = gfc_copy_expr (src->end);
1633 dest->step = gfc_copy_expr (src->step);
1639 /* Copy a constructor structure. */
1642 gfc_copy_constructor (gfc_constructor *src)
1644 gfc_constructor *dest;
1645 gfc_constructor *tail;
1654 dest = tail = gfc_get_constructor ();
1657 tail->next = gfc_get_constructor ();
1660 tail->where = src->where;
1661 tail->expr = gfc_copy_expr (src->expr);
1662 tail->iterator = copy_iterator (src->iterator);
1663 mpz_set (tail->n.offset, src->n.offset);
1664 tail->n.component = src->n.component;
1665 mpz_set (tail->repeat, src->repeat);
1673 /* Given an array expression and an element number (starting at zero),
1674 return a pointer to the array element. NULL is returned if the
1675 size of the array has been exceeded. The expression node returned
1676 remains a part of the array and should not be freed. Access is not
1677 efficient at all, but this is another place where things do not
1678 have to be particularly fast. */
1681 gfc_get_array_element (gfc_expr *array, int element)
1683 expand_info expand_save;
1687 expand_save = current_expand;
1688 current_expand.extract_n = element;
1689 current_expand.expand_work_function = extract_element;
1690 current_expand.extracted = NULL;
1691 current_expand.extract_count = 0;
1695 rc = expand_constructor (array->value.constructor);
1696 e = current_expand.extracted;
1697 current_expand = expand_save;
1706 /********* Subroutines for determining the size of an array *********/
1708 /* These are needed just to accommodate RESHAPE(). There are no
1709 diagnostics here, we just return a negative number if something
1713 /* Get the size of single dimension of an array specification. The
1714 array is guaranteed to be one dimensional. */
1717 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1722 if (dimen < 0 || dimen > as->rank - 1)
1723 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1725 if (as->type != AS_EXPLICIT
1726 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1727 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1728 || as->lower[dimen]->ts.type != BT_INTEGER
1729 || as->upper[dimen]->ts.type != BT_INTEGER)
1734 mpz_sub (*result, as->upper[dimen]->value.integer,
1735 as->lower[dimen]->value.integer);
1737 mpz_add_ui (*result, *result, 1);
1744 spec_size (gfc_array_spec *as, mpz_t *result)
1749 mpz_init_set_ui (*result, 1);
1751 for (d = 0; d < as->rank; d++)
1753 if (spec_dimen_size (as, d, &size) == FAILURE)
1755 mpz_clear (*result);
1759 mpz_mul (*result, *result, size);
1767 /* Get the number of elements in an array section. */
1770 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1772 mpz_t upper, lower, stride;
1775 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1776 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1778 switch (ar->dimen_type[dimen])
1782 mpz_set_ui (*result, 1);
1787 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1796 if (ar->start[dimen] == NULL)
1798 if (ar->as->lower[dimen] == NULL
1799 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1801 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1805 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1807 mpz_set (lower, ar->start[dimen]->value.integer);
1810 if (ar->end[dimen] == NULL)
1812 if (ar->as->upper[dimen] == NULL
1813 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1815 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1819 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1821 mpz_set (upper, ar->end[dimen]->value.integer);
1824 if (ar->stride[dimen] == NULL)
1825 mpz_set_ui (stride, 1);
1828 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1830 mpz_set (stride, ar->stride[dimen]->value.integer);
1834 mpz_sub (*result, upper, lower);
1835 mpz_add (*result, *result, stride);
1836 mpz_div (*result, *result, stride);
1838 /* Zero stride caught earlier. */
1839 if (mpz_cmp_ui (*result, 0) < 0)
1840 mpz_set_ui (*result, 0);
1850 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1858 ref_size (gfc_array_ref *ar, mpz_t *result)
1863 mpz_init_set_ui (*result, 1);
1865 for (d = 0; d < ar->dimen; d++)
1867 if (ref_dimen_size (ar, d, &size) == FAILURE)
1869 mpz_clear (*result);
1873 mpz_mul (*result, *result, size);
1881 /* Given an array expression and a dimension, figure out how many
1882 elements it has along that dimension. Returns SUCCESS if we were
1883 able to return a result in the 'result' variable, FAILURE
1887 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
1892 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1893 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1895 switch (array->expr_type)
1899 for (ref = array->ref; ref; ref = ref->next)
1901 if (ref->type != REF_ARRAY)
1904 if (ref->u.ar.type == AR_FULL)
1905 return spec_dimen_size (ref->u.ar.as, dimen, result);
1907 if (ref->u.ar.type == AR_SECTION)
1909 for (i = 0; dimen >= 0; i++)
1910 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1913 return ref_dimen_size (&ref->u.ar, i - 1, result);
1917 if (array->shape && array->shape[dimen])
1919 mpz_init_set (*result, array->shape[dimen]);
1923 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
1929 if (array->shape == NULL) {
1930 /* Expressions with rank > 1 should have "shape" properly set */
1931 if ( array->rank != 1 )
1932 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1933 return gfc_array_size(array, result);
1938 if (array->shape == NULL)
1941 mpz_init_set (*result, array->shape[dimen]);
1950 /* Given an array expression, figure out how many elements are in the
1951 array. Returns SUCCESS if this is possible, and sets the 'result'
1952 variable. Otherwise returns FAILURE. */
1955 gfc_array_size (gfc_expr *array, mpz_t *result)
1957 expand_info expand_save;
1962 switch (array->expr_type)
1965 flag = gfc_suppress_error;
1966 gfc_suppress_error = 1;
1968 expand_save = current_expand;
1970 current_expand.count = result;
1971 mpz_init_set_ui (*result, 0);
1973 current_expand.expand_work_function = count_elements;
1976 t = expand_constructor (array->value.constructor);
1977 gfc_suppress_error = flag;
1980 mpz_clear (*result);
1981 current_expand = expand_save;
1985 for (ref = array->ref; ref; ref = ref->next)
1987 if (ref->type != REF_ARRAY)
1990 if (ref->u.ar.type == AR_FULL)
1991 return spec_size (ref->u.ar.as, result);
1993 if (ref->u.ar.type == AR_SECTION)
1994 return ref_size (&ref->u.ar, result);
1997 return spec_size (array->symtree->n.sym->as, result);
2001 if (array->rank == 0 || array->shape == NULL)
2004 mpz_init_set_ui (*result, 1);
2006 for (i = 0; i < array->rank; i++)
2007 mpz_mul (*result, *result, array->shape[i]);
2016 /* Given an array reference, return the shape of the reference in an
2017 array of mpz_t integers. */
2020 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2030 for (; d < ar->as->rank; d++)
2031 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2037 for (i = 0; i < ar->dimen; i++)
2039 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2041 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2054 for (d--; d >= 0; d--)
2055 mpz_clear (shape[d]);
2061 /* Given an array expression, find the array reference structure that
2062 characterizes the reference. */
2065 gfc_find_array_ref (gfc_expr *e)
2069 for (ref = e->ref; ref; ref = ref->next)
2070 if (ref->type == REF_ARRAY
2071 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2075 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2081 /* Find out if an array shape is known at compile time. */
2084 gfc_is_compile_time_shape (gfc_array_spec *as)
2088 if (as->type != AS_EXPLICIT)
2091 for (i = 0; i < as->rank; i++)
2092 if (!gfc_is_constant_expr (as->lower[i])
2093 || !gfc_is_constant_expr (as->upper[i]))