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",
441 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
442 "specification at %C with more than 7 dimensions")
449 /* If a lower bounds of an assumed shape array is blank, put in one. */
450 if (as->type == AS_ASSUMED_SHAPE)
452 for (i = 0; i < as->rank; i++)
454 if (as->lower[i] == NULL)
455 as->lower[i] = gfc_int_expr (1);
462 /* Something went wrong. */
463 gfc_free_array_spec (as);
468 /* Given a symbol and an array specification, modify the symbol to
469 have that array specification. The error locus is needed in case
470 something goes wrong. On failure, the caller must free the spec. */
473 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
478 if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
487 /* Copy an array specification. */
490 gfc_copy_array_spec (gfc_array_spec *src)
492 gfc_array_spec *dest;
498 dest = gfc_get_array_spec ();
502 for (i = 0; i < dest->rank; i++)
504 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
505 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
512 /* Returns nonzero if the two expressions are equal. Only handles integer
516 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
518 if (bound1 == NULL || bound2 == NULL
519 || bound1->expr_type != EXPR_CONSTANT
520 || bound2->expr_type != EXPR_CONSTANT
521 || bound1->ts.type != BT_INTEGER
522 || bound2->ts.type != BT_INTEGER)
523 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
525 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
532 /* Compares two array specifications. They must be constant or deferred
536 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
540 if (as1 == NULL && as2 == NULL)
543 if (as1 == NULL || as2 == NULL)
546 if (as1->rank != as2->rank)
552 if (as1->type != as2->type)
555 if (as1->type == AS_EXPLICIT)
556 for (i = 0; i < as1->rank; i++)
558 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
561 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
569 /****************** Array constructor functions ******************/
571 /* Start an array constructor. The constructor starts with zero
572 elements and should be appended to by gfc_append_constructor(). */
575 gfc_start_constructor (bt type, int kind, locus *where)
579 result = gfc_get_expr ();
581 result->expr_type = EXPR_ARRAY;
584 result->ts.type = type;
585 result->ts.kind = kind;
586 result->where = *where;
591 /* Given an array constructor expression, append the new expression
592 node onto the constructor. */
595 gfc_append_constructor (gfc_expr *base, gfc_expr *new)
599 if (base->value.constructor == NULL)
600 base->value.constructor = c = gfc_get_constructor ();
603 c = base->value.constructor;
607 c->next = gfc_get_constructor ();
613 if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind)
614 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
618 /* Given an array constructor expression, insert the new expression's
619 constructor onto the base's one according to the offset. */
622 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
624 gfc_constructor *c, *pre;
628 type = base->expr_type;
630 if (base->value.constructor == NULL)
631 base->value.constructor = c1;
634 c = pre = base->value.constructor;
637 if (type == EXPR_ARRAY)
639 t = mpz_cmp (c->n.offset, c1->n.offset);
647 gfc_error ("duplicated initializer");
668 base->value.constructor = c1;
674 /* Get a new constructor. */
677 gfc_get_constructor (void)
681 c = XCNEW (gfc_constructor);
685 mpz_init_set_si (c->n.offset, 0);
686 mpz_init_set_si (c->repeat, 0);
691 /* Free chains of gfc_constructor structures. */
694 gfc_free_constructor (gfc_constructor *p)
696 gfc_constructor *next;
706 gfc_free_expr (p->expr);
707 if (p->iterator != NULL)
708 gfc_free_iterator (p->iterator, 1);
709 mpz_clear (p->n.offset);
710 mpz_clear (p->repeat);
716 /* Given an expression node that might be an array constructor and a
717 symbol, make sure that no iterators in this or child constructors
718 use the symbol as an implied-DO iterator. Returns nonzero if a
719 duplicate was found. */
722 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
726 for (; c; c = c->next)
730 if (e->expr_type == EXPR_ARRAY
731 && check_duplicate_iterator (e->value.constructor, master))
734 if (c->iterator == NULL)
737 if (c->iterator->var->symtree->n.sym == master)
739 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
740 "same name", master->name, &c->where);
750 /* Forward declaration because these functions are mutually recursive. */
751 static match match_array_cons_element (gfc_constructor **);
753 /* Match a list of array elements. */
756 match_array_list (gfc_constructor **result)
758 gfc_constructor *p, *head, *tail, *new;
765 old_loc = gfc_current_locus;
767 if (gfc_match_char ('(') == MATCH_NO)
770 memset (&iter, '\0', sizeof (gfc_iterator));
773 m = match_array_cons_element (&head);
779 if (gfc_match_char (',') != MATCH_YES)
787 m = gfc_match_iterator (&iter, 0);
790 if (m == MATCH_ERROR)
793 m = match_array_cons_element (&new);
794 if (m == MATCH_ERROR)
801 goto cleanup; /* Could be a complex constant */
807 if (gfc_match_char (',') != MATCH_YES)
816 if (gfc_match_char (')') != MATCH_YES)
819 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
826 e->expr_type = EXPR_ARRAY;
828 e->value.constructor = head;
830 p = gfc_get_constructor ();
831 p->where = gfc_current_locus;
832 p->iterator = gfc_get_iterator ();
841 gfc_error ("Syntax error in array constructor at %C");
845 gfc_free_constructor (head);
846 gfc_free_iterator (&iter, 0);
847 gfc_current_locus = old_loc;
852 /* Match a single element of an array constructor, which can be a
853 single expression or a list of elements. */
856 match_array_cons_element (gfc_constructor **result)
862 m = match_array_list (result);
866 m = gfc_match_expr (&expr);
870 p = gfc_get_constructor ();
871 p->where = gfc_current_locus;
879 /* Match an array constructor. */
882 gfc_match_array_constructor (gfc_expr **result)
884 gfc_constructor *head, *tail, *new;
889 const char *end_delim;
892 if (gfc_match (" (/") == MATCH_NO)
894 if (gfc_match (" [") == MATCH_NO)
898 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
899 "style array constructors at %C") == FAILURE)
907 where = gfc_current_locus;
911 /* Try to match an optional "type-spec ::" */
912 if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
914 seen_ts = (gfc_match (" ::") == MATCH_YES);
918 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
919 "including type specification at %C") == FAILURE)
925 gfc_current_locus = where;
927 if (gfc_match (end_delim) == MATCH_YES)
933 gfc_error ("Empty array constructor at %C is not allowed");
940 m = match_array_cons_element (&new);
941 if (m == MATCH_ERROR)
953 if (gfc_match_char (',') == MATCH_NO)
957 if (gfc_match (end_delim) == MATCH_NO)
961 expr = gfc_get_expr ();
963 expr->expr_type = EXPR_ARRAY;
965 expr->value.constructor = head;
966 /* Size must be calculated at resolution time. */
971 expr->ts.type = BT_UNKNOWN;
974 expr->ts.cl->length_from_typespec = seen_ts;
983 gfc_error ("Syntax error in array constructor at %C");
986 gfc_free_constructor (head);
992 /************** Check array constructors for correctness **************/
994 /* Given an expression, compare it's type with the type of the current
995 constructor. Returns nonzero if an error was issued. The
996 cons_state variable keeps track of whether the type of the
997 constructor being read or resolved is known to be good, bad or just
1000 static gfc_typespec constructor_ts;
1002 { CONS_START, CONS_GOOD, CONS_BAD }
1006 check_element_type (gfc_expr *expr, bool convert)
1008 if (cons_state == CONS_BAD)
1009 return 0; /* Suppress further errors */
1011 if (cons_state == CONS_START)
1013 if (expr->ts.type == BT_UNKNOWN)
1014 cons_state = CONS_BAD;
1017 cons_state = CONS_GOOD;
1018 constructor_ts = expr->ts;
1024 if (gfc_compare_types (&constructor_ts, &expr->ts))
1028 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1030 gfc_error ("Element in %s array constructor at %L is %s",
1031 gfc_typename (&constructor_ts), &expr->where,
1032 gfc_typename (&expr->ts));
1034 cons_state = CONS_BAD;
1039 /* Recursive work function for gfc_check_constructor_type(). */
1042 check_constructor_type (gfc_constructor *c, bool convert)
1046 for (; c; c = c->next)
1050 if (e->expr_type == EXPR_ARRAY)
1052 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1058 if (check_element_type (e, convert))
1066 /* Check that all elements of an array constructor are the same type.
1067 On FAILURE, an error has been generated. */
1070 gfc_check_constructor_type (gfc_expr *e)
1074 if (e->ts.type != BT_UNKNOWN)
1076 cons_state = CONS_GOOD;
1077 constructor_ts = e->ts;
1081 cons_state = CONS_START;
1082 gfc_clear_ts (&constructor_ts);
1085 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1086 typespec, and we will now convert the values on the fly. */
1087 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1088 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1089 e->ts = constructor_ts;
1096 typedef struct cons_stack
1098 gfc_iterator *iterator;
1099 struct cons_stack *previous;
1103 static cons_stack *base;
1105 static try check_constructor (gfc_constructor *, try (*) (gfc_expr *));
1107 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1108 that that variable is an iteration variables. */
1111 gfc_check_iter_variable (gfc_expr *expr)
1116 sym = expr->symtree->n.sym;
1118 for (c = base; c; c = c->previous)
1119 if (sym == c->iterator->var->symtree->n.sym)
1126 /* Recursive work function for gfc_check_constructor(). This amounts
1127 to calling the check function for each expression in the
1128 constructor, giving variables with the names of iterators a pass. */
1131 check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *))
1137 for (; c; c = c->next)
1141 if (e->expr_type != EXPR_ARRAY)
1143 if ((*check_function) (e) == FAILURE)
1148 element.previous = base;
1149 element.iterator = c->iterator;
1152 t = check_constructor (e->value.constructor, check_function);
1153 base = element.previous;
1159 /* Nothing went wrong, so all OK. */
1164 /* Checks a constructor to see if it is a particular kind of
1165 expression -- specification, restricted, or initialization as
1166 determined by the check_function. */
1169 gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *))
1171 cons_stack *base_save;
1177 t = check_constructor (expr->value.constructor, check_function);
1185 /**************** Simplification of array constructors ****************/
1187 iterator_stack *iter_stack;
1191 gfc_constructor *new_head, *new_tail;
1192 int extract_count, extract_n;
1193 gfc_expr *extracted;
1197 gfc_component *component;
1200 try (*expand_work_function) (gfc_expr *);
1204 static expand_info current_expand;
1206 static try expand_constructor (gfc_constructor *);
1209 /* Work function that counts the number of elements present in a
1213 count_elements (gfc_expr *e)
1218 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1221 if (gfc_array_size (e, &result) == FAILURE)
1227 mpz_add (*current_expand.count, *current_expand.count, result);
1236 /* Work function that extracts a particular element from an array
1237 constructor, freeing the rest. */
1240 extract_element (gfc_expr *e)
1244 { /* Something unextractable */
1249 if (current_expand.extract_count == current_expand.extract_n)
1250 current_expand.extracted = e;
1254 current_expand.extract_count++;
1259 /* Work function that constructs a new constructor out of the old one,
1260 stringing new elements together. */
1263 expand (gfc_expr *e)
1265 if (current_expand.new_head == NULL)
1266 current_expand.new_head = current_expand.new_tail =
1267 gfc_get_constructor ();
1270 current_expand.new_tail->next = gfc_get_constructor ();
1271 current_expand.new_tail = current_expand.new_tail->next;
1274 current_expand.new_tail->where = e->where;
1275 current_expand.new_tail->expr = e;
1277 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1278 current_expand.new_tail->n.component = current_expand.component;
1279 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1284 /* Given an initialization expression that is a variable reference,
1285 substitute the current value of the iteration variable. */
1288 gfc_simplify_iterator_var (gfc_expr *e)
1292 for (p = iter_stack; p; p = p->prev)
1293 if (e->symtree == p->variable)
1297 return; /* Variable not found */
1299 gfc_replace_expr (e, gfc_int_expr (0));
1301 mpz_set (e->value.integer, p->value);
1307 /* Expand an expression with that is inside of a constructor,
1308 recursing into other constructors if present. */
1311 expand_expr (gfc_expr *e)
1313 if (e->expr_type == EXPR_ARRAY)
1314 return expand_constructor (e->value.constructor);
1316 e = gfc_copy_expr (e);
1318 if (gfc_simplify_expr (e, 1) == FAILURE)
1324 return current_expand.expand_work_function (e);
1329 expand_iterator (gfc_constructor *c)
1331 gfc_expr *start, *end, *step;
1332 iterator_stack frame;
1341 mpz_init (frame.value);
1344 start = gfc_copy_expr (c->iterator->start);
1345 if (gfc_simplify_expr (start, 1) == FAILURE)
1348 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1351 end = gfc_copy_expr (c->iterator->end);
1352 if (gfc_simplify_expr (end, 1) == FAILURE)
1355 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1358 step = gfc_copy_expr (c->iterator->step);
1359 if (gfc_simplify_expr (step, 1) == FAILURE)
1362 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1365 if (mpz_sgn (step->value.integer) == 0)
1367 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1371 /* Calculate the trip count of the loop. */
1372 mpz_sub (trip, end->value.integer, start->value.integer);
1373 mpz_add (trip, trip, step->value.integer);
1374 mpz_tdiv_q (trip, trip, step->value.integer);
1376 mpz_set (frame.value, start->value.integer);
1378 frame.prev = iter_stack;
1379 frame.variable = c->iterator->var->symtree;
1380 iter_stack = &frame;
1382 while (mpz_sgn (trip) > 0)
1384 if (expand_expr (c->expr) == FAILURE)
1387 mpz_add (frame.value, frame.value, step->value.integer);
1388 mpz_sub_ui (trip, trip, 1);
1394 gfc_free_expr (start);
1395 gfc_free_expr (end);
1396 gfc_free_expr (step);
1399 mpz_clear (frame.value);
1401 iter_stack = frame.prev;
1407 /* Expand a constructor into constant constructors without any
1408 iterators, calling the work function for each of the expanded
1409 expressions. The work function needs to either save or free the
1410 passed expression. */
1413 expand_constructor (gfc_constructor *c)
1417 for (; c; c = c->next)
1419 if (c->iterator != NULL)
1421 if (expand_iterator (c) == FAILURE)
1428 if (e->expr_type == EXPR_ARRAY)
1430 if (expand_constructor (e->value.constructor) == FAILURE)
1436 e = gfc_copy_expr (e);
1437 if (gfc_simplify_expr (e, 1) == FAILURE)
1442 current_expand.offset = &c->n.offset;
1443 current_expand.component = c->n.component;
1444 current_expand.repeat = &c->repeat;
1445 if (current_expand.expand_work_function (e) == FAILURE)
1452 /* Top level subroutine for expanding constructors. We only expand
1453 constructor if they are small enough. */
1456 gfc_expand_constructor (gfc_expr *e)
1458 expand_info expand_save;
1462 f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1469 expand_save = current_expand;
1470 current_expand.new_head = current_expand.new_tail = NULL;
1474 current_expand.expand_work_function = expand;
1476 if (expand_constructor (e->value.constructor) == FAILURE)
1478 gfc_free_constructor (current_expand.new_head);
1483 gfc_free_constructor (e->value.constructor);
1484 e->value.constructor = current_expand.new_head;
1489 current_expand = expand_save;
1495 /* Work function for checking that an element of a constructor is a
1496 constant, after removal of any iteration variables. We return
1497 FAILURE if not so. */
1500 constant_element (gfc_expr *e)
1504 rv = gfc_is_constant_expr (e);
1507 return rv ? SUCCESS : FAILURE;
1511 /* Given an array constructor, determine if the constructor is
1512 constant or not by expanding it and making sure that all elements
1513 are constants. This is a bit of a hack since something like (/ (i,
1514 i=1,100000000) /) will take a while as* opposed to a more clever
1515 function that traverses the expression tree. FIXME. */
1518 gfc_constant_ac (gfc_expr *e)
1520 expand_info expand_save;
1524 expand_save = current_expand;
1525 current_expand.expand_work_function = constant_element;
1527 rc = expand_constructor (e->value.constructor);
1529 current_expand = expand_save;
1537 /* Returns nonzero if an array constructor has been completely
1538 expanded (no iterators) and zero if iterators are present. */
1541 gfc_expanded_ac (gfc_expr *e)
1545 if (e->expr_type == EXPR_ARRAY)
1546 for (p = e->value.constructor; p; p = p->next)
1547 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1554 /*************** Type resolution of array constructors ***************/
1556 /* Recursive array list resolution function. All of the elements must
1557 be of the same type. */
1560 resolve_array_list (gfc_constructor *p)
1566 for (; p; p = p->next)
1568 if (p->iterator != NULL
1569 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1572 if (gfc_resolve_expr (p->expr) == FAILURE)
1579 /* Resolve character array constructor. If it has a specified constant character
1580 length, pad/trunkate the elements here; if the length is not specified and
1581 all elements are of compile-time known length, emit an error as this is
1585 gfc_resolve_character_array_constructor (gfc_expr *expr)
1590 gcc_assert (expr->expr_type == EXPR_ARRAY);
1591 gcc_assert (expr->ts.type == BT_CHARACTER);
1593 if (expr->ts.cl == NULL)
1595 for (p = expr->value.constructor; p; p = p->next)
1596 if (p->expr->ts.cl != NULL)
1598 /* Ensure that if there is a char_len around that it is
1599 used; otherwise the middle-end confuses them! */
1600 expr->ts.cl = p->expr->ts.cl;
1604 expr->ts.cl = gfc_get_charlen ();
1605 expr->ts.cl->next = gfc_current_ns->cl_list;
1606 gfc_current_ns->cl_list = expr->ts.cl;
1613 if (expr->ts.cl->length == NULL)
1615 /* Check that all constant string elements have the same length until
1616 we reach the end or find a variable-length one. */
1618 for (p = expr->value.constructor; p; p = p->next)
1620 int current_length = -1;
1622 for (ref = p->expr->ref; ref; ref = ref->next)
1623 if (ref->type == REF_SUBSTRING
1624 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1625 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1628 if (p->expr->expr_type == EXPR_CONSTANT)
1629 current_length = p->expr->value.character.length;
1633 j = mpz_get_ui (ref->u.ss.end->value.integer)
1634 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1635 current_length = (int) j;
1637 else if (p->expr->ts.cl && p->expr->ts.cl->length
1638 && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1641 j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1642 current_length = (int) j;
1647 gcc_assert (current_length != -1);
1649 if (found_length == -1)
1650 found_length = current_length;
1651 else if (found_length != current_length)
1653 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1654 " constructor at %L", found_length, current_length,
1659 gcc_assert (found_length == current_length);
1662 gcc_assert (found_length != -1);
1664 /* Update the character length of the array constructor. */
1665 expr->ts.cl->length = gfc_int_expr (found_length);
1669 /* We've got a character length specified. It should be an integer,
1670 otherwise an error is signalled elsewhere. */
1671 gcc_assert (expr->ts.cl->length);
1673 /* If we've got a constant character length, pad according to this.
1674 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1675 max_length only if they pass. */
1676 gfc_extract_int (expr->ts.cl->length, &found_length);
1678 /* Now pad/trunkate the elements accordingly to the specified character
1679 length. This is ok inside this conditional, as in the case above
1680 (without typespec) all elements are verified to have the same length
1682 if (found_length != -1)
1683 for (p = expr->value.constructor; p; p = p->next)
1684 if (p->expr->expr_type == EXPR_CONSTANT)
1686 gfc_expr *cl = NULL;
1687 int current_length = -1;
1690 if (p->expr->ts.cl && p->expr->ts.cl->length)
1692 cl = p->expr->ts.cl->length;
1693 gfc_extract_int (cl, ¤t_length);
1696 /* If gfc_extract_int above set current_length, we implicitly
1697 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1699 has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
1702 || (current_length != -1 && current_length < found_length))
1703 gfc_set_constant_character_len (found_length, p->expr,
1704 has_ts ? -1 : found_length);
1712 /* Resolve all of the expressions in an array list. */
1715 gfc_resolve_array_constructor (gfc_expr *expr)
1719 t = resolve_array_list (expr->value.constructor);
1721 t = gfc_check_constructor_type (expr);
1723 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1724 the call to this function, so we don't need to call it here; if it was
1725 called twice, an error message there would be duplicated. */
1731 /* Copy an iterator structure. */
1733 static gfc_iterator *
1734 copy_iterator (gfc_iterator *src)
1741 dest = gfc_get_iterator ();
1743 dest->var = gfc_copy_expr (src->var);
1744 dest->start = gfc_copy_expr (src->start);
1745 dest->end = gfc_copy_expr (src->end);
1746 dest->step = gfc_copy_expr (src->step);
1752 /* Copy a constructor structure. */
1755 gfc_copy_constructor (gfc_constructor *src)
1757 gfc_constructor *dest;
1758 gfc_constructor *tail;
1767 dest = tail = gfc_get_constructor ();
1770 tail->next = gfc_get_constructor ();
1773 tail->where = src->where;
1774 tail->expr = gfc_copy_expr (src->expr);
1775 tail->iterator = copy_iterator (src->iterator);
1776 mpz_set (tail->n.offset, src->n.offset);
1777 tail->n.component = src->n.component;
1778 mpz_set (tail->repeat, src->repeat);
1786 /* Given an array expression and an element number (starting at zero),
1787 return a pointer to the array element. NULL is returned if the
1788 size of the array has been exceeded. The expression node returned
1789 remains a part of the array and should not be freed. Access is not
1790 efficient at all, but this is another place where things do not
1791 have to be particularly fast. */
1794 gfc_get_array_element (gfc_expr *array, int element)
1796 expand_info expand_save;
1800 expand_save = current_expand;
1801 current_expand.extract_n = element;
1802 current_expand.expand_work_function = extract_element;
1803 current_expand.extracted = NULL;
1804 current_expand.extract_count = 0;
1808 rc = expand_constructor (array->value.constructor);
1809 e = current_expand.extracted;
1810 current_expand = expand_save;
1819 /********* Subroutines for determining the size of an array *********/
1821 /* These are needed just to accommodate RESHAPE(). There are no
1822 diagnostics here, we just return a negative number if something
1826 /* Get the size of single dimension of an array specification. The
1827 array is guaranteed to be one dimensional. */
1830 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1835 if (dimen < 0 || dimen > as->rank - 1)
1836 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1838 if (as->type != AS_EXPLICIT
1839 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1840 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1841 || as->lower[dimen]->ts.type != BT_INTEGER
1842 || as->upper[dimen]->ts.type != BT_INTEGER)
1847 mpz_sub (*result, as->upper[dimen]->value.integer,
1848 as->lower[dimen]->value.integer);
1850 mpz_add_ui (*result, *result, 1);
1857 spec_size (gfc_array_spec *as, mpz_t *result)
1862 mpz_init_set_ui (*result, 1);
1864 for (d = 0; d < as->rank; d++)
1866 if (spec_dimen_size (as, d, &size) == FAILURE)
1868 mpz_clear (*result);
1872 mpz_mul (*result, *result, size);
1880 /* Get the number of elements in an array section. */
1883 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1885 mpz_t upper, lower, stride;
1888 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1889 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1891 switch (ar->dimen_type[dimen])
1895 mpz_set_ui (*result, 1);
1900 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1909 if (ar->start[dimen] == NULL)
1911 if (ar->as->lower[dimen] == NULL
1912 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1914 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1918 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1920 mpz_set (lower, ar->start[dimen]->value.integer);
1923 if (ar->end[dimen] == NULL)
1925 if (ar->as->upper[dimen] == NULL
1926 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1928 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1932 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1934 mpz_set (upper, ar->end[dimen]->value.integer);
1937 if (ar->stride[dimen] == NULL)
1938 mpz_set_ui (stride, 1);
1941 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1943 mpz_set (stride, ar->stride[dimen]->value.integer);
1947 mpz_sub (*result, upper, lower);
1948 mpz_add (*result, *result, stride);
1949 mpz_div (*result, *result, stride);
1951 /* Zero stride caught earlier. */
1952 if (mpz_cmp_ui (*result, 0) < 0)
1953 mpz_set_ui (*result, 0);
1963 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1971 ref_size (gfc_array_ref *ar, mpz_t *result)
1976 mpz_init_set_ui (*result, 1);
1978 for (d = 0; d < ar->dimen; d++)
1980 if (ref_dimen_size (ar, d, &size) == FAILURE)
1982 mpz_clear (*result);
1986 mpz_mul (*result, *result, size);
1994 /* Given an array expression and a dimension, figure out how many
1995 elements it has along that dimension. Returns SUCCESS if we were
1996 able to return a result in the 'result' variable, FAILURE
2000 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2005 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2006 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2008 switch (array->expr_type)
2012 for (ref = array->ref; ref; ref = ref->next)
2014 if (ref->type != REF_ARRAY)
2017 if (ref->u.ar.type == AR_FULL)
2018 return spec_dimen_size (ref->u.ar.as, dimen, result);
2020 if (ref->u.ar.type == AR_SECTION)
2022 for (i = 0; dimen >= 0; i++)
2023 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2026 return ref_dimen_size (&ref->u.ar, i - 1, result);
2030 if (array->shape && array->shape[dimen])
2032 mpz_init_set (*result, array->shape[dimen]);
2036 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
2042 if (array->shape == NULL) {
2043 /* Expressions with rank > 1 should have "shape" properly set */
2044 if ( array->rank != 1 )
2045 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2046 return gfc_array_size(array, result);
2051 if (array->shape == NULL)
2054 mpz_init_set (*result, array->shape[dimen]);
2063 /* Given an array expression, figure out how many elements are in the
2064 array. Returns SUCCESS if this is possible, and sets the 'result'
2065 variable. Otherwise returns FAILURE. */
2068 gfc_array_size (gfc_expr *array, mpz_t *result)
2070 expand_info expand_save;
2075 switch (array->expr_type)
2078 flag = gfc_suppress_error;
2079 gfc_suppress_error = 1;
2081 expand_save = current_expand;
2083 current_expand.count = result;
2084 mpz_init_set_ui (*result, 0);
2086 current_expand.expand_work_function = count_elements;
2089 t = expand_constructor (array->value.constructor);
2090 gfc_suppress_error = flag;
2093 mpz_clear (*result);
2094 current_expand = expand_save;
2098 for (ref = array->ref; ref; ref = ref->next)
2100 if (ref->type != REF_ARRAY)
2103 if (ref->u.ar.type == AR_FULL)
2104 return spec_size (ref->u.ar.as, result);
2106 if (ref->u.ar.type == AR_SECTION)
2107 return ref_size (&ref->u.ar, result);
2110 return spec_size (array->symtree->n.sym->as, result);
2114 if (array->rank == 0 || array->shape == NULL)
2117 mpz_init_set_ui (*result, 1);
2119 for (i = 0; i < array->rank; i++)
2120 mpz_mul (*result, *result, array->shape[i]);
2129 /* Given an array reference, return the shape of the reference in an
2130 array of mpz_t integers. */
2133 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2143 for (; d < ar->as->rank; d++)
2144 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2150 for (i = 0; i < ar->dimen; i++)
2152 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2154 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2167 for (d--; d >= 0; d--)
2168 mpz_clear (shape[d]);
2174 /* Given an array expression, find the array reference structure that
2175 characterizes the reference. */
2178 gfc_find_array_ref (gfc_expr *e)
2182 for (ref = e->ref; ref; ref = ref->next)
2183 if (ref->type == REF_ARRAY
2184 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2188 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2194 /* Find out if an array shape is known at compile time. */
2197 gfc_is_compile_time_shape (gfc_array_spec *as)
2201 if (as->type != AS_EXPLICIT)
2204 for (i = 0; i < as->rank; i++)
2205 if (!gfc_is_constant_expr (as->lower[i])
2206 || !gfc_is_constant_expr (as->upper[i]))