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 /**************** Array reference matching subroutines *****************/
29 /* Copy an array reference structure. */
32 gfc_copy_array_ref (gfc_array_ref *src)
40 dest = gfc_get_array_ref ();
44 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
46 dest->start[i] = gfc_copy_expr (src->start[i]);
47 dest->end[i] = gfc_copy_expr (src->end[i]);
48 dest->stride[i] = gfc_copy_expr (src->stride[i]);
51 dest->offset = gfc_copy_expr (src->offset);
57 /* Match a single dimension of an array reference. This can be a
58 single element or an array section. Any modifications we've made
59 to the ar structure are cleaned up by the caller. If the init
60 is set, we require the subscript to be a valid initialization
64 match_subscript (gfc_array_ref *ar, int init)
71 ar->c_where[i] = gfc_current_locus;
72 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
74 /* We can't be sure of the difference between DIMEN_ELEMENT and
75 DIMEN_VECTOR until we know the type of the element itself at
78 ar->dimen_type[i] = DIMEN_UNKNOWN;
80 if (gfc_match_char (':') == MATCH_YES)
83 /* Get start element. */
85 m = gfc_match_init_expr (&ar->start[i]);
87 m = gfc_match_expr (&ar->start[i]);
90 gfc_error ("Expected array subscript at %C");
94 if (gfc_match_char (':') == MATCH_NO)
97 /* Get an optional end element. Because we've seen the colon, we
98 definitely have a range along this dimension. */
100 ar->dimen_type[i] = DIMEN_RANGE;
103 m = gfc_match_init_expr (&ar->end[i]);
105 m = gfc_match_expr (&ar->end[i]);
107 if (m == MATCH_ERROR)
110 /* See if we have an optional stride. */
111 if (gfc_match_char (':') == MATCH_YES)
113 m = init ? gfc_match_init_expr (&ar->stride[i])
114 : gfc_match_expr (&ar->stride[i]);
117 gfc_error ("Expected array subscript stride at %C");
126 /* Match an array reference, whether it is the whole array or a
127 particular elements or a section. If init is set, the reference has
128 to consist of init expressions. */
131 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
135 memset (ar, '\0', sizeof (ar));
137 ar->where = gfc_current_locus;
140 if (gfc_match_char ('(') != MATCH_YES)
147 ar->type = AR_UNKNOWN;
149 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
151 m = match_subscript (ar, init);
152 if (m == MATCH_ERROR)
155 if (gfc_match_char (')') == MATCH_YES)
158 if (gfc_match_char (',') != MATCH_YES)
160 gfc_error ("Invalid form of array reference at %C");
165 gfc_error ("Array reference at %C cannot have more than %d dimensions",
178 /************** Array specification matching subroutines ***************/
180 /* Free all of the expressions associated with array bounds
184 gfc_free_array_spec (gfc_array_spec *as)
191 for (i = 0; i < as->rank; i++)
193 gfc_free_expr (as->lower[i]);
194 gfc_free_expr (as->upper[i]);
201 /* Take an array bound, resolves the expression, that make up the
202 shape and check associated constraints. */
205 resolve_array_bound (gfc_expr *e, int check_constant)
210 if (gfc_resolve_expr (e) == FAILURE
211 || gfc_specification_expr (e) == FAILURE)
214 if (check_constant && gfc_is_constant_expr (e) == 0)
216 gfc_error ("Variable '%s' at %L in this context must be constant",
217 e->symtree->n.sym->name, &e->where);
225 /* Takes an array specification, resolves the expressions that make up
226 the shape and make sure everything is integral. */
229 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
237 for (i = 0; i < as->rank; i++)
240 if (resolve_array_bound (e, check_constant) == FAILURE)
244 if (resolve_array_bound (e, check_constant) == FAILURE)
247 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
250 /* If the size is negative in this dimension, set it to zero. */
251 if (as->lower[i]->expr_type == EXPR_CONSTANT
252 && as->upper[i]->expr_type == EXPR_CONSTANT
253 && mpz_cmp (as->upper[i]->value.integer,
254 as->lower[i]->value.integer) < 0)
256 gfc_free_expr (as->upper[i]);
257 as->upper[i] = gfc_copy_expr (as->lower[i]);
258 mpz_sub_ui (as->upper[i]->value.integer,
259 as->upper[i]->value.integer, 1);
267 /* Match a single array element specification. The return values as
268 well as the upper and lower bounds of the array spec are filled
269 in according to what we see on the input. The caller makes sure
270 individual specifications make sense as a whole.
273 Parsed Lower Upper Returned
274 ------------------------------------
275 : NULL NULL AS_DEFERRED (*)
277 x: x NULL AS_ASSUMED_SHAPE
279 x:* x NULL AS_ASSUMED_SIZE
280 * 1 NULL AS_ASSUMED_SIZE
282 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
283 is fixed during the resolution of formal interfaces.
285 Anything else AS_UNKNOWN. */
288 match_array_element_spec (gfc_array_spec *as)
290 gfc_expr **upper, **lower;
293 lower = &as->lower[as->rank - 1];
294 upper = &as->upper[as->rank - 1];
296 if (gfc_match_char ('*') == MATCH_YES)
298 *lower = gfc_int_expr (1);
299 return AS_ASSUMED_SIZE;
302 if (gfc_match_char (':') == MATCH_YES)
305 m = gfc_match_expr (upper);
307 gfc_error ("Expected expression in array specification at %C");
310 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
313 if (gfc_match_char (':') == MATCH_NO)
315 *lower = gfc_int_expr (1);
322 if (gfc_match_char ('*') == MATCH_YES)
323 return AS_ASSUMED_SIZE;
325 m = gfc_match_expr (upper);
326 if (m == MATCH_ERROR)
329 return AS_ASSUMED_SHAPE;
330 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
337 /* Matches an array specification, incidentally figuring out what sort
341 gfc_match_array_spec (gfc_array_spec **asp)
343 array_type current_type;
347 if (gfc_match_char ('(') != MATCH_YES)
353 as = gfc_get_array_spec ();
355 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
365 current_type = match_array_element_spec (as);
369 if (current_type == AS_UNKNOWN)
371 as->type = current_type;
375 { /* See how current spec meshes with the existing. */
380 if (current_type == AS_ASSUMED_SIZE)
382 as->type = AS_ASSUMED_SIZE;
386 if (current_type == AS_EXPLICIT)
389 gfc_error ("Bad array specification for an explicitly shaped "
394 case AS_ASSUMED_SHAPE:
395 if ((current_type == AS_ASSUMED_SHAPE)
396 || (current_type == AS_DEFERRED))
399 gfc_error ("Bad array specification for assumed shape "
404 if (current_type == AS_DEFERRED)
407 if (current_type == AS_ASSUMED_SHAPE)
409 as->type = AS_ASSUMED_SHAPE;
413 gfc_error ("Bad specification for deferred shape array at %C");
416 case AS_ASSUMED_SIZE:
417 gfc_error ("Bad specification for assumed size array at %C");
421 if (gfc_match_char (')') == MATCH_YES)
424 if (gfc_match_char (',') != MATCH_YES)
426 gfc_error ("Expected another dimension in array declaration at %C");
430 if (as->rank >= GFC_MAX_DIMENSIONS)
432 gfc_error ("Array specification at %C has more than %d dimensions",
438 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
439 "specification at %C with more than 7 dimensions")
446 /* If a lower bounds of an assumed shape array is blank, put in one. */
447 if (as->type == AS_ASSUMED_SHAPE)
449 for (i = 0; i < as->rank; i++)
451 if (as->lower[i] == NULL)
452 as->lower[i] = gfc_int_expr (1);
459 /* Something went wrong. */
460 gfc_free_array_spec (as);
465 /* Given a symbol and an array specification, modify the symbol to
466 have that array specification. The error locus is needed in case
467 something goes wrong. On failure, the caller must free the spec. */
470 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
475 if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
484 /* Copy an array specification. */
487 gfc_copy_array_spec (gfc_array_spec *src)
489 gfc_array_spec *dest;
495 dest = gfc_get_array_spec ();
499 for (i = 0; i < dest->rank; i++)
501 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
502 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
509 /* Returns nonzero if the two expressions are equal. Only handles integer
513 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
515 if (bound1 == NULL || bound2 == NULL
516 || bound1->expr_type != EXPR_CONSTANT
517 || bound2->expr_type != EXPR_CONSTANT
518 || bound1->ts.type != BT_INTEGER
519 || bound2->ts.type != BT_INTEGER)
520 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
522 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
529 /* Compares two array specifications. They must be constant or deferred
533 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
537 if (as1 == NULL && as2 == NULL)
540 if (as1 == NULL || as2 == NULL)
543 if (as1->rank != as2->rank)
549 if (as1->type != as2->type)
552 if (as1->type == AS_EXPLICIT)
553 for (i = 0; i < as1->rank; i++)
555 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
558 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
566 /****************** Array constructor functions ******************/
568 /* Start an array constructor. The constructor starts with zero
569 elements and should be appended to by gfc_append_constructor(). */
572 gfc_start_constructor (bt type, int kind, locus *where)
576 result = gfc_get_expr ();
578 result->expr_type = EXPR_ARRAY;
581 result->ts.type = type;
582 result->ts.kind = kind;
583 result->where = *where;
588 /* Given an array constructor expression, append the new expression
589 node onto the constructor. */
592 gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
596 if (base->value.constructor == NULL)
597 base->value.constructor = c = gfc_get_constructor ();
600 c = base->value.constructor;
604 c->next = gfc_get_constructor ();
610 if (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)
611 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
615 /* Given an array constructor expression, insert the new expression's
616 constructor onto the base's one according to the offset. */
619 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
621 gfc_constructor *c, *pre;
625 type = base->expr_type;
627 if (base->value.constructor == NULL)
628 base->value.constructor = c1;
631 c = pre = base->value.constructor;
634 if (type == EXPR_ARRAY)
636 t = mpz_cmp (c->n.offset, c1->n.offset);
644 gfc_error ("duplicated initializer");
665 base->value.constructor = c1;
671 /* Get a new constructor. */
674 gfc_get_constructor (void)
678 c = XCNEW (gfc_constructor);
682 mpz_init_set_si (c->n.offset, 0);
683 mpz_init_set_si (c->repeat, 0);
688 /* Free chains of gfc_constructor structures. */
691 gfc_free_constructor (gfc_constructor *p)
693 gfc_constructor *next;
703 gfc_free_expr (p->expr);
704 if (p->iterator != NULL)
705 gfc_free_iterator (p->iterator, 1);
706 mpz_clear (p->n.offset);
707 mpz_clear (p->repeat);
713 /* Given an expression node that might be an array constructor and a
714 symbol, make sure that no iterators in this or child constructors
715 use the symbol as an implied-DO iterator. Returns nonzero if a
716 duplicate was found. */
719 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
723 for (; c; c = c->next)
727 if (e->expr_type == EXPR_ARRAY
728 && check_duplicate_iterator (e->value.constructor, master))
731 if (c->iterator == NULL)
734 if (c->iterator->var->symtree->n.sym == master)
736 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
737 "same name", master->name, &c->where);
747 /* Forward declaration because these functions are mutually recursive. */
748 static match match_array_cons_element (gfc_constructor **);
750 /* Match a list of array elements. */
753 match_array_list (gfc_constructor **result)
755 gfc_constructor *p, *head, *tail, *new_cons;
762 old_loc = gfc_current_locus;
764 if (gfc_match_char ('(') == MATCH_NO)
767 memset (&iter, '\0', sizeof (gfc_iterator));
770 m = match_array_cons_element (&head);
776 if (gfc_match_char (',') != MATCH_YES)
784 m = gfc_match_iterator (&iter, 0);
787 if (m == MATCH_ERROR)
790 m = match_array_cons_element (&new_cons);
791 if (m == MATCH_ERROR)
798 goto cleanup; /* Could be a complex constant */
801 tail->next = new_cons;
804 if (gfc_match_char (',') != MATCH_YES)
813 if (gfc_match_char (')') != MATCH_YES)
816 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
823 e->expr_type = EXPR_ARRAY;
825 e->value.constructor = head;
827 p = gfc_get_constructor ();
828 p->where = gfc_current_locus;
829 p->iterator = gfc_get_iterator ();
838 gfc_error ("Syntax error in array constructor at %C");
842 gfc_free_constructor (head);
843 gfc_free_iterator (&iter, 0);
844 gfc_current_locus = old_loc;
849 /* Match a single element of an array constructor, which can be a
850 single expression or a list of elements. */
853 match_array_cons_element (gfc_constructor **result)
859 m = match_array_list (result);
863 m = gfc_match_expr (&expr);
867 p = gfc_get_constructor ();
868 p->where = gfc_current_locus;
876 /* Match an array constructor. */
879 gfc_match_array_constructor (gfc_expr **result)
881 gfc_constructor *head, *tail, *new_cons;
886 const char *end_delim;
889 if (gfc_match (" (/") == MATCH_NO)
891 if (gfc_match (" [") == MATCH_NO)
895 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
896 "style array constructors at %C") == FAILURE)
904 where = gfc_current_locus;
908 /* Try to match an optional "type-spec ::" */
909 if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
911 seen_ts = (gfc_match (" ::") == MATCH_YES);
915 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
916 "including type specification at %C") == FAILURE)
922 gfc_current_locus = where;
924 if (gfc_match (end_delim) == MATCH_YES)
930 gfc_error ("Empty array constructor at %C is not allowed");
937 m = match_array_cons_element (&new_cons);
938 if (m == MATCH_ERROR)
946 tail->next = new_cons;
950 if (gfc_match_char (',') == MATCH_NO)
954 if (gfc_match (end_delim) == MATCH_NO)
958 expr = gfc_get_expr ();
960 expr->expr_type = EXPR_ARRAY;
962 expr->value.constructor = head;
963 /* Size must be calculated at resolution time. */
968 expr->ts.type = BT_UNKNOWN;
971 expr->ts.cl->length_from_typespec = seen_ts;
980 gfc_error ("Syntax error in array constructor at %C");
983 gfc_free_constructor (head);
989 /************** Check array constructors for correctness **************/
991 /* Given an expression, compare it's type with the type of the current
992 constructor. Returns nonzero if an error was issued. The
993 cons_state variable keeps track of whether the type of the
994 constructor being read or resolved is known to be good, bad or just
997 static gfc_typespec constructor_ts;
999 { CONS_START, CONS_GOOD, CONS_BAD }
1003 check_element_type (gfc_expr *expr, bool convert)
1005 if (cons_state == CONS_BAD)
1006 return 0; /* Suppress further errors */
1008 if (cons_state == CONS_START)
1010 if (expr->ts.type == BT_UNKNOWN)
1011 cons_state = CONS_BAD;
1014 cons_state = CONS_GOOD;
1015 constructor_ts = expr->ts;
1021 if (gfc_compare_types (&constructor_ts, &expr->ts))
1025 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1027 gfc_error ("Element in %s array constructor at %L is %s",
1028 gfc_typename (&constructor_ts), &expr->where,
1029 gfc_typename (&expr->ts));
1031 cons_state = CONS_BAD;
1036 /* Recursive work function for gfc_check_constructor_type(). */
1039 check_constructor_type (gfc_constructor *c, bool convert)
1043 for (; c; c = c->next)
1047 if (e->expr_type == EXPR_ARRAY)
1049 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1055 if (check_element_type (e, convert))
1063 /* Check that all elements of an array constructor are the same type.
1064 On FAILURE, an error has been generated. */
1067 gfc_check_constructor_type (gfc_expr *e)
1071 if (e->ts.type != BT_UNKNOWN)
1073 cons_state = CONS_GOOD;
1074 constructor_ts = e->ts;
1078 cons_state = CONS_START;
1079 gfc_clear_ts (&constructor_ts);
1082 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1083 typespec, and we will now convert the values on the fly. */
1084 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1085 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1086 e->ts = constructor_ts;
1093 typedef struct cons_stack
1095 gfc_iterator *iterator;
1096 struct cons_stack *previous;
1100 static cons_stack *base;
1102 static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
1104 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1105 that that variable is an iteration variables. */
1108 gfc_check_iter_variable (gfc_expr *expr)
1113 sym = expr->symtree->n.sym;
1115 for (c = base; c; c = c->previous)
1116 if (sym == c->iterator->var->symtree->n.sym)
1123 /* Recursive work function for gfc_check_constructor(). This amounts
1124 to calling the check function for each expression in the
1125 constructor, giving variables with the names of iterators a pass. */
1128 check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
1134 for (; c; c = c->next)
1138 if (e->expr_type != EXPR_ARRAY)
1140 if ((*check_function) (e) == FAILURE)
1145 element.previous = base;
1146 element.iterator = c->iterator;
1149 t = check_constructor (e->value.constructor, check_function);
1150 base = element.previous;
1156 /* Nothing went wrong, so all OK. */
1161 /* Checks a constructor to see if it is a particular kind of
1162 expression -- specification, restricted, or initialization as
1163 determined by the check_function. */
1166 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1168 cons_stack *base_save;
1174 t = check_constructor (expr->value.constructor, check_function);
1182 /**************** Simplification of array constructors ****************/
1184 iterator_stack *iter_stack;
1188 gfc_constructor *new_head, *new_tail;
1189 int extract_count, extract_n;
1190 gfc_expr *extracted;
1194 gfc_component *component;
1197 gfc_try (*expand_work_function) (gfc_expr *);
1201 static expand_info current_expand;
1203 static gfc_try expand_constructor (gfc_constructor *);
1206 /* Work function that counts the number of elements present in a
1210 count_elements (gfc_expr *e)
1215 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1218 if (gfc_array_size (e, &result) == FAILURE)
1224 mpz_add (*current_expand.count, *current_expand.count, result);
1233 /* Work function that extracts a particular element from an array
1234 constructor, freeing the rest. */
1237 extract_element (gfc_expr *e)
1241 { /* Something unextractable */
1246 if (current_expand.extract_count == current_expand.extract_n)
1247 current_expand.extracted = e;
1251 current_expand.extract_count++;
1256 /* Work function that constructs a new constructor out of the old one,
1257 stringing new elements together. */
1260 expand (gfc_expr *e)
1262 if (current_expand.new_head == NULL)
1263 current_expand.new_head = current_expand.new_tail =
1264 gfc_get_constructor ();
1267 current_expand.new_tail->next = gfc_get_constructor ();
1268 current_expand.new_tail = current_expand.new_tail->next;
1271 current_expand.new_tail->where = e->where;
1272 current_expand.new_tail->expr = e;
1274 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1275 current_expand.new_tail->n.component = current_expand.component;
1276 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1281 /* Given an initialization expression that is a variable reference,
1282 substitute the current value of the iteration variable. */
1285 gfc_simplify_iterator_var (gfc_expr *e)
1289 for (p = iter_stack; p; p = p->prev)
1290 if (e->symtree == p->variable)
1294 return; /* Variable not found */
1296 gfc_replace_expr (e, gfc_int_expr (0));
1298 mpz_set (e->value.integer, p->value);
1304 /* Expand an expression with that is inside of a constructor,
1305 recursing into other constructors if present. */
1308 expand_expr (gfc_expr *e)
1310 if (e->expr_type == EXPR_ARRAY)
1311 return expand_constructor (e->value.constructor);
1313 e = gfc_copy_expr (e);
1315 if (gfc_simplify_expr (e, 1) == FAILURE)
1321 return current_expand.expand_work_function (e);
1326 expand_iterator (gfc_constructor *c)
1328 gfc_expr *start, *end, *step;
1329 iterator_stack frame;
1338 mpz_init (frame.value);
1341 start = gfc_copy_expr (c->iterator->start);
1342 if (gfc_simplify_expr (start, 1) == FAILURE)
1345 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1348 end = gfc_copy_expr (c->iterator->end);
1349 if (gfc_simplify_expr (end, 1) == FAILURE)
1352 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1355 step = gfc_copy_expr (c->iterator->step);
1356 if (gfc_simplify_expr (step, 1) == FAILURE)
1359 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1362 if (mpz_sgn (step->value.integer) == 0)
1364 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1368 /* Calculate the trip count of the loop. */
1369 mpz_sub (trip, end->value.integer, start->value.integer);
1370 mpz_add (trip, trip, step->value.integer);
1371 mpz_tdiv_q (trip, trip, step->value.integer);
1373 mpz_set (frame.value, start->value.integer);
1375 frame.prev = iter_stack;
1376 frame.variable = c->iterator->var->symtree;
1377 iter_stack = &frame;
1379 while (mpz_sgn (trip) > 0)
1381 if (expand_expr (c->expr) == FAILURE)
1384 mpz_add (frame.value, frame.value, step->value.integer);
1385 mpz_sub_ui (trip, trip, 1);
1391 gfc_free_expr (start);
1392 gfc_free_expr (end);
1393 gfc_free_expr (step);
1396 mpz_clear (frame.value);
1398 iter_stack = frame.prev;
1404 /* Expand a constructor into constant constructors without any
1405 iterators, calling the work function for each of the expanded
1406 expressions. The work function needs to either save or free the
1407 passed expression. */
1410 expand_constructor (gfc_constructor *c)
1414 for (; c; c = c->next)
1416 if (c->iterator != NULL)
1418 if (expand_iterator (c) == FAILURE)
1425 if (e->expr_type == EXPR_ARRAY)
1427 if (expand_constructor (e->value.constructor) == FAILURE)
1433 e = gfc_copy_expr (e);
1434 if (gfc_simplify_expr (e, 1) == FAILURE)
1439 current_expand.offset = &c->n.offset;
1440 current_expand.component = c->n.component;
1441 current_expand.repeat = &c->repeat;
1442 if (current_expand.expand_work_function (e) == FAILURE)
1449 /* Top level subroutine for expanding constructors. We only expand
1450 constructor if they are small enough. */
1453 gfc_expand_constructor (gfc_expr *e)
1455 expand_info expand_save;
1459 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1466 expand_save = current_expand;
1467 current_expand.new_head = current_expand.new_tail = NULL;
1471 current_expand.expand_work_function = expand;
1473 if (expand_constructor (e->value.constructor) == FAILURE)
1475 gfc_free_constructor (current_expand.new_head);
1480 gfc_free_constructor (e->value.constructor);
1481 e->value.constructor = current_expand.new_head;
1486 current_expand = expand_save;
1492 /* Work function for checking that an element of a constructor is a
1493 constant, after removal of any iteration variables. We return
1494 FAILURE if not so. */
1497 constant_element (gfc_expr *e)
1501 rv = gfc_is_constant_expr (e);
1504 return rv ? SUCCESS : FAILURE;
1508 /* Given an array constructor, determine if the constructor is
1509 constant or not by expanding it and making sure that all elements
1510 are constants. This is a bit of a hack since something like (/ (i,
1511 i=1,100000000) /) will take a while as* opposed to a more clever
1512 function that traverses the expression tree. FIXME. */
1515 gfc_constant_ac (gfc_expr *e)
1517 expand_info expand_save;
1521 expand_save = current_expand;
1522 current_expand.expand_work_function = constant_element;
1524 rc = expand_constructor (e->value.constructor);
1526 current_expand = expand_save;
1534 /* Returns nonzero if an array constructor has been completely
1535 expanded (no iterators) and zero if iterators are present. */
1538 gfc_expanded_ac (gfc_expr *e)
1542 if (e->expr_type == EXPR_ARRAY)
1543 for (p = e->value.constructor; p; p = p->next)
1544 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1551 /*************** Type resolution of array constructors ***************/
1553 /* Recursive array list resolution function. All of the elements must
1554 be of the same type. */
1557 resolve_array_list (gfc_constructor *p)
1563 for (; p; p = p->next)
1565 if (p->iterator != NULL
1566 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1569 if (gfc_resolve_expr (p->expr) == FAILURE)
1576 /* Resolve character array constructor. If it has a specified constant character
1577 length, pad/truncate the elements here; if the length is not specified and
1578 all elements are of compile-time known length, emit an error as this is
1582 gfc_resolve_character_array_constructor (gfc_expr *expr)
1587 gcc_assert (expr->expr_type == EXPR_ARRAY);
1588 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;
1610 if (expr->ts.cl->length == NULL)
1612 /* Check that all constant string elements have the same length until
1613 we reach the end or find a variable-length one. */
1615 for (p = expr->value.constructor; p; p = p->next)
1617 int current_length = -1;
1619 for (ref = p->expr->ref; ref; ref = ref->next)
1620 if (ref->type == REF_SUBSTRING
1621 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1622 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1625 if (p->expr->expr_type == EXPR_CONSTANT)
1626 current_length = p->expr->value.character.length;
1630 j = mpz_get_ui (ref->u.ss.end->value.integer)
1631 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1632 current_length = (int) j;
1634 else if (p->expr->ts.cl && p->expr->ts.cl->length
1635 && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1638 j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1639 current_length = (int) j;
1644 gcc_assert (current_length != -1);
1646 if (found_length == -1)
1647 found_length = current_length;
1648 else if (found_length != current_length)
1650 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1651 " constructor at %L", found_length, current_length,
1656 gcc_assert (found_length == current_length);
1659 gcc_assert (found_length != -1);
1661 /* Update the character length of the array constructor. */
1662 expr->ts.cl->length = gfc_int_expr (found_length);
1666 /* We've got a character length specified. It should be an integer,
1667 otherwise an error is signalled elsewhere. */
1668 gcc_assert (expr->ts.cl->length);
1670 /* If we've got a constant character length, pad according to this.
1671 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1672 max_length only if they pass. */
1673 gfc_extract_int (expr->ts.cl->length, &found_length);
1675 /* Now pad/truncate the elements accordingly to the specified character
1676 length. This is ok inside this conditional, as in the case above
1677 (without typespec) all elements are verified to have the same length
1679 if (found_length != -1)
1680 for (p = expr->value.constructor; p; p = p->next)
1681 if (p->expr->expr_type == EXPR_CONSTANT)
1683 gfc_expr *cl = NULL;
1684 int current_length = -1;
1687 if (p->expr->ts.cl && p->expr->ts.cl->length)
1689 cl = p->expr->ts.cl->length;
1690 gfc_extract_int (cl, ¤t_length);
1693 /* If gfc_extract_int above set current_length, we implicitly
1694 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1696 has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
1699 || (current_length != -1 && current_length < found_length))
1700 gfc_set_constant_character_len (found_length, p->expr,
1701 has_ts ? -1 : found_length);
1709 /* Resolve all of the expressions in an array list. */
1712 gfc_resolve_array_constructor (gfc_expr *expr)
1716 t = resolve_array_list (expr->value.constructor);
1718 t = gfc_check_constructor_type (expr);
1720 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1721 the call to this function, so we don't need to call it here; if it was
1722 called twice, an error message there would be duplicated. */
1728 /* Copy an iterator structure. */
1730 static gfc_iterator *
1731 copy_iterator (gfc_iterator *src)
1738 dest = gfc_get_iterator ();
1740 dest->var = gfc_copy_expr (src->var);
1741 dest->start = gfc_copy_expr (src->start);
1742 dest->end = gfc_copy_expr (src->end);
1743 dest->step = gfc_copy_expr (src->step);
1749 /* Copy a constructor structure. */
1752 gfc_copy_constructor (gfc_constructor *src)
1754 gfc_constructor *dest;
1755 gfc_constructor *tail;
1764 dest = tail = gfc_get_constructor ();
1767 tail->next = gfc_get_constructor ();
1770 tail->where = src->where;
1771 tail->expr = gfc_copy_expr (src->expr);
1772 tail->iterator = copy_iterator (src->iterator);
1773 mpz_set (tail->n.offset, src->n.offset);
1774 tail->n.component = src->n.component;
1775 mpz_set (tail->repeat, src->repeat);
1783 /* Given an array expression and an element number (starting at zero),
1784 return a pointer to the array element. NULL is returned if the
1785 size of the array has been exceeded. The expression node returned
1786 remains a part of the array and should not be freed. Access is not
1787 efficient at all, but this is another place where things do not
1788 have to be particularly fast. */
1791 gfc_get_array_element (gfc_expr *array, int element)
1793 expand_info expand_save;
1797 expand_save = current_expand;
1798 current_expand.extract_n = element;
1799 current_expand.expand_work_function = extract_element;
1800 current_expand.extracted = NULL;
1801 current_expand.extract_count = 0;
1805 rc = expand_constructor (array->value.constructor);
1806 e = current_expand.extracted;
1807 current_expand = expand_save;
1816 /********* Subroutines for determining the size of an array *********/
1818 /* These are needed just to accommodate RESHAPE(). There are no
1819 diagnostics here, we just return a negative number if something
1823 /* Get the size of single dimension of an array specification. The
1824 array is guaranteed to be one dimensional. */
1827 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1832 if (dimen < 0 || dimen > as->rank - 1)
1833 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1835 if (as->type != AS_EXPLICIT
1836 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1837 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1838 || as->lower[dimen]->ts.type != BT_INTEGER
1839 || as->upper[dimen]->ts.type != BT_INTEGER)
1844 mpz_sub (*result, as->upper[dimen]->value.integer,
1845 as->lower[dimen]->value.integer);
1847 mpz_add_ui (*result, *result, 1);
1854 spec_size (gfc_array_spec *as, mpz_t *result)
1859 mpz_init_set_ui (*result, 1);
1861 for (d = 0; d < as->rank; d++)
1863 if (spec_dimen_size (as, d, &size) == FAILURE)
1865 mpz_clear (*result);
1869 mpz_mul (*result, *result, size);
1877 /* Get the number of elements in an array section. */
1880 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1882 mpz_t upper, lower, stride;
1885 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1886 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1888 switch (ar->dimen_type[dimen])
1892 mpz_set_ui (*result, 1);
1897 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1906 if (ar->start[dimen] == NULL)
1908 if (ar->as->lower[dimen] == NULL
1909 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1911 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1915 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1917 mpz_set (lower, ar->start[dimen]->value.integer);
1920 if (ar->end[dimen] == NULL)
1922 if (ar->as->upper[dimen] == NULL
1923 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1925 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1929 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1931 mpz_set (upper, ar->end[dimen]->value.integer);
1934 if (ar->stride[dimen] == NULL)
1935 mpz_set_ui (stride, 1);
1938 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1940 mpz_set (stride, ar->stride[dimen]->value.integer);
1944 mpz_sub (*result, upper, lower);
1945 mpz_add (*result, *result, stride);
1946 mpz_div (*result, *result, stride);
1948 /* Zero stride caught earlier. */
1949 if (mpz_cmp_ui (*result, 0) < 0)
1950 mpz_set_ui (*result, 0);
1960 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1968 ref_size (gfc_array_ref *ar, mpz_t *result)
1973 mpz_init_set_ui (*result, 1);
1975 for (d = 0; d < ar->dimen; d++)
1977 if (ref_dimen_size (ar, d, &size) == FAILURE)
1979 mpz_clear (*result);
1983 mpz_mul (*result, *result, size);
1991 /* Given an array expression and a dimension, figure out how many
1992 elements it has along that dimension. Returns SUCCESS if we were
1993 able to return a result in the 'result' variable, FAILURE
1997 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2002 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2003 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2005 switch (array->expr_type)
2009 for (ref = array->ref; ref; ref = ref->next)
2011 if (ref->type != REF_ARRAY)
2014 if (ref->u.ar.type == AR_FULL)
2015 return spec_dimen_size (ref->u.ar.as, dimen, result);
2017 if (ref->u.ar.type == AR_SECTION)
2019 for (i = 0; dimen >= 0; i++)
2020 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2023 return ref_dimen_size (&ref->u.ar, i - 1, result);
2027 if (array->shape && array->shape[dimen])
2029 mpz_init_set (*result, array->shape[dimen]);
2033 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
2039 if (array->shape == NULL) {
2040 /* Expressions with rank > 1 should have "shape" properly set */
2041 if ( array->rank != 1 )
2042 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2043 return gfc_array_size(array, result);
2048 if (array->shape == NULL)
2051 mpz_init_set (*result, array->shape[dimen]);
2060 /* Given an array expression, figure out how many elements are in the
2061 array. Returns SUCCESS if this is possible, and sets the 'result'
2062 variable. Otherwise returns FAILURE. */
2065 gfc_array_size (gfc_expr *array, mpz_t *result)
2067 expand_info expand_save;
2072 switch (array->expr_type)
2075 gfc_push_suppress_errors ();
2077 expand_save = current_expand;
2079 current_expand.count = result;
2080 mpz_init_set_ui (*result, 0);
2082 current_expand.expand_work_function = count_elements;
2085 t = expand_constructor (array->value.constructor);
2087 gfc_pop_suppress_errors ();
2090 mpz_clear (*result);
2091 current_expand = expand_save;
2095 for (ref = array->ref; ref; ref = ref->next)
2097 if (ref->type != REF_ARRAY)
2100 if (ref->u.ar.type == AR_FULL)
2101 return spec_size (ref->u.ar.as, result);
2103 if (ref->u.ar.type == AR_SECTION)
2104 return ref_size (&ref->u.ar, result);
2107 return spec_size (array->symtree->n.sym->as, result);
2111 if (array->rank == 0 || array->shape == NULL)
2114 mpz_init_set_ui (*result, 1);
2116 for (i = 0; i < array->rank; i++)
2117 mpz_mul (*result, *result, array->shape[i]);
2126 /* Given an array reference, return the shape of the reference in an
2127 array of mpz_t integers. */
2130 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2140 for (; d < ar->as->rank; d++)
2141 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2147 for (i = 0; i < ar->dimen; i++)
2149 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2151 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2164 for (d--; d >= 0; d--)
2165 mpz_clear (shape[d]);
2171 /* Given an array expression, find the array reference structure that
2172 characterizes the reference. */
2175 gfc_find_array_ref (gfc_expr *e)
2179 for (ref = e->ref; ref; ref = ref->next)
2180 if (ref->type == REF_ARRAY
2181 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2185 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2191 /* Find out if an array shape is known at compile time. */
2194 gfc_is_compile_time_shape (gfc_array_spec *as)
2198 if (as->type != AS_EXPLICIT)
2201 for (i = 0; i < as->rank; i++)
2202 if (!gfc_is_constant_expr (as->lower[i])
2203 || !gfc_is_constant_expr (as->upper[i]))