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");
318 if (gfc_match_char (':') == MATCH_NO)
320 *lower = gfc_int_expr (1);
327 if (gfc_match_char ('*') == MATCH_YES)
328 return AS_ASSUMED_SIZE;
330 m = gfc_match_expr (upper);
331 if (m == MATCH_ERROR)
334 return AS_ASSUMED_SHAPE;
340 /* Matches an array specification, incidentally figuring out what sort
344 gfc_match_array_spec (gfc_array_spec **asp)
346 array_type current_type;
350 if (gfc_match_char ('(') != MATCH_YES)
356 as = gfc_get_array_spec ();
358 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
368 current_type = match_array_element_spec (as);
372 if (current_type == AS_UNKNOWN)
374 as->type = current_type;
378 { /* See how current spec meshes with the existing. */
383 if (current_type == AS_ASSUMED_SIZE)
385 as->type = AS_ASSUMED_SIZE;
389 if (current_type == AS_EXPLICIT)
392 gfc_error ("Bad array specification for an explicitly shaped "
397 case AS_ASSUMED_SHAPE:
398 if ((current_type == AS_ASSUMED_SHAPE)
399 || (current_type == AS_DEFERRED))
402 gfc_error ("Bad array specification for assumed shape "
407 if (current_type == AS_DEFERRED)
410 if (current_type == AS_ASSUMED_SHAPE)
412 as->type = AS_ASSUMED_SHAPE;
416 gfc_error ("Bad specification for deferred shape array at %C");
419 case AS_ASSUMED_SIZE:
420 gfc_error ("Bad specification for assumed size array at %C");
424 if (gfc_match_char (')') == MATCH_YES)
427 if (gfc_match_char (',') != MATCH_YES)
429 gfc_error ("Expected another dimension in array declaration at %C");
433 if (as->rank >= GFC_MAX_DIMENSIONS)
435 gfc_error ("Array specification at %C has more than %d dimensions",
443 /* If a lower bounds of an assumed shape array is blank, put in one. */
444 if (as->type == AS_ASSUMED_SHAPE)
446 for (i = 0; i < as->rank; i++)
448 if (as->lower[i] == NULL)
449 as->lower[i] = gfc_int_expr (1);
456 /* Something went wrong. */
457 gfc_free_array_spec (as);
462 /* Given a symbol and an array specification, modify the symbol to
463 have that array specification. The error locus is needed in case
464 something goes wrong. On failure, the caller must free the spec. */
467 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
472 if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
481 /* Copy an array specification. */
484 gfc_copy_array_spec (gfc_array_spec *src)
486 gfc_array_spec *dest;
492 dest = gfc_get_array_spec ();
496 for (i = 0; i < dest->rank; i++)
498 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
499 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
506 /* Returns nonzero if the two expressions are equal. Only handles integer
510 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
512 if (bound1 == NULL || bound2 == NULL
513 || bound1->expr_type != EXPR_CONSTANT
514 || bound2->expr_type != EXPR_CONSTANT
515 || bound1->ts.type != BT_INTEGER
516 || bound2->ts.type != BT_INTEGER)
517 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
519 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
526 /* Compares two array specifications. They must be constant or deferred
530 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
534 if (as1 == NULL && as2 == NULL)
537 if (as1 == NULL || as2 == NULL)
540 if (as1->rank != as2->rank)
546 if (as1->type != as2->type)
549 if (as1->type == AS_EXPLICIT)
550 for (i = 0; i < as1->rank; i++)
552 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
555 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
563 /****************** Array constructor functions ******************/
565 /* Start an array constructor. The constructor starts with zero
566 elements and should be appended to by gfc_append_constructor(). */
569 gfc_start_constructor (bt type, int kind, locus *where)
573 result = gfc_get_expr ();
575 result->expr_type = EXPR_ARRAY;
578 result->ts.type = type;
579 result->ts.kind = kind;
580 result->where = *where;
585 /* Given an array constructor expression, append the new expression
586 node onto the constructor. */
589 gfc_append_constructor (gfc_expr *base, gfc_expr *new)
593 if (base->value.constructor == NULL)
594 base->value.constructor = c = gfc_get_constructor ();
597 c = base->value.constructor;
601 c->next = gfc_get_constructor ();
607 if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind)
608 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
612 /* Given an array constructor expression, insert the new expression's
613 constructor onto the base's one according to the offset. */
616 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
618 gfc_constructor *c, *pre;
622 type = base->expr_type;
624 if (base->value.constructor == NULL)
625 base->value.constructor = c1;
628 c = pre = base->value.constructor;
631 if (type == EXPR_ARRAY)
633 t = mpz_cmp (c->n.offset, c1->n.offset);
641 gfc_error ("duplicated initializer");
662 base->value.constructor = c1;
668 /* Get a new constructor. */
671 gfc_get_constructor (void)
675 c = gfc_getmem (sizeof(gfc_constructor));
679 mpz_init_set_si (c->n.offset, 0);
680 mpz_init_set_si (c->repeat, 0);
685 /* Free chains of gfc_constructor structures. */
688 gfc_free_constructor (gfc_constructor *p)
690 gfc_constructor *next;
700 gfc_free_expr (p->expr);
701 if (p->iterator != NULL)
702 gfc_free_iterator (p->iterator, 1);
703 mpz_clear (p->n.offset);
704 mpz_clear (p->repeat);
710 /* Given an expression node that might be an array constructor and a
711 symbol, make sure that no iterators in this or child constructors
712 use the symbol as an implied-DO iterator. Returns nonzero if a
713 duplicate was found. */
716 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
720 for (; c; c = c->next)
724 if (e->expr_type == EXPR_ARRAY
725 && check_duplicate_iterator (e->value.constructor, master))
728 if (c->iterator == NULL)
731 if (c->iterator->var->symtree->n.sym == master)
733 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
734 "same name", master->name, &c->where);
744 /* Forward declaration because these functions are mutually recursive. */
745 static match match_array_cons_element (gfc_constructor **);
747 /* Match a list of array elements. */
750 match_array_list (gfc_constructor **result)
752 gfc_constructor *p, *head, *tail, *new;
759 old_loc = gfc_current_locus;
761 if (gfc_match_char ('(') == MATCH_NO)
764 memset (&iter, '\0', sizeof (gfc_iterator));
767 m = match_array_cons_element (&head);
773 if (gfc_match_char (',') != MATCH_YES)
781 m = gfc_match_iterator (&iter, 0);
784 if (m == MATCH_ERROR)
787 m = match_array_cons_element (&new);
788 if (m == MATCH_ERROR)
795 goto cleanup; /* Could be a complex constant */
801 if (gfc_match_char (',') != MATCH_YES)
810 if (gfc_match_char (')') != MATCH_YES)
813 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
820 e->expr_type = EXPR_ARRAY;
822 e->value.constructor = head;
824 p = gfc_get_constructor ();
825 p->where = gfc_current_locus;
826 p->iterator = gfc_get_iterator ();
835 gfc_error ("Syntax error in array constructor at %C");
839 gfc_free_constructor (head);
840 gfc_free_iterator (&iter, 0);
841 gfc_current_locus = old_loc;
846 /* Match a single element of an array constructor, which can be a
847 single expression or a list of elements. */
850 match_array_cons_element (gfc_constructor **result)
856 m = match_array_list (result);
860 m = gfc_match_expr (&expr);
864 p = gfc_get_constructor ();
865 p->where = gfc_current_locus;
873 /* Match an array constructor. */
876 gfc_match_array_constructor (gfc_expr **result)
878 gfc_constructor *head, *tail, *new;
883 const char *end_delim;
886 if (gfc_match (" (/") == MATCH_NO)
888 if (gfc_match (" [") == MATCH_NO)
892 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
893 "style array constructors at %C") == FAILURE)
901 where = gfc_current_locus;
905 /* Try to match an optional "type-spec ::" */
906 if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
908 seen_ts = (gfc_match (" ::") == MATCH_YES);
912 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
913 "including type specification at %C") == FAILURE)
919 gfc_current_locus = where;
921 if (gfc_match (end_delim) == MATCH_YES)
927 gfc_error ("Empty array constructor at %C is not allowed");
934 m = match_array_cons_element (&new);
935 if (m == MATCH_ERROR)
947 if (gfc_match_char (',') == MATCH_NO)
951 if (gfc_match (end_delim) == MATCH_NO)
955 expr = gfc_get_expr ();
957 expr->expr_type = EXPR_ARRAY;
959 expr->value.constructor = head;
960 /* Size must be calculated at resolution time. */
965 expr->ts.type = BT_UNKNOWN;
968 expr->ts.cl->length_from_typespec = seen_ts;
977 gfc_error ("Syntax error in array constructor at %C");
980 gfc_free_constructor (head);
986 /************** Check array constructors for correctness **************/
988 /* Given an expression, compare it's type with the type of the current
989 constructor. Returns nonzero if an error was issued. The
990 cons_state variable keeps track of whether the type of the
991 constructor being read or resolved is known to be good, bad or just
994 static gfc_typespec constructor_ts;
996 { CONS_START, CONS_GOOD, CONS_BAD }
1000 check_element_type (gfc_expr *expr, bool convert)
1002 if (cons_state == CONS_BAD)
1003 return 0; /* Suppress further errors */
1005 if (cons_state == CONS_START)
1007 if (expr->ts.type == BT_UNKNOWN)
1008 cons_state = CONS_BAD;
1011 cons_state = CONS_GOOD;
1012 constructor_ts = expr->ts;
1018 if (gfc_compare_types (&constructor_ts, &expr->ts))
1022 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1024 gfc_error ("Element in %s array constructor at %L is %s",
1025 gfc_typename (&constructor_ts), &expr->where,
1026 gfc_typename (&expr->ts));
1028 cons_state = CONS_BAD;
1033 /* Recursive work function for gfc_check_constructor_type(). */
1036 check_constructor_type (gfc_constructor *c, bool convert)
1040 for (; c; c = c->next)
1044 if (e->expr_type == EXPR_ARRAY)
1046 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1052 if (check_element_type (e, convert))
1060 /* Check that all elements of an array constructor are the same type.
1061 On FAILURE, an error has been generated. */
1064 gfc_check_constructor_type (gfc_expr *e)
1068 if (e->ts.type != BT_UNKNOWN)
1070 cons_state = CONS_GOOD;
1071 constructor_ts = e->ts;
1075 cons_state = CONS_START;
1076 gfc_clear_ts (&constructor_ts);
1079 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1080 typespec, and we will now convert the values on the fly. */
1081 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1082 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1083 e->ts = constructor_ts;
1090 typedef struct cons_stack
1092 gfc_iterator *iterator;
1093 struct cons_stack *previous;
1097 static cons_stack *base;
1099 static try check_constructor (gfc_constructor *, try (*) (gfc_expr *));
1101 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1102 that that variable is an iteration variables. */
1105 gfc_check_iter_variable (gfc_expr *expr)
1110 sym = expr->symtree->n.sym;
1112 for (c = base; c; c = c->previous)
1113 if (sym == c->iterator->var->symtree->n.sym)
1120 /* Recursive work function for gfc_check_constructor(). This amounts
1121 to calling the check function for each expression in the
1122 constructor, giving variables with the names of iterators a pass. */
1125 check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *))
1131 for (; c; c = c->next)
1135 if (e->expr_type != EXPR_ARRAY)
1137 if ((*check_function) (e) == FAILURE)
1142 element.previous = base;
1143 element.iterator = c->iterator;
1146 t = check_constructor (e->value.constructor, check_function);
1147 base = element.previous;
1153 /* Nothing went wrong, so all OK. */
1158 /* Checks a constructor to see if it is a particular kind of
1159 expression -- specification, restricted, or initialization as
1160 determined by the check_function. */
1163 gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *))
1165 cons_stack *base_save;
1171 t = check_constructor (expr->value.constructor, check_function);
1179 /**************** Simplification of array constructors ****************/
1181 iterator_stack *iter_stack;
1185 gfc_constructor *new_head, *new_tail;
1186 int extract_count, extract_n;
1187 gfc_expr *extracted;
1191 gfc_component *component;
1194 try (*expand_work_function) (gfc_expr *);
1198 static expand_info current_expand;
1200 static try expand_constructor (gfc_constructor *);
1203 /* Work function that counts the number of elements present in a
1207 count_elements (gfc_expr *e)
1212 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1215 if (gfc_array_size (e, &result) == FAILURE)
1221 mpz_add (*current_expand.count, *current_expand.count, result);
1230 /* Work function that extracts a particular element from an array
1231 constructor, freeing the rest. */
1234 extract_element (gfc_expr *e)
1238 { /* Something unextractable */
1243 if (current_expand.extract_count == current_expand.extract_n)
1244 current_expand.extracted = e;
1248 current_expand.extract_count++;
1253 /* Work function that constructs a new constructor out of the old one,
1254 stringing new elements together. */
1257 expand (gfc_expr *e)
1259 if (current_expand.new_head == NULL)
1260 current_expand.new_head = current_expand.new_tail =
1261 gfc_get_constructor ();
1264 current_expand.new_tail->next = gfc_get_constructor ();
1265 current_expand.new_tail = current_expand.new_tail->next;
1268 current_expand.new_tail->where = e->where;
1269 current_expand.new_tail->expr = e;
1271 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1272 current_expand.new_tail->n.component = current_expand.component;
1273 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1278 /* Given an initialization expression that is a variable reference,
1279 substitute the current value of the iteration variable. */
1282 gfc_simplify_iterator_var (gfc_expr *e)
1286 for (p = iter_stack; p; p = p->prev)
1287 if (e->symtree == p->variable)
1291 return; /* Variable not found */
1293 gfc_replace_expr (e, gfc_int_expr (0));
1295 mpz_set (e->value.integer, p->value);
1301 /* Expand an expression with that is inside of a constructor,
1302 recursing into other constructors if present. */
1305 expand_expr (gfc_expr *e)
1307 if (e->expr_type == EXPR_ARRAY)
1308 return expand_constructor (e->value.constructor);
1310 e = gfc_copy_expr (e);
1312 if (gfc_simplify_expr (e, 1) == FAILURE)
1318 return current_expand.expand_work_function (e);
1323 expand_iterator (gfc_constructor *c)
1325 gfc_expr *start, *end, *step;
1326 iterator_stack frame;
1335 mpz_init (frame.value);
1338 start = gfc_copy_expr (c->iterator->start);
1339 if (gfc_simplify_expr (start, 1) == FAILURE)
1342 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1345 end = gfc_copy_expr (c->iterator->end);
1346 if (gfc_simplify_expr (end, 1) == FAILURE)
1349 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1352 step = gfc_copy_expr (c->iterator->step);
1353 if (gfc_simplify_expr (step, 1) == FAILURE)
1356 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1359 if (mpz_sgn (step->value.integer) == 0)
1361 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1365 /* Calculate the trip count of the loop. */
1366 mpz_sub (trip, end->value.integer, start->value.integer);
1367 mpz_add (trip, trip, step->value.integer);
1368 mpz_tdiv_q (trip, trip, step->value.integer);
1370 mpz_set (frame.value, start->value.integer);
1372 frame.prev = iter_stack;
1373 frame.variable = c->iterator->var->symtree;
1374 iter_stack = &frame;
1376 while (mpz_sgn (trip) > 0)
1378 if (expand_expr (c->expr) == FAILURE)
1381 mpz_add (frame.value, frame.value, step->value.integer);
1382 mpz_sub_ui (trip, trip, 1);
1388 gfc_free_expr (start);
1389 gfc_free_expr (end);
1390 gfc_free_expr (step);
1393 mpz_clear (frame.value);
1395 iter_stack = frame.prev;
1401 /* Expand a constructor into constant constructors without any
1402 iterators, calling the work function for each of the expanded
1403 expressions. The work function needs to either save or free the
1404 passed expression. */
1407 expand_constructor (gfc_constructor *c)
1411 for (; c; c = c->next)
1413 if (c->iterator != NULL)
1415 if (expand_iterator (c) == FAILURE)
1422 if (e->expr_type == EXPR_ARRAY)
1424 if (expand_constructor (e->value.constructor) == FAILURE)
1430 e = gfc_copy_expr (e);
1431 if (gfc_simplify_expr (e, 1) == FAILURE)
1436 current_expand.offset = &c->n.offset;
1437 current_expand.component = c->n.component;
1438 current_expand.repeat = &c->repeat;
1439 if (current_expand.expand_work_function (e) == FAILURE)
1446 /* Top level subroutine for expanding constructors. We only expand
1447 constructor if they are small enough. */
1450 gfc_expand_constructor (gfc_expr *e)
1452 expand_info expand_save;
1456 f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1463 expand_save = current_expand;
1464 current_expand.new_head = current_expand.new_tail = NULL;
1468 current_expand.expand_work_function = expand;
1470 if (expand_constructor (e->value.constructor) == FAILURE)
1472 gfc_free_constructor (current_expand.new_head);
1477 gfc_free_constructor (e->value.constructor);
1478 e->value.constructor = current_expand.new_head;
1483 current_expand = expand_save;
1489 /* Work function for checking that an element of a constructor is a
1490 constant, after removal of any iteration variables. We return
1491 FAILURE if not so. */
1494 constant_element (gfc_expr *e)
1498 rv = gfc_is_constant_expr (e);
1501 return rv ? SUCCESS : FAILURE;
1505 /* Given an array constructor, determine if the constructor is
1506 constant or not by expanding it and making sure that all elements
1507 are constants. This is a bit of a hack since something like (/ (i,
1508 i=1,100000000) /) will take a while as* opposed to a more clever
1509 function that traverses the expression tree. FIXME. */
1512 gfc_constant_ac (gfc_expr *e)
1514 expand_info expand_save;
1518 expand_save = current_expand;
1519 current_expand.expand_work_function = constant_element;
1521 rc = expand_constructor (e->value.constructor);
1523 current_expand = expand_save;
1531 /* Returns nonzero if an array constructor has been completely
1532 expanded (no iterators) and zero if iterators are present. */
1535 gfc_expanded_ac (gfc_expr *e)
1539 if (e->expr_type == EXPR_ARRAY)
1540 for (p = e->value.constructor; p; p = p->next)
1541 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1548 /*************** Type resolution of array constructors ***************/
1550 /* Recursive array list resolution function. All of the elements must
1551 be of the same type. */
1554 resolve_array_list (gfc_constructor *p)
1560 for (; p; p = p->next)
1562 if (p->iterator != NULL
1563 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1566 if (gfc_resolve_expr (p->expr) == FAILURE)
1573 /* Resolve character array constructor. If it is a constant character array and
1574 not specified character length, update character length to the maximum of
1575 its element constructors' length. For arrays with fixed length, pad the
1576 elements as necessary with needed_length. */
1579 gfc_resolve_character_array_constructor (gfc_expr *expr)
1583 bool generated_length;
1585 gcc_assert (expr->expr_type == EXPR_ARRAY);
1586 gcc_assert (expr->ts.type == BT_CHARACTER);
1590 if (expr->ts.cl == NULL)
1592 for (p = expr->value.constructor; p; p = p->next)
1593 if (p->expr->ts.cl != NULL)
1595 /* Ensure that if there is a char_len around that it is
1596 used; otherwise the middle-end confuses them! */
1597 expr->ts.cl = p->expr->ts.cl;
1601 expr->ts.cl = gfc_get_charlen ();
1602 expr->ts.cl->next = gfc_current_ns->cl_list;
1603 gfc_current_ns->cl_list = expr->ts.cl;
1608 generated_length = false;
1609 if (expr->ts.cl->length == NULL)
1611 /* Find the maximum length of the elements. Do nothing for variable
1612 array constructor, unless the character length is constant or
1613 there is a constant substring reference. */
1615 for (p = expr->value.constructor; p; p = p->next)
1618 for (ref = p->expr->ref; ref; ref = ref->next)
1619 if (ref->type == REF_SUBSTRING
1620 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1621 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1624 if (p->expr->expr_type == EXPR_CONSTANT)
1625 max_length = MAX (p->expr->value.character.length, max_length);
1629 j = mpz_get_ui (ref->u.ss.end->value.integer)
1630 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1631 max_length = MAX ((int) j, max_length);
1633 else if (p->expr->ts.cl && p->expr->ts.cl->length
1634 && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1637 j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1638 max_length = MAX ((int) j, max_length);
1644 if (max_length != -1)
1646 /* Update the character length of the array constructor. */
1647 expr->ts.cl->length = gfc_int_expr (max_length);
1648 generated_length = true;
1649 /* Real update follows below. */
1654 /* We've got a character length specified. It should be an integer,
1655 otherwise an error is signalled elsewhere. */
1656 gcc_assert (expr->ts.cl->length);
1658 /* If we've got a constant character length, pad according to this.
1659 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1660 max_length only if they pass. */
1661 gfc_extract_int (expr->ts.cl->length, &max_length);
1664 /* Found a length to update to, do it for all element strings shorter than
1665 the target length. */
1666 if (max_length != -1)
1668 for (p = expr->value.constructor; p; p = p->next)
1669 if (p->expr->expr_type == EXPR_CONSTANT)
1671 gfc_expr *cl = NULL;
1672 int current_length = -1;
1674 if (p->expr->ts.cl && p->expr->ts.cl->length)
1676 cl = p->expr->ts.cl->length;
1677 gfc_extract_int (cl, ¤t_length);
1680 /* If gfc_extract_int above set current_length, we implicitly
1681 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1683 if (generated_length || ! cl
1684 || (current_length != -1 && current_length < max_length))
1685 gfc_set_constant_character_len (max_length, p->expr, true);
1691 /* Resolve all of the expressions in an array list. */
1694 gfc_resolve_array_constructor (gfc_expr *expr)
1698 t = resolve_array_list (expr->value.constructor);
1700 t = gfc_check_constructor_type (expr);
1701 if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
1702 gfc_resolve_character_array_constructor (expr);
1708 /* Copy an iterator structure. */
1710 static gfc_iterator *
1711 copy_iterator (gfc_iterator *src)
1718 dest = gfc_get_iterator ();
1720 dest->var = gfc_copy_expr (src->var);
1721 dest->start = gfc_copy_expr (src->start);
1722 dest->end = gfc_copy_expr (src->end);
1723 dest->step = gfc_copy_expr (src->step);
1729 /* Copy a constructor structure. */
1732 gfc_copy_constructor (gfc_constructor *src)
1734 gfc_constructor *dest;
1735 gfc_constructor *tail;
1744 dest = tail = gfc_get_constructor ();
1747 tail->next = gfc_get_constructor ();
1750 tail->where = src->where;
1751 tail->expr = gfc_copy_expr (src->expr);
1752 tail->iterator = copy_iterator (src->iterator);
1753 mpz_set (tail->n.offset, src->n.offset);
1754 tail->n.component = src->n.component;
1755 mpz_set (tail->repeat, src->repeat);
1763 /* Given an array expression and an element number (starting at zero),
1764 return a pointer to the array element. NULL is returned if the
1765 size of the array has been exceeded. The expression node returned
1766 remains a part of the array and should not be freed. Access is not
1767 efficient at all, but this is another place where things do not
1768 have to be particularly fast. */
1771 gfc_get_array_element (gfc_expr *array, int element)
1773 expand_info expand_save;
1777 expand_save = current_expand;
1778 current_expand.extract_n = element;
1779 current_expand.expand_work_function = extract_element;
1780 current_expand.extracted = NULL;
1781 current_expand.extract_count = 0;
1785 rc = expand_constructor (array->value.constructor);
1786 e = current_expand.extracted;
1787 current_expand = expand_save;
1796 /********* Subroutines for determining the size of an array *********/
1798 /* These are needed just to accommodate RESHAPE(). There are no
1799 diagnostics here, we just return a negative number if something
1803 /* Get the size of single dimension of an array specification. The
1804 array is guaranteed to be one dimensional. */
1807 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1812 if (dimen < 0 || dimen > as->rank - 1)
1813 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1815 if (as->type != AS_EXPLICIT
1816 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1817 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1818 || as->lower[dimen]->ts.type != BT_INTEGER
1819 || as->upper[dimen]->ts.type != BT_INTEGER)
1824 mpz_sub (*result, as->upper[dimen]->value.integer,
1825 as->lower[dimen]->value.integer);
1827 mpz_add_ui (*result, *result, 1);
1834 spec_size (gfc_array_spec *as, mpz_t *result)
1839 mpz_init_set_ui (*result, 1);
1841 for (d = 0; d < as->rank; d++)
1843 if (spec_dimen_size (as, d, &size) == FAILURE)
1845 mpz_clear (*result);
1849 mpz_mul (*result, *result, size);
1857 /* Get the number of elements in an array section. */
1860 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1862 mpz_t upper, lower, stride;
1865 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1866 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1868 switch (ar->dimen_type[dimen])
1872 mpz_set_ui (*result, 1);
1877 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1886 if (ar->start[dimen] == NULL)
1888 if (ar->as->lower[dimen] == NULL
1889 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1891 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1895 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1897 mpz_set (lower, ar->start[dimen]->value.integer);
1900 if (ar->end[dimen] == NULL)
1902 if (ar->as->upper[dimen] == NULL
1903 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1905 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1909 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1911 mpz_set (upper, ar->end[dimen]->value.integer);
1914 if (ar->stride[dimen] == NULL)
1915 mpz_set_ui (stride, 1);
1918 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1920 mpz_set (stride, ar->stride[dimen]->value.integer);
1924 mpz_sub (*result, upper, lower);
1925 mpz_add (*result, *result, stride);
1926 mpz_div (*result, *result, stride);
1928 /* Zero stride caught earlier. */
1929 if (mpz_cmp_ui (*result, 0) < 0)
1930 mpz_set_ui (*result, 0);
1940 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1948 ref_size (gfc_array_ref *ar, mpz_t *result)
1953 mpz_init_set_ui (*result, 1);
1955 for (d = 0; d < ar->dimen; d++)
1957 if (ref_dimen_size (ar, d, &size) == FAILURE)
1959 mpz_clear (*result);
1963 mpz_mul (*result, *result, size);
1971 /* Given an array expression and a dimension, figure out how many
1972 elements it has along that dimension. Returns SUCCESS if we were
1973 able to return a result in the 'result' variable, FAILURE
1977 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
1982 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1983 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1985 switch (array->expr_type)
1989 for (ref = array->ref; ref; ref = ref->next)
1991 if (ref->type != REF_ARRAY)
1994 if (ref->u.ar.type == AR_FULL)
1995 return spec_dimen_size (ref->u.ar.as, dimen, result);
1997 if (ref->u.ar.type == AR_SECTION)
1999 for (i = 0; dimen >= 0; i++)
2000 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2003 return ref_dimen_size (&ref->u.ar, i - 1, result);
2007 if (array->shape && array->shape[dimen])
2009 mpz_init_set (*result, array->shape[dimen]);
2013 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
2019 if (array->shape == NULL) {
2020 /* Expressions with rank > 1 should have "shape" properly set */
2021 if ( array->rank != 1 )
2022 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2023 return gfc_array_size(array, result);
2028 if (array->shape == NULL)
2031 mpz_init_set (*result, array->shape[dimen]);
2040 /* Given an array expression, figure out how many elements are in the
2041 array. Returns SUCCESS if this is possible, and sets the 'result'
2042 variable. Otherwise returns FAILURE. */
2045 gfc_array_size (gfc_expr *array, mpz_t *result)
2047 expand_info expand_save;
2052 switch (array->expr_type)
2055 flag = gfc_suppress_error;
2056 gfc_suppress_error = 1;
2058 expand_save = current_expand;
2060 current_expand.count = result;
2061 mpz_init_set_ui (*result, 0);
2063 current_expand.expand_work_function = count_elements;
2066 t = expand_constructor (array->value.constructor);
2067 gfc_suppress_error = flag;
2070 mpz_clear (*result);
2071 current_expand = expand_save;
2075 for (ref = array->ref; ref; ref = ref->next)
2077 if (ref->type != REF_ARRAY)
2080 if (ref->u.ar.type == AR_FULL)
2081 return spec_size (ref->u.ar.as, result);
2083 if (ref->u.ar.type == AR_SECTION)
2084 return ref_size (&ref->u.ar, result);
2087 return spec_size (array->symtree->n.sym->as, result);
2091 if (array->rank == 0 || array->shape == NULL)
2094 mpz_init_set_ui (*result, 1);
2096 for (i = 0; i < array->rank; i++)
2097 mpz_mul (*result, *result, array->shape[i]);
2106 /* Given an array reference, return the shape of the reference in an
2107 array of mpz_t integers. */
2110 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2120 for (; d < ar->as->rank; d++)
2121 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2127 for (i = 0; i < ar->dimen; i++)
2129 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2131 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2144 for (d--; d >= 0; d--)
2145 mpz_clear (shape[d]);
2151 /* Given an array expression, find the array reference structure that
2152 characterizes the reference. */
2155 gfc_find_array_ref (gfc_expr *e)
2159 for (ref = e->ref; ref; ref = ref->next)
2160 if (ref->type == REF_ARRAY
2161 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2165 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2171 /* Find out if an array shape is known at compile time. */
2174 gfc_is_compile_time_shape (gfc_array_spec *as)
2178 if (as->type != AS_EXPLICIT)
2181 for (i = 0; i < as->rank; i++)
2182 if (!gfc_is_constant_expr (as->lower[i])
2183 || !gfc_is_constant_expr (as->upper[i]))