2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
27 /* 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)
254 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
257 /* If the size is negative in this dimension, set it to zero. */
258 if (as->lower[i]->expr_type == EXPR_CONSTANT
259 && as->upper[i]->expr_type == EXPR_CONSTANT
260 && mpz_cmp (as->upper[i]->value.integer,
261 as->lower[i]->value.integer) < 0)
263 gfc_free_expr (as->upper[i]);
264 as->upper[i] = gfc_copy_expr (as->lower[i]);
265 mpz_sub_ui (as->upper[i]->value.integer,
266 as->upper[i]->value.integer, 1);
274 /* Match a single array element specification. The return values as
275 well as the upper and lower bounds of the array spec are filled
276 in according to what we see on the input. The caller makes sure
277 individual specifications make sense as a whole.
280 Parsed Lower Upper Returned
281 ------------------------------------
282 : NULL NULL AS_DEFERRED (*)
284 x: x NULL AS_ASSUMED_SHAPE
286 x:* x NULL AS_ASSUMED_SIZE
287 * 1 NULL AS_ASSUMED_SIZE
289 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
290 is fixed during the resolution of formal interfaces.
292 Anything else AS_UNKNOWN. */
295 match_array_element_spec (gfc_array_spec *as)
297 gfc_expr **upper, **lower;
300 lower = &as->lower[as->rank - 1];
301 upper = &as->upper[as->rank - 1];
303 if (gfc_match_char ('*') == MATCH_YES)
305 *lower = gfc_int_expr (1);
306 return AS_ASSUMED_SIZE;
309 if (gfc_match_char (':') == MATCH_YES)
312 m = gfc_match_expr (upper);
314 gfc_error ("Expected expression in array specification at %C");
317 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
320 if (gfc_match_char (':') == MATCH_NO)
322 *lower = gfc_int_expr (1);
329 if (gfc_match_char ('*') == MATCH_YES)
330 return AS_ASSUMED_SIZE;
332 m = gfc_match_expr (upper);
333 if (m == MATCH_ERROR)
336 return AS_ASSUMED_SHAPE;
337 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
344 /* Matches an array specification, incidentally figuring out what sort
348 gfc_match_array_spec (gfc_array_spec **asp)
350 array_type current_type;
354 if (gfc_match_char ('(') != MATCH_YES)
360 as = gfc_get_array_spec ();
362 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
372 current_type = match_array_element_spec (as);
376 if (current_type == AS_UNKNOWN)
378 as->type = current_type;
382 { /* See how current spec meshes with the existing. */
387 if (current_type == AS_ASSUMED_SIZE)
389 as->type = AS_ASSUMED_SIZE;
393 if (current_type == AS_EXPLICIT)
396 gfc_error ("Bad array specification for an explicitly shaped "
401 case AS_ASSUMED_SHAPE:
402 if ((current_type == AS_ASSUMED_SHAPE)
403 || (current_type == AS_DEFERRED))
406 gfc_error ("Bad array specification for assumed shape "
411 if (current_type == AS_DEFERRED)
414 if (current_type == AS_ASSUMED_SHAPE)
416 as->type = AS_ASSUMED_SHAPE;
420 gfc_error ("Bad specification for deferred shape array at %C");
423 case AS_ASSUMED_SIZE:
424 gfc_error ("Bad specification for assumed size array at %C");
428 if (gfc_match_char (')') == MATCH_YES)
431 if (gfc_match_char (',') != MATCH_YES)
433 gfc_error ("Expected another dimension in array declaration at %C");
437 if (as->rank >= GFC_MAX_DIMENSIONS)
439 gfc_error ("Array specification at %C has more than %d dimensions",
445 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
446 "specification at %C with more than 7 dimensions")
453 /* If a lower bounds of an assumed shape array is blank, put in one. */
454 if (as->type == AS_ASSUMED_SHAPE)
456 for (i = 0; i < as->rank; i++)
458 if (as->lower[i] == NULL)
459 as->lower[i] = gfc_int_expr (1);
466 /* Something went wrong. */
467 gfc_free_array_spec (as);
472 /* Given a symbol and an array specification, modify the symbol to
473 have that array specification. The error locus is needed in case
474 something goes wrong. On failure, the caller must free the spec. */
477 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
482 if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
491 /* Copy an array specification. */
494 gfc_copy_array_spec (gfc_array_spec *src)
496 gfc_array_spec *dest;
502 dest = gfc_get_array_spec ();
506 for (i = 0; i < dest->rank; i++)
508 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
509 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
516 /* Returns nonzero if the two expressions are equal. Only handles integer
520 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
522 if (bound1 == NULL || bound2 == NULL
523 || bound1->expr_type != EXPR_CONSTANT
524 || bound2->expr_type != EXPR_CONSTANT
525 || bound1->ts.type != BT_INTEGER
526 || bound2->ts.type != BT_INTEGER)
527 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
529 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
536 /* Compares two array specifications. They must be constant or deferred
540 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
544 if (as1 == NULL && as2 == NULL)
547 if (as1 == NULL || as2 == NULL)
550 if (as1->rank != as2->rank)
556 if (as1->type != as2->type)
559 if (as1->type == AS_EXPLICIT)
560 for (i = 0; i < as1->rank; i++)
562 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
565 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
573 /****************** Array constructor functions ******************/
575 /* Start an array constructor. The constructor starts with zero
576 elements and should be appended to by gfc_append_constructor(). */
579 gfc_start_constructor (bt type, int kind, locus *where)
583 result = gfc_get_expr ();
585 result->expr_type = EXPR_ARRAY;
588 result->ts.type = type;
589 result->ts.kind = kind;
590 result->where = *where;
595 /* Given an array constructor expression, append the new expression
596 node onto the constructor. */
599 gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
603 if (base->value.constructor == NULL)
604 base->value.constructor = c = gfc_get_constructor ();
607 c = base->value.constructor;
611 c->next = gfc_get_constructor ();
617 if (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)
618 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
622 /* Given an array constructor expression, insert the new expression's
623 constructor onto the base's one according to the offset. */
626 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
628 gfc_constructor *c, *pre;
632 type = base->expr_type;
634 if (base->value.constructor == NULL)
635 base->value.constructor = c1;
638 c = pre = base->value.constructor;
641 if (type == EXPR_ARRAY)
643 t = mpz_cmp (c->n.offset, c1->n.offset);
651 gfc_error ("duplicated initializer");
672 base->value.constructor = c1;
678 /* Get a new constructor. */
681 gfc_get_constructor (void)
685 c = XCNEW (gfc_constructor);
689 mpz_init_set_si (c->n.offset, 0);
690 mpz_init_set_si (c->repeat, 0);
695 /* Free chains of gfc_constructor structures. */
698 gfc_free_constructor (gfc_constructor *p)
700 gfc_constructor *next;
710 gfc_free_expr (p->expr);
711 if (p->iterator != NULL)
712 gfc_free_iterator (p->iterator, 1);
713 mpz_clear (p->n.offset);
714 mpz_clear (p->repeat);
720 /* Given an expression node that might be an array constructor and a
721 symbol, make sure that no iterators in this or child constructors
722 use the symbol as an implied-DO iterator. Returns nonzero if a
723 duplicate was found. */
726 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
730 for (; c; c = c->next)
734 if (e->expr_type == EXPR_ARRAY
735 && check_duplicate_iterator (e->value.constructor, master))
738 if (c->iterator == NULL)
741 if (c->iterator->var->symtree->n.sym == master)
743 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
744 "same name", master->name, &c->where);
754 /* Forward declaration because these functions are mutually recursive. */
755 static match match_array_cons_element (gfc_constructor **);
757 /* Match a list of array elements. */
760 match_array_list (gfc_constructor **result)
762 gfc_constructor *p, *head, *tail, *new_cons;
769 old_loc = gfc_current_locus;
771 if (gfc_match_char ('(') == MATCH_NO)
774 memset (&iter, '\0', sizeof (gfc_iterator));
777 m = match_array_cons_element (&head);
783 if (gfc_match_char (',') != MATCH_YES)
791 m = gfc_match_iterator (&iter, 0);
794 if (m == MATCH_ERROR)
797 m = match_array_cons_element (&new_cons);
798 if (m == MATCH_ERROR)
805 goto cleanup; /* Could be a complex constant */
808 tail->next = new_cons;
811 if (gfc_match_char (',') != MATCH_YES)
820 if (gfc_match_char (')') != MATCH_YES)
823 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
830 e->expr_type = EXPR_ARRAY;
832 e->value.constructor = head;
834 p = gfc_get_constructor ();
835 p->where = gfc_current_locus;
836 p->iterator = gfc_get_iterator ();
845 gfc_error ("Syntax error in array constructor at %C");
849 gfc_free_constructor (head);
850 gfc_free_iterator (&iter, 0);
851 gfc_current_locus = old_loc;
856 /* Match a single element of an array constructor, which can be a
857 single expression or a list of elements. */
860 match_array_cons_element (gfc_constructor **result)
866 m = match_array_list (result);
870 m = gfc_match_expr (&expr);
874 p = gfc_get_constructor ();
875 p->where = gfc_current_locus;
883 /* Match an array constructor. */
886 gfc_match_array_constructor (gfc_expr **result)
888 gfc_constructor *head, *tail, *new_cons;
893 const char *end_delim;
896 if (gfc_match (" (/") == MATCH_NO)
898 if (gfc_match (" [") == MATCH_NO)
902 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
903 "style array constructors at %C") == FAILURE)
911 where = gfc_current_locus;
915 /* Try to match an optional "type-spec ::" */
916 if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
918 seen_ts = (gfc_match (" ::") == MATCH_YES);
922 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
923 "including type specification at %C") == FAILURE)
929 gfc_current_locus = where;
931 if (gfc_match (end_delim) == MATCH_YES)
937 gfc_error ("Empty array constructor at %C is not allowed");
944 m = match_array_cons_element (&new_cons);
945 if (m == MATCH_ERROR)
953 tail->next = new_cons;
957 if (gfc_match_char (',') == MATCH_NO)
961 if (gfc_match (end_delim) == MATCH_NO)
965 expr = gfc_get_expr ();
967 expr->expr_type = EXPR_ARRAY;
969 expr->value.constructor = head;
970 /* Size must be calculated at resolution time. */
975 expr->ts.type = BT_UNKNOWN;
978 expr->ts.cl->length_from_typespec = seen_ts;
987 gfc_error ("Syntax error in array constructor at %C");
990 gfc_free_constructor (head);
996 /************** Check array constructors for correctness **************/
998 /* Given an expression, compare it's type with the type of the current
999 constructor. Returns nonzero if an error was issued. The
1000 cons_state variable keeps track of whether the type of the
1001 constructor being read or resolved is known to be good, bad or just
1004 static gfc_typespec constructor_ts;
1006 { CONS_START, CONS_GOOD, CONS_BAD }
1010 check_element_type (gfc_expr *expr, bool convert)
1012 if (cons_state == CONS_BAD)
1013 return 0; /* Suppress further errors */
1015 if (cons_state == CONS_START)
1017 if (expr->ts.type == BT_UNKNOWN)
1018 cons_state = CONS_BAD;
1021 cons_state = CONS_GOOD;
1022 constructor_ts = expr->ts;
1028 if (gfc_compare_types (&constructor_ts, &expr->ts))
1032 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1034 gfc_error ("Element in %s array constructor at %L is %s",
1035 gfc_typename (&constructor_ts), &expr->where,
1036 gfc_typename (&expr->ts));
1038 cons_state = CONS_BAD;
1043 /* Recursive work function for gfc_check_constructor_type(). */
1046 check_constructor_type (gfc_constructor *c, bool convert)
1050 for (; c; c = c->next)
1054 if (e->expr_type == EXPR_ARRAY)
1056 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1062 if (check_element_type (e, convert))
1070 /* Check that all elements of an array constructor are the same type.
1071 On FAILURE, an error has been generated. */
1074 gfc_check_constructor_type (gfc_expr *e)
1078 if (e->ts.type != BT_UNKNOWN)
1080 cons_state = CONS_GOOD;
1081 constructor_ts = e->ts;
1085 cons_state = CONS_START;
1086 gfc_clear_ts (&constructor_ts);
1089 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1090 typespec, and we will now convert the values on the fly. */
1091 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1092 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1093 e->ts = constructor_ts;
1100 typedef struct cons_stack
1102 gfc_iterator *iterator;
1103 struct cons_stack *previous;
1107 static cons_stack *base;
1109 static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
1111 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1112 that that variable is an iteration variables. */
1115 gfc_check_iter_variable (gfc_expr *expr)
1120 sym = expr->symtree->n.sym;
1122 for (c = base; c; c = c->previous)
1123 if (sym == c->iterator->var->symtree->n.sym)
1130 /* Recursive work function for gfc_check_constructor(). This amounts
1131 to calling the check function for each expression in the
1132 constructor, giving variables with the names of iterators a pass. */
1135 check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
1141 for (; c; c = c->next)
1145 if (e->expr_type != EXPR_ARRAY)
1147 if ((*check_function) (e) == FAILURE)
1152 element.previous = base;
1153 element.iterator = c->iterator;
1156 t = check_constructor (e->value.constructor, check_function);
1157 base = element.previous;
1163 /* Nothing went wrong, so all OK. */
1168 /* Checks a constructor to see if it is a particular kind of
1169 expression -- specification, restricted, or initialization as
1170 determined by the check_function. */
1173 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1175 cons_stack *base_save;
1181 t = check_constructor (expr->value.constructor, check_function);
1189 /**************** Simplification of array constructors ****************/
1191 iterator_stack *iter_stack;
1195 gfc_constructor *new_head, *new_tail;
1196 int extract_count, extract_n;
1197 gfc_expr *extracted;
1201 gfc_component *component;
1204 gfc_try (*expand_work_function) (gfc_expr *);
1208 static expand_info current_expand;
1210 static gfc_try expand_constructor (gfc_constructor *);
1213 /* Work function that counts the number of elements present in a
1217 count_elements (gfc_expr *e)
1222 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1225 if (gfc_array_size (e, &result) == FAILURE)
1231 mpz_add (*current_expand.count, *current_expand.count, result);
1240 /* Work function that extracts a particular element from an array
1241 constructor, freeing the rest. */
1244 extract_element (gfc_expr *e)
1248 { /* Something unextractable */
1253 if (current_expand.extract_count == current_expand.extract_n)
1254 current_expand.extracted = e;
1258 current_expand.extract_count++;
1263 /* Work function that constructs a new constructor out of the old one,
1264 stringing new elements together. */
1267 expand (gfc_expr *e)
1269 if (current_expand.new_head == NULL)
1270 current_expand.new_head = current_expand.new_tail =
1271 gfc_get_constructor ();
1274 current_expand.new_tail->next = gfc_get_constructor ();
1275 current_expand.new_tail = current_expand.new_tail->next;
1278 current_expand.new_tail->where = e->where;
1279 current_expand.new_tail->expr = e;
1281 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1282 current_expand.new_tail->n.component = current_expand.component;
1283 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1288 /* Given an initialization expression that is a variable reference,
1289 substitute the current value of the iteration variable. */
1292 gfc_simplify_iterator_var (gfc_expr *e)
1296 for (p = iter_stack; p; p = p->prev)
1297 if (e->symtree == p->variable)
1301 return; /* Variable not found */
1303 gfc_replace_expr (e, gfc_int_expr (0));
1305 mpz_set (e->value.integer, p->value);
1311 /* Expand an expression with that is inside of a constructor,
1312 recursing into other constructors if present. */
1315 expand_expr (gfc_expr *e)
1317 if (e->expr_type == EXPR_ARRAY)
1318 return expand_constructor (e->value.constructor);
1320 e = gfc_copy_expr (e);
1322 if (gfc_simplify_expr (e, 1) == FAILURE)
1328 return current_expand.expand_work_function (e);
1333 expand_iterator (gfc_constructor *c)
1335 gfc_expr *start, *end, *step;
1336 iterator_stack frame;
1345 mpz_init (frame.value);
1348 start = gfc_copy_expr (c->iterator->start);
1349 if (gfc_simplify_expr (start, 1) == FAILURE)
1352 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1355 end = gfc_copy_expr (c->iterator->end);
1356 if (gfc_simplify_expr (end, 1) == FAILURE)
1359 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1362 step = gfc_copy_expr (c->iterator->step);
1363 if (gfc_simplify_expr (step, 1) == FAILURE)
1366 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1369 if (mpz_sgn (step->value.integer) == 0)
1371 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1375 /* Calculate the trip count of the loop. */
1376 mpz_sub (trip, end->value.integer, start->value.integer);
1377 mpz_add (trip, trip, step->value.integer);
1378 mpz_tdiv_q (trip, trip, step->value.integer);
1380 mpz_set (frame.value, start->value.integer);
1382 frame.prev = iter_stack;
1383 frame.variable = c->iterator->var->symtree;
1384 iter_stack = &frame;
1386 while (mpz_sgn (trip) > 0)
1388 if (expand_expr (c->expr) == FAILURE)
1391 mpz_add (frame.value, frame.value, step->value.integer);
1392 mpz_sub_ui (trip, trip, 1);
1398 gfc_free_expr (start);
1399 gfc_free_expr (end);
1400 gfc_free_expr (step);
1403 mpz_clear (frame.value);
1405 iter_stack = frame.prev;
1411 /* Expand a constructor into constant constructors without any
1412 iterators, calling the work function for each of the expanded
1413 expressions. The work function needs to either save or free the
1414 passed expression. */
1417 expand_constructor (gfc_constructor *c)
1421 for (; c; c = c->next)
1423 if (c->iterator != NULL)
1425 if (expand_iterator (c) == FAILURE)
1432 if (e->expr_type == EXPR_ARRAY)
1434 if (expand_constructor (e->value.constructor) == FAILURE)
1440 e = gfc_copy_expr (e);
1441 if (gfc_simplify_expr (e, 1) == FAILURE)
1446 current_expand.offset = &c->n.offset;
1447 current_expand.component = c->n.component;
1448 current_expand.repeat = &c->repeat;
1449 if (current_expand.expand_work_function (e) == FAILURE)
1456 /* Top level subroutine for expanding constructors. We only expand
1457 constructor if they are small enough. */
1460 gfc_expand_constructor (gfc_expr *e)
1462 expand_info expand_save;
1466 f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1473 expand_save = current_expand;
1474 current_expand.new_head = current_expand.new_tail = NULL;
1478 current_expand.expand_work_function = expand;
1480 if (expand_constructor (e->value.constructor) == FAILURE)
1482 gfc_free_constructor (current_expand.new_head);
1487 gfc_free_constructor (e->value.constructor);
1488 e->value.constructor = current_expand.new_head;
1493 current_expand = expand_save;
1499 /* Work function for checking that an element of a constructor is a
1500 constant, after removal of any iteration variables. We return
1501 FAILURE if not so. */
1504 constant_element (gfc_expr *e)
1508 rv = gfc_is_constant_expr (e);
1511 return rv ? SUCCESS : FAILURE;
1515 /* Given an array constructor, determine if the constructor is
1516 constant or not by expanding it and making sure that all elements
1517 are constants. This is a bit of a hack since something like (/ (i,
1518 i=1,100000000) /) will take a while as* opposed to a more clever
1519 function that traverses the expression tree. FIXME. */
1522 gfc_constant_ac (gfc_expr *e)
1524 expand_info expand_save;
1528 expand_save = current_expand;
1529 current_expand.expand_work_function = constant_element;
1531 rc = expand_constructor (e->value.constructor);
1533 current_expand = expand_save;
1541 /* Returns nonzero if an array constructor has been completely
1542 expanded (no iterators) and zero if iterators are present. */
1545 gfc_expanded_ac (gfc_expr *e)
1549 if (e->expr_type == EXPR_ARRAY)
1550 for (p = e->value.constructor; p; p = p->next)
1551 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1558 /*************** Type resolution of array constructors ***************/
1560 /* Recursive array list resolution function. All of the elements must
1561 be of the same type. */
1564 resolve_array_list (gfc_constructor *p)
1570 for (; p; p = p->next)
1572 if (p->iterator != NULL
1573 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1576 if (gfc_resolve_expr (p->expr) == FAILURE)
1583 /* Resolve character array constructor. If it has a specified constant character
1584 length, pad/truncate the elements here; if the length is not specified and
1585 all elements are of compile-time known length, emit an error as this is
1589 gfc_resolve_character_array_constructor (gfc_expr *expr)
1594 gcc_assert (expr->expr_type == EXPR_ARRAY);
1595 gcc_assert (expr->ts.type == BT_CHARACTER);
1597 if (expr->ts.cl == NULL)
1599 for (p = expr->value.constructor; p; p = p->next)
1600 if (p->expr->ts.cl != NULL)
1602 /* Ensure that if there is a char_len around that it is
1603 used; otherwise the middle-end confuses them! */
1604 expr->ts.cl = p->expr->ts.cl;
1608 expr->ts.cl = gfc_get_charlen ();
1609 expr->ts.cl->next = gfc_current_ns->cl_list;
1610 gfc_current_ns->cl_list = expr->ts.cl;
1617 if (expr->ts.cl->length == NULL)
1619 /* Check that all constant string elements have the same length until
1620 we reach the end or find a variable-length one. */
1622 for (p = expr->value.constructor; p; p = p->next)
1624 int current_length = -1;
1626 for (ref = p->expr->ref; ref; ref = ref->next)
1627 if (ref->type == REF_SUBSTRING
1628 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1629 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1632 if (p->expr->expr_type == EXPR_CONSTANT)
1633 current_length = p->expr->value.character.length;
1637 j = mpz_get_ui (ref->u.ss.end->value.integer)
1638 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1639 current_length = (int) j;
1641 else if (p->expr->ts.cl && p->expr->ts.cl->length
1642 && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1645 j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1646 current_length = (int) j;
1651 gcc_assert (current_length != -1);
1653 if (found_length == -1)
1654 found_length = current_length;
1655 else if (found_length != current_length)
1657 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1658 " constructor at %L", found_length, current_length,
1663 gcc_assert (found_length == current_length);
1666 gcc_assert (found_length != -1);
1668 /* Update the character length of the array constructor. */
1669 expr->ts.cl->length = gfc_int_expr (found_length);
1673 /* We've got a character length specified. It should be an integer,
1674 otherwise an error is signalled elsewhere. */
1675 gcc_assert (expr->ts.cl->length);
1677 /* If we've got a constant character length, pad according to this.
1678 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1679 max_length only if they pass. */
1680 gfc_extract_int (expr->ts.cl->length, &found_length);
1682 /* Now pad/truncate the elements accordingly to the specified character
1683 length. This is ok inside this conditional, as in the case above
1684 (without typespec) all elements are verified to have the same length
1686 if (found_length != -1)
1687 for (p = expr->value.constructor; p; p = p->next)
1688 if (p->expr->expr_type == EXPR_CONSTANT)
1690 gfc_expr *cl = NULL;
1691 int current_length = -1;
1694 if (p->expr->ts.cl && p->expr->ts.cl->length)
1696 cl = p->expr->ts.cl->length;
1697 gfc_extract_int (cl, ¤t_length);
1700 /* If gfc_extract_int above set current_length, we implicitly
1701 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1703 has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
1706 || (current_length != -1 && current_length < found_length))
1707 gfc_set_constant_character_len (found_length, p->expr,
1708 has_ts ? -1 : found_length);
1716 /* Resolve all of the expressions in an array list. */
1719 gfc_resolve_array_constructor (gfc_expr *expr)
1723 t = resolve_array_list (expr->value.constructor);
1725 t = gfc_check_constructor_type (expr);
1727 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1728 the call to this function, so we don't need to call it here; if it was
1729 called twice, an error message there would be duplicated. */
1735 /* Copy an iterator structure. */
1737 static gfc_iterator *
1738 copy_iterator (gfc_iterator *src)
1745 dest = gfc_get_iterator ();
1747 dest->var = gfc_copy_expr (src->var);
1748 dest->start = gfc_copy_expr (src->start);
1749 dest->end = gfc_copy_expr (src->end);
1750 dest->step = gfc_copy_expr (src->step);
1756 /* Copy a constructor structure. */
1759 gfc_copy_constructor (gfc_constructor *src)
1761 gfc_constructor *dest;
1762 gfc_constructor *tail;
1771 dest = tail = gfc_get_constructor ();
1774 tail->next = gfc_get_constructor ();
1777 tail->where = src->where;
1778 tail->expr = gfc_copy_expr (src->expr);
1779 tail->iterator = copy_iterator (src->iterator);
1780 mpz_set (tail->n.offset, src->n.offset);
1781 tail->n.component = src->n.component;
1782 mpz_set (tail->repeat, src->repeat);
1790 /* Given an array expression and an element number (starting at zero),
1791 return a pointer to the array element. NULL is returned if the
1792 size of the array has been exceeded. The expression node returned
1793 remains a part of the array and should not be freed. Access is not
1794 efficient at all, but this is another place where things do not
1795 have to be particularly fast. */
1798 gfc_get_array_element (gfc_expr *array, int element)
1800 expand_info expand_save;
1804 expand_save = current_expand;
1805 current_expand.extract_n = element;
1806 current_expand.expand_work_function = extract_element;
1807 current_expand.extracted = NULL;
1808 current_expand.extract_count = 0;
1812 rc = expand_constructor (array->value.constructor);
1813 e = current_expand.extracted;
1814 current_expand = expand_save;
1823 /********* Subroutines for determining the size of an array *********/
1825 /* These are needed just to accommodate RESHAPE(). There are no
1826 diagnostics here, we just return a negative number if something
1830 /* Get the size of single dimension of an array specification. The
1831 array is guaranteed to be one dimensional. */
1834 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1839 if (dimen < 0 || dimen > as->rank - 1)
1840 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1842 if (as->type != AS_EXPLICIT
1843 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1844 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1845 || as->lower[dimen]->ts.type != BT_INTEGER
1846 || as->upper[dimen]->ts.type != BT_INTEGER)
1851 mpz_sub (*result, as->upper[dimen]->value.integer,
1852 as->lower[dimen]->value.integer);
1854 mpz_add_ui (*result, *result, 1);
1861 spec_size (gfc_array_spec *as, mpz_t *result)
1866 mpz_init_set_ui (*result, 1);
1868 for (d = 0; d < as->rank; d++)
1870 if (spec_dimen_size (as, d, &size) == FAILURE)
1872 mpz_clear (*result);
1876 mpz_mul (*result, *result, size);
1884 /* Get the number of elements in an array section. */
1887 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1889 mpz_t upper, lower, stride;
1892 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1893 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1895 switch (ar->dimen_type[dimen])
1899 mpz_set_ui (*result, 1);
1904 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1913 if (ar->start[dimen] == NULL)
1915 if (ar->as->lower[dimen] == NULL
1916 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1918 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1922 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1924 mpz_set (lower, ar->start[dimen]->value.integer);
1927 if (ar->end[dimen] == NULL)
1929 if (ar->as->upper[dimen] == NULL
1930 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1932 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1936 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1938 mpz_set (upper, ar->end[dimen]->value.integer);
1941 if (ar->stride[dimen] == NULL)
1942 mpz_set_ui (stride, 1);
1945 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1947 mpz_set (stride, ar->stride[dimen]->value.integer);
1951 mpz_sub (*result, upper, lower);
1952 mpz_add (*result, *result, stride);
1953 mpz_div (*result, *result, stride);
1955 /* Zero stride caught earlier. */
1956 if (mpz_cmp_ui (*result, 0) < 0)
1957 mpz_set_ui (*result, 0);
1967 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1975 ref_size (gfc_array_ref *ar, mpz_t *result)
1980 mpz_init_set_ui (*result, 1);
1982 for (d = 0; d < ar->dimen; d++)
1984 if (ref_dimen_size (ar, d, &size) == FAILURE)
1986 mpz_clear (*result);
1990 mpz_mul (*result, *result, size);
1998 /* Given an array expression and a dimension, figure out how many
1999 elements it has along that dimension. Returns SUCCESS if we were
2000 able to return a result in the 'result' variable, FAILURE
2004 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2009 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2010 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2012 switch (array->expr_type)
2016 for (ref = array->ref; ref; ref = ref->next)
2018 if (ref->type != REF_ARRAY)
2021 if (ref->u.ar.type == AR_FULL)
2022 return spec_dimen_size (ref->u.ar.as, dimen, result);
2024 if (ref->u.ar.type == AR_SECTION)
2026 for (i = 0; dimen >= 0; i++)
2027 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2030 return ref_dimen_size (&ref->u.ar, i - 1, result);
2034 if (array->shape && array->shape[dimen])
2036 mpz_init_set (*result, array->shape[dimen]);
2040 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
2046 if (array->shape == NULL) {
2047 /* Expressions with rank > 1 should have "shape" properly set */
2048 if ( array->rank != 1 )
2049 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2050 return gfc_array_size(array, result);
2055 if (array->shape == NULL)
2058 mpz_init_set (*result, array->shape[dimen]);
2067 /* Given an array expression, figure out how many elements are in the
2068 array. Returns SUCCESS if this is possible, and sets the 'result'
2069 variable. Otherwise returns FAILURE. */
2072 gfc_array_size (gfc_expr *array, mpz_t *result)
2074 expand_info expand_save;
2079 switch (array->expr_type)
2082 flag = gfc_suppress_error;
2083 gfc_suppress_error = 1;
2085 expand_save = current_expand;
2087 current_expand.count = result;
2088 mpz_init_set_ui (*result, 0);
2090 current_expand.expand_work_function = count_elements;
2093 t = expand_constructor (array->value.constructor);
2094 gfc_suppress_error = flag;
2097 mpz_clear (*result);
2098 current_expand = expand_save;
2102 for (ref = array->ref; ref; ref = ref->next)
2104 if (ref->type != REF_ARRAY)
2107 if (ref->u.ar.type == AR_FULL)
2108 return spec_size (ref->u.ar.as, result);
2110 if (ref->u.ar.type == AR_SECTION)
2111 return ref_size (&ref->u.ar, result);
2114 return spec_size (array->symtree->n.sym->as, result);
2118 if (array->rank == 0 || array->shape == NULL)
2121 mpz_init_set_ui (*result, 1);
2123 for (i = 0; i < array->rank; i++)
2124 mpz_mul (*result, *result, array->shape[i]);
2133 /* Given an array reference, return the shape of the reference in an
2134 array of mpz_t integers. */
2137 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2147 for (; d < ar->as->rank; d++)
2148 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2154 for (i = 0; i < ar->dimen; i++)
2156 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2158 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2171 for (d--; d >= 0; d--)
2172 mpz_clear (shape[d]);
2178 /* Given an array expression, find the array reference structure that
2179 characterizes the reference. */
2182 gfc_find_array_ref (gfc_expr *e)
2186 for (ref = e->ref; ref; ref = ref->next)
2187 if (ref->type == REF_ARRAY
2188 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2192 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2198 /* Find out if an array shape is known at compile time. */
2201 gfc_is_compile_time_shape (gfc_array_spec *as)
2205 if (as->type != AS_EXPLICIT)
2208 for (i = 0; i < as->rank; i++)
2209 if (!gfc_is_constant_expr (as->lower[i])
2210 || !gfc_is_constant_expr (as->upper[i]))