2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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 + as->corank; 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 + as->corank; 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 + as->corank - 1];
294 upper = &as->upper[as->rank + as->corank - 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
338 it is. Match either a normal array specification, or a coarray spec
339 or both. Optionally allow [:] for coarrays. */
342 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
344 array_type current_type;
348 as = gfc_get_array_spec ();
352 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
361 if (gfc_match_char ('(') != MATCH_YES)
371 current_type = match_array_element_spec (as);
375 if (current_type == AS_UNKNOWN)
377 as->type = current_type;
381 { /* See how current spec meshes with the existing. */
386 if (current_type == AS_ASSUMED_SIZE)
388 as->type = AS_ASSUMED_SIZE;
392 if (current_type == AS_EXPLICIT)
395 gfc_error ("Bad array specification for an explicitly shaped "
400 case AS_ASSUMED_SHAPE:
401 if ((current_type == AS_ASSUMED_SHAPE)
402 || (current_type == AS_DEFERRED))
405 gfc_error ("Bad array specification for assumed shape "
410 if (current_type == AS_DEFERRED)
413 if (current_type == AS_ASSUMED_SHAPE)
415 as->type = AS_ASSUMED_SHAPE;
419 gfc_error ("Bad specification for deferred shape array at %C");
422 case AS_ASSUMED_SIZE:
423 gfc_error ("Bad specification for assumed size array at %C");
427 if (gfc_match_char (')') == MATCH_YES)
430 if (gfc_match_char (',') != MATCH_YES)
432 gfc_error ("Expected another dimension in array declaration at %C");
436 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
438 gfc_error ("Array specification at %C has more than %d dimensions",
443 if (as->corank + as->rank >= 7
444 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
445 "specification at %C with more than 7 dimensions")
454 if (gfc_match_char ('[') != MATCH_YES)
457 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
461 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
463 gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
470 current_type = match_array_element_spec (as);
472 if (current_type == AS_UNKNOWN)
476 as->cotype = current_type;
479 { /* See how current spec meshes with the existing. */
484 if (current_type == AS_ASSUMED_SIZE)
486 as->cotype = AS_ASSUMED_SIZE;
490 if (current_type == AS_EXPLICIT)
493 gfc_error ("Bad array specification for an explicitly "
494 "shaped array at %C");
498 case AS_ASSUMED_SHAPE:
499 if ((current_type == AS_ASSUMED_SHAPE)
500 || (current_type == AS_DEFERRED))
503 gfc_error ("Bad array specification for assumed shape "
508 if (current_type == AS_DEFERRED)
511 if (current_type == AS_ASSUMED_SHAPE)
513 as->cotype = AS_ASSUMED_SHAPE;
517 gfc_error ("Bad specification for deferred shape array at %C");
520 case AS_ASSUMED_SIZE:
521 gfc_error ("Bad specification for assumed size array at %C");
525 if (gfc_match_char (']') == MATCH_YES)
528 if (gfc_match_char (',') != MATCH_YES)
530 gfc_error ("Expected another dimension in array declaration at %C");
534 if (as->corank >= GFC_MAX_DIMENSIONS)
536 gfc_error ("Array specification at %C has more than %d "
537 "dimensions", GFC_MAX_DIMENSIONS);
542 if (current_type == AS_EXPLICIT)
544 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
548 if (as->cotype == AS_ASSUMED_SIZE)
549 as->cotype = AS_EXPLICIT;
552 as->type = as->cotype;
555 if (as->rank == 0 && as->corank == 0)
558 gfc_free_array_spec (as);
562 /* If a lower bounds of an assumed shape array is blank, put in one. */
563 if (as->type == AS_ASSUMED_SHAPE)
565 for (i = 0; i < as->rank + as->corank; i++)
567 if (as->lower[i] == NULL)
568 as->lower[i] = gfc_int_expr (1);
577 /* Something went wrong. */
578 gfc_free_array_spec (as);
583 /* Given a symbol and an array specification, modify the symbol to
584 have that array specification. The error locus is needed in case
585 something goes wrong. On failure, the caller must free the spec. */
588 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
596 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
600 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
611 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
612 the codimension is simply added. */
613 gcc_assert (as->rank == 0 && sym->as->corank == 0);
615 sym->as->cotype = as->cotype;
616 sym->as->corank = as->corank;
617 for (i = 0; i < as->corank; i++)
619 sym->as->lower[sym->as->rank + i] = as->lower[i];
620 sym->as->upper[sym->as->rank + i] = as->upper[i];
625 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
626 the dimension is added - but first the codimensions (if existing
627 need to be shifted to make space for the dimension. */
628 gcc_assert (as->corank == 0 && sym->as->rank == 0);
630 sym->as->rank = as->rank;
631 sym->as->type = as->type;
632 sym->as->cray_pointee = as->cray_pointee;
633 sym->as->cp_was_assumed = as->cp_was_assumed;
635 for (i = 0; i < sym->as->corank; i++)
637 sym->as->lower[as->rank + i] = sym->as->lower[i];
638 sym->as->upper[as->rank + i] = sym->as->upper[i];
640 for (i = 0; i < as->rank; i++)
642 sym->as->lower[i] = as->lower[i];
643 sym->as->upper[i] = as->upper[i];
652 /* Copy an array specification. */
655 gfc_copy_array_spec (gfc_array_spec *src)
657 gfc_array_spec *dest;
663 dest = gfc_get_array_spec ();
667 for (i = 0; i < dest->rank + dest->corank; i++)
669 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
670 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
677 /* Returns nonzero if the two expressions are equal. Only handles integer
681 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
683 if (bound1 == NULL || bound2 == NULL
684 || bound1->expr_type != EXPR_CONSTANT
685 || bound2->expr_type != EXPR_CONSTANT
686 || bound1->ts.type != BT_INTEGER
687 || bound2->ts.type != BT_INTEGER)
688 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
690 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
697 /* Compares two array specifications. They must be constant or deferred
701 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
705 if (as1 == NULL && as2 == NULL)
708 if (as1 == NULL || as2 == NULL)
711 if (as1->rank != as2->rank)
714 if (as1->corank != as2->corank)
720 if (as1->type != as2->type)
723 if (as1->type == AS_EXPLICIT)
724 for (i = 0; i < as1->rank + as1->corank; i++)
726 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
729 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
737 /****************** Array constructor functions ******************/
739 /* Start an array constructor. The constructor starts with zero
740 elements and should be appended to by gfc_append_constructor(). */
743 gfc_start_constructor (bt type, int kind, locus *where)
747 result = gfc_get_expr ();
749 result->expr_type = EXPR_ARRAY;
752 result->ts.type = type;
753 result->ts.kind = kind;
754 result->where = *where;
759 /* Given an array constructor expression, append the new expression
760 node onto the constructor. */
763 gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
767 if (base->value.constructor == NULL)
768 base->value.constructor = c = gfc_get_constructor ();
771 c = base->value.constructor;
775 c->next = gfc_get_constructor ();
782 && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
783 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
787 /* Given an array constructor expression, insert the new expression's
788 constructor onto the base's one according to the offset. */
791 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
793 gfc_constructor *c, *pre;
797 type = base->expr_type;
799 if (base->value.constructor == NULL)
800 base->value.constructor = c1;
803 c = pre = base->value.constructor;
806 if (type == EXPR_ARRAY)
808 t = mpz_cmp (c->n.offset, c1->n.offset);
816 gfc_error ("duplicated initializer");
837 base->value.constructor = c1;
843 /* Get a new constructor. */
846 gfc_get_constructor (void)
850 c = XCNEW (gfc_constructor);
854 mpz_init_set_si (c->n.offset, 0);
855 mpz_init_set_si (c->repeat, 0);
860 /* Free chains of gfc_constructor structures. */
863 gfc_free_constructor (gfc_constructor *p)
865 gfc_constructor *next;
875 gfc_free_expr (p->expr);
876 if (p->iterator != NULL)
877 gfc_free_iterator (p->iterator, 1);
878 mpz_clear (p->n.offset);
879 mpz_clear (p->repeat);
885 /* Given an expression node that might be an array constructor and a
886 symbol, make sure that no iterators in this or child constructors
887 use the symbol as an implied-DO iterator. Returns nonzero if a
888 duplicate was found. */
891 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
895 for (; c; c = c->next)
899 if (e->expr_type == EXPR_ARRAY
900 && check_duplicate_iterator (e->value.constructor, master))
903 if (c->iterator == NULL)
906 if (c->iterator->var->symtree->n.sym == master)
908 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
909 "same name", master->name, &c->where);
919 /* Forward declaration because these functions are mutually recursive. */
920 static match match_array_cons_element (gfc_constructor **);
922 /* Match a list of array elements. */
925 match_array_list (gfc_constructor **result)
927 gfc_constructor *p, *head, *tail, *new_cons;
934 old_loc = gfc_current_locus;
936 if (gfc_match_char ('(') == MATCH_NO)
939 memset (&iter, '\0', sizeof (gfc_iterator));
942 m = match_array_cons_element (&head);
948 if (gfc_match_char (',') != MATCH_YES)
956 m = gfc_match_iterator (&iter, 0);
959 if (m == MATCH_ERROR)
962 m = match_array_cons_element (&new_cons);
963 if (m == MATCH_ERROR)
970 goto cleanup; /* Could be a complex constant */
973 tail->next = new_cons;
976 if (gfc_match_char (',') != MATCH_YES)
985 if (gfc_match_char (')') != MATCH_YES)
988 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
995 e->expr_type = EXPR_ARRAY;
997 e->value.constructor = head;
999 p = gfc_get_constructor ();
1000 p->where = gfc_current_locus;
1001 p->iterator = gfc_get_iterator ();
1002 *p->iterator = iter;
1010 gfc_error ("Syntax error in array constructor at %C");
1014 gfc_free_constructor (head);
1015 gfc_free_iterator (&iter, 0);
1016 gfc_current_locus = old_loc;
1021 /* Match a single element of an array constructor, which can be a
1022 single expression or a list of elements. */
1025 match_array_cons_element (gfc_constructor **result)
1031 m = match_array_list (result);
1035 m = gfc_match_expr (&expr);
1039 p = gfc_get_constructor ();
1040 p->where = gfc_current_locus;
1048 /* Match an array constructor. */
1051 gfc_match_array_constructor (gfc_expr **result)
1053 gfc_constructor *head, *tail, *new_cons;
1058 const char *end_delim;
1061 if (gfc_match (" (/") == MATCH_NO)
1063 if (gfc_match (" [") == MATCH_NO)
1067 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1068 "style array constructors at %C") == FAILURE)
1076 where = gfc_current_locus;
1080 /* Try to match an optional "type-spec ::" */
1081 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1083 seen_ts = (gfc_match (" ::") == MATCH_YES);
1087 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1088 "including type specification at %C") == FAILURE)
1094 gfc_current_locus = where;
1096 if (gfc_match (end_delim) == MATCH_YES)
1102 gfc_error ("Empty array constructor at %C is not allowed");
1109 m = match_array_cons_element (&new_cons);
1110 if (m == MATCH_ERROR)
1118 tail->next = new_cons;
1122 if (gfc_match_char (',') == MATCH_NO)
1126 if (gfc_match (end_delim) == MATCH_NO)
1130 expr = gfc_get_expr ();
1132 expr->expr_type = EXPR_ARRAY;
1134 expr->value.constructor = head;
1135 /* Size must be calculated at resolution time. */
1140 expr->ts.type = BT_UNKNOWN;
1143 expr->ts.u.cl->length_from_typespec = seen_ts;
1145 expr->where = where;
1152 gfc_error ("Syntax error in array constructor at %C");
1155 gfc_free_constructor (head);
1161 /************** Check array constructors for correctness **************/
1163 /* Given an expression, compare it's type with the type of the current
1164 constructor. Returns nonzero if an error was issued. The
1165 cons_state variable keeps track of whether the type of the
1166 constructor being read or resolved is known to be good, bad or just
1169 static gfc_typespec constructor_ts;
1171 { CONS_START, CONS_GOOD, CONS_BAD }
1175 check_element_type (gfc_expr *expr, bool convert)
1177 if (cons_state == CONS_BAD)
1178 return 0; /* Suppress further errors */
1180 if (cons_state == CONS_START)
1182 if (expr->ts.type == BT_UNKNOWN)
1183 cons_state = CONS_BAD;
1186 cons_state = CONS_GOOD;
1187 constructor_ts = expr->ts;
1193 if (gfc_compare_types (&constructor_ts, &expr->ts))
1197 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1199 gfc_error ("Element in %s array constructor at %L is %s",
1200 gfc_typename (&constructor_ts), &expr->where,
1201 gfc_typename (&expr->ts));
1203 cons_state = CONS_BAD;
1208 /* Recursive work function for gfc_check_constructor_type(). */
1211 check_constructor_type (gfc_constructor *c, bool convert)
1215 for (; c; c = c->next)
1219 if (e->expr_type == EXPR_ARRAY)
1221 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1227 if (check_element_type (e, convert))
1235 /* Check that all elements of an array constructor are the same type.
1236 On FAILURE, an error has been generated. */
1239 gfc_check_constructor_type (gfc_expr *e)
1243 if (e->ts.type != BT_UNKNOWN)
1245 cons_state = CONS_GOOD;
1246 constructor_ts = e->ts;
1250 cons_state = CONS_START;
1251 gfc_clear_ts (&constructor_ts);
1254 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1255 typespec, and we will now convert the values on the fly. */
1256 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1257 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1258 e->ts = constructor_ts;
1265 typedef struct cons_stack
1267 gfc_iterator *iterator;
1268 struct cons_stack *previous;
1272 static cons_stack *base;
1274 static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
1276 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1277 that that variable is an iteration variables. */
1280 gfc_check_iter_variable (gfc_expr *expr)
1285 sym = expr->symtree->n.sym;
1287 for (c = base; c; c = c->previous)
1288 if (sym == c->iterator->var->symtree->n.sym)
1295 /* Recursive work function for gfc_check_constructor(). This amounts
1296 to calling the check function for each expression in the
1297 constructor, giving variables with the names of iterators a pass. */
1300 check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
1306 for (; c; c = c->next)
1310 if (e->expr_type != EXPR_ARRAY)
1312 if ((*check_function) (e) == FAILURE)
1317 element.previous = base;
1318 element.iterator = c->iterator;
1321 t = check_constructor (e->value.constructor, check_function);
1322 base = element.previous;
1328 /* Nothing went wrong, so all OK. */
1333 /* Checks a constructor to see if it is a particular kind of
1334 expression -- specification, restricted, or initialization as
1335 determined by the check_function. */
1338 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1340 cons_stack *base_save;
1346 t = check_constructor (expr->value.constructor, check_function);
1354 /**************** Simplification of array constructors ****************/
1356 iterator_stack *iter_stack;
1360 gfc_constructor *new_head, *new_tail;
1361 int extract_count, extract_n;
1362 gfc_expr *extracted;
1366 gfc_component *component;
1369 gfc_try (*expand_work_function) (gfc_expr *);
1373 static expand_info current_expand;
1375 static gfc_try expand_constructor (gfc_constructor *);
1378 /* Work function that counts the number of elements present in a
1382 count_elements (gfc_expr *e)
1387 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1390 if (gfc_array_size (e, &result) == FAILURE)
1396 mpz_add (*current_expand.count, *current_expand.count, result);
1405 /* Work function that extracts a particular element from an array
1406 constructor, freeing the rest. */
1409 extract_element (gfc_expr *e)
1412 { /* Something unextractable */
1417 if (current_expand.extract_count == current_expand.extract_n)
1418 current_expand.extracted = e;
1422 current_expand.extract_count++;
1428 /* Work function that constructs a new constructor out of the old one,
1429 stringing new elements together. */
1432 expand (gfc_expr *e)
1434 if (current_expand.new_head == NULL)
1435 current_expand.new_head = current_expand.new_tail =
1436 gfc_get_constructor ();
1439 current_expand.new_tail->next = gfc_get_constructor ();
1440 current_expand.new_tail = current_expand.new_tail->next;
1443 current_expand.new_tail->where = e->where;
1444 current_expand.new_tail->expr = e;
1446 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1447 current_expand.new_tail->n.component = current_expand.component;
1448 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1453 /* Given an initialization expression that is a variable reference,
1454 substitute the current value of the iteration variable. */
1457 gfc_simplify_iterator_var (gfc_expr *e)
1461 for (p = iter_stack; p; p = p->prev)
1462 if (e->symtree == p->variable)
1466 return; /* Variable not found */
1468 gfc_replace_expr (e, gfc_int_expr (0));
1470 mpz_set (e->value.integer, p->value);
1476 /* Expand an expression with that is inside of a constructor,
1477 recursing into other constructors if present. */
1480 expand_expr (gfc_expr *e)
1482 if (e->expr_type == EXPR_ARRAY)
1483 return expand_constructor (e->value.constructor);
1485 e = gfc_copy_expr (e);
1487 if (gfc_simplify_expr (e, 1) == FAILURE)
1493 return current_expand.expand_work_function (e);
1498 expand_iterator (gfc_constructor *c)
1500 gfc_expr *start, *end, *step;
1501 iterator_stack frame;
1510 mpz_init (frame.value);
1513 start = gfc_copy_expr (c->iterator->start);
1514 if (gfc_simplify_expr (start, 1) == FAILURE)
1517 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1520 end = gfc_copy_expr (c->iterator->end);
1521 if (gfc_simplify_expr (end, 1) == FAILURE)
1524 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1527 step = gfc_copy_expr (c->iterator->step);
1528 if (gfc_simplify_expr (step, 1) == FAILURE)
1531 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1534 if (mpz_sgn (step->value.integer) == 0)
1536 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1540 /* Calculate the trip count of the loop. */
1541 mpz_sub (trip, end->value.integer, start->value.integer);
1542 mpz_add (trip, trip, step->value.integer);
1543 mpz_tdiv_q (trip, trip, step->value.integer);
1545 mpz_set (frame.value, start->value.integer);
1547 frame.prev = iter_stack;
1548 frame.variable = c->iterator->var->symtree;
1549 iter_stack = &frame;
1551 while (mpz_sgn (trip) > 0)
1553 if (expand_expr (c->expr) == FAILURE)
1556 mpz_add (frame.value, frame.value, step->value.integer);
1557 mpz_sub_ui (trip, trip, 1);
1563 gfc_free_expr (start);
1564 gfc_free_expr (end);
1565 gfc_free_expr (step);
1568 mpz_clear (frame.value);
1570 iter_stack = frame.prev;
1576 /* Expand a constructor into constant constructors without any
1577 iterators, calling the work function for each of the expanded
1578 expressions. The work function needs to either save or free the
1579 passed expression. */
1582 expand_constructor (gfc_constructor *c)
1586 for (; c; c = c->next)
1588 if (c->iterator != NULL)
1590 if (expand_iterator (c) == FAILURE)
1597 if (e->expr_type == EXPR_ARRAY)
1599 if (expand_constructor (e->value.constructor) == FAILURE)
1605 e = gfc_copy_expr (e);
1606 if (gfc_simplify_expr (e, 1) == FAILURE)
1611 current_expand.offset = &c->n.offset;
1612 current_expand.component = c->n.component;
1613 current_expand.repeat = &c->repeat;
1614 if (current_expand.expand_work_function (e) == FAILURE)
1621 /* Top level subroutine for expanding constructors. We only expand
1622 constructor if they are small enough. */
1625 gfc_expand_constructor (gfc_expr *e)
1627 expand_info expand_save;
1631 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1638 expand_save = current_expand;
1639 current_expand.new_head = current_expand.new_tail = NULL;
1643 current_expand.expand_work_function = expand;
1645 if (expand_constructor (e->value.constructor) == FAILURE)
1647 gfc_free_constructor (current_expand.new_head);
1652 gfc_free_constructor (e->value.constructor);
1653 e->value.constructor = current_expand.new_head;
1658 current_expand = expand_save;
1664 /* Work function for checking that an element of a constructor is a
1665 constant, after removal of any iteration variables. We return
1666 FAILURE if not so. */
1669 is_constant_element (gfc_expr *e)
1673 rv = gfc_is_constant_expr (e);
1676 return rv ? SUCCESS : FAILURE;
1680 /* Given an array constructor, determine if the constructor is
1681 constant or not by expanding it and making sure that all elements
1682 are constants. This is a bit of a hack since something like (/ (i,
1683 i=1,100000000) /) will take a while as* opposed to a more clever
1684 function that traverses the expression tree. FIXME. */
1687 gfc_constant_ac (gfc_expr *e)
1689 expand_info expand_save;
1691 gfc_constructor * con;
1695 if (e->value.constructor
1696 && e->value.constructor->expr->expr_type == EXPR_ARRAY)
1698 /* Expand the constructor. */
1700 expand_save = current_expand;
1701 current_expand.expand_work_function = is_constant_element;
1703 rc = expand_constructor (e->value.constructor);
1705 current_expand = expand_save;
1709 /* No need to expand this further. */
1710 for (con = e->value.constructor; con; con = con->next)
1712 if (con->expr->expr_type == EXPR_CONSTANT)
1716 if (!gfc_is_constant_expr (con->expr))
1729 /* Returns nonzero if an array constructor has been completely
1730 expanded (no iterators) and zero if iterators are present. */
1733 gfc_expanded_ac (gfc_expr *e)
1737 if (e->expr_type == EXPR_ARRAY)
1738 for (p = e->value.constructor; p; p = p->next)
1739 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1746 /*************** Type resolution of array constructors ***************/
1748 /* Recursive array list resolution function. All of the elements must
1749 be of the same type. */
1752 resolve_array_list (gfc_constructor *p)
1758 for (; p; p = p->next)
1760 if (p->iterator != NULL
1761 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1764 if (gfc_resolve_expr (p->expr) == FAILURE)
1771 /* Resolve character array constructor. If it has a specified constant character
1772 length, pad/truncate the elements here; if the length is not specified and
1773 all elements are of compile-time known length, emit an error as this is
1777 gfc_resolve_character_array_constructor (gfc_expr *expr)
1782 gcc_assert (expr->expr_type == EXPR_ARRAY);
1783 gcc_assert (expr->ts.type == BT_CHARACTER);
1785 if (expr->ts.u.cl == NULL)
1787 for (p = expr->value.constructor; p; p = p->next)
1788 if (p->expr->ts.u.cl != NULL)
1790 /* Ensure that if there is a char_len around that it is
1791 used; otherwise the middle-end confuses them! */
1792 expr->ts.u.cl = p->expr->ts.u.cl;
1796 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1803 if (expr->ts.u.cl->length == NULL)
1805 /* Check that all constant string elements have the same length until
1806 we reach the end or find a variable-length one. */
1808 for (p = expr->value.constructor; p; p = p->next)
1810 int current_length = -1;
1812 for (ref = p->expr->ref; ref; ref = ref->next)
1813 if (ref->type == REF_SUBSTRING
1814 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1815 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1818 if (p->expr->expr_type == EXPR_CONSTANT)
1819 current_length = p->expr->value.character.length;
1823 j = mpz_get_ui (ref->u.ss.end->value.integer)
1824 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1825 current_length = (int) j;
1827 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1828 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1831 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1832 current_length = (int) j;
1837 gcc_assert (current_length != -1);
1839 if (found_length == -1)
1840 found_length = current_length;
1841 else if (found_length != current_length)
1843 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1844 " constructor at %L", found_length, current_length,
1849 gcc_assert (found_length == current_length);
1852 gcc_assert (found_length != -1);
1854 /* Update the character length of the array constructor. */
1855 expr->ts.u.cl->length = gfc_int_expr (found_length);
1859 /* We've got a character length specified. It should be an integer,
1860 otherwise an error is signalled elsewhere. */
1861 gcc_assert (expr->ts.u.cl->length);
1863 /* If we've got a constant character length, pad according to this.
1864 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1865 max_length only if they pass. */
1866 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1868 /* Now pad/truncate the elements accordingly to the specified character
1869 length. This is ok inside this conditional, as in the case above
1870 (without typespec) all elements are verified to have the same length
1872 if (found_length != -1)
1873 for (p = expr->value.constructor; p; p = p->next)
1874 if (p->expr->expr_type == EXPR_CONSTANT)
1876 gfc_expr *cl = NULL;
1877 int current_length = -1;
1880 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1882 cl = p->expr->ts.u.cl->length;
1883 gfc_extract_int (cl, ¤t_length);
1886 /* If gfc_extract_int above set current_length, we implicitly
1887 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1889 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1892 || (current_length != -1 && current_length < found_length))
1893 gfc_set_constant_character_len (found_length, p->expr,
1894 has_ts ? -1 : found_length);
1902 /* Resolve all of the expressions in an array list. */
1905 gfc_resolve_array_constructor (gfc_expr *expr)
1909 t = resolve_array_list (expr->value.constructor);
1911 t = gfc_check_constructor_type (expr);
1913 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1914 the call to this function, so we don't need to call it here; if it was
1915 called twice, an error message there would be duplicated. */
1921 /* Copy an iterator structure. */
1923 static gfc_iterator *
1924 copy_iterator (gfc_iterator *src)
1931 dest = gfc_get_iterator ();
1933 dest->var = gfc_copy_expr (src->var);
1934 dest->start = gfc_copy_expr (src->start);
1935 dest->end = gfc_copy_expr (src->end);
1936 dest->step = gfc_copy_expr (src->step);
1942 /* Copy a constructor structure. */
1945 gfc_copy_constructor (gfc_constructor *src)
1947 gfc_constructor *dest;
1948 gfc_constructor *tail;
1957 dest = tail = gfc_get_constructor ();
1960 tail->next = gfc_get_constructor ();
1963 tail->where = src->where;
1964 tail->expr = gfc_copy_expr (src->expr);
1965 tail->iterator = copy_iterator (src->iterator);
1966 mpz_set (tail->n.offset, src->n.offset);
1967 tail->n.component = src->n.component;
1968 mpz_set (tail->repeat, src->repeat);
1976 /* Given an array expression and an element number (starting at zero),
1977 return a pointer to the array element. NULL is returned if the
1978 size of the array has been exceeded. The expression node returned
1979 remains a part of the array and should not be freed. Access is not
1980 efficient at all, but this is another place where things do not
1981 have to be particularly fast. */
1984 gfc_get_array_element (gfc_expr *array, int element)
1986 expand_info expand_save;
1990 expand_save = current_expand;
1991 current_expand.extract_n = element;
1992 current_expand.expand_work_function = extract_element;
1993 current_expand.extracted = NULL;
1994 current_expand.extract_count = 0;
1998 rc = expand_constructor (array->value.constructor);
1999 e = current_expand.extracted;
2000 current_expand = expand_save;
2009 /********* Subroutines for determining the size of an array *********/
2011 /* These are needed just to accommodate RESHAPE(). There are no
2012 diagnostics here, we just return a negative number if something
2016 /* Get the size of single dimension of an array specification. The
2017 array is guaranteed to be one dimensional. */
2020 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2025 if (dimen < 0 || dimen > as->rank - 1)
2026 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2028 if (as->type != AS_EXPLICIT
2029 || as->lower[dimen]->expr_type != EXPR_CONSTANT
2030 || as->upper[dimen]->expr_type != EXPR_CONSTANT
2031 || as->lower[dimen]->ts.type != BT_INTEGER
2032 || as->upper[dimen]->ts.type != BT_INTEGER)
2037 mpz_sub (*result, as->upper[dimen]->value.integer,
2038 as->lower[dimen]->value.integer);
2040 mpz_add_ui (*result, *result, 1);
2047 spec_size (gfc_array_spec *as, mpz_t *result)
2052 mpz_init_set_ui (*result, 1);
2054 for (d = 0; d < as->rank; d++)
2056 if (spec_dimen_size (as, d, &size) == FAILURE)
2058 mpz_clear (*result);
2062 mpz_mul (*result, *result, size);
2070 /* Get the number of elements in an array section. */
2073 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
2075 mpz_t upper, lower, stride;
2078 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
2079 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2081 switch (ar->dimen_type[dimen])
2085 mpz_set_ui (*result, 1);
2090 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2099 if (ar->start[dimen] == NULL)
2101 if (ar->as->lower[dimen] == NULL
2102 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
2104 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2108 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2110 mpz_set (lower, ar->start[dimen]->value.integer);
2113 if (ar->end[dimen] == NULL)
2115 if (ar->as->upper[dimen] == NULL
2116 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2118 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2122 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2124 mpz_set (upper, ar->end[dimen]->value.integer);
2127 if (ar->stride[dimen] == NULL)
2128 mpz_set_ui (stride, 1);
2131 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2133 mpz_set (stride, ar->stride[dimen]->value.integer);
2137 mpz_sub (*result, upper, lower);
2138 mpz_add (*result, *result, stride);
2139 mpz_div (*result, *result, stride);
2141 /* Zero stride caught earlier. */
2142 if (mpz_cmp_ui (*result, 0) < 0)
2143 mpz_set_ui (*result, 0);
2153 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2161 ref_size (gfc_array_ref *ar, mpz_t *result)
2166 mpz_init_set_ui (*result, 1);
2168 for (d = 0; d < ar->dimen; d++)
2170 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2172 mpz_clear (*result);
2176 mpz_mul (*result, *result, size);
2184 /* Given an array expression and a dimension, figure out how many
2185 elements it has along that dimension. Returns SUCCESS if we were
2186 able to return a result in the 'result' variable, FAILURE
2190 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2195 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2196 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2198 switch (array->expr_type)
2202 for (ref = array->ref; ref; ref = ref->next)
2204 if (ref->type != REF_ARRAY)
2207 if (ref->u.ar.type == AR_FULL)
2208 return spec_dimen_size (ref->u.ar.as, dimen, result);
2210 if (ref->u.ar.type == AR_SECTION)
2212 for (i = 0; dimen >= 0; i++)
2213 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2216 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2220 if (array->shape && array->shape[dimen])
2222 mpz_init_set (*result, array->shape[dimen]);
2226 if (array->symtree->n.sym->attr.generic
2227 && array->value.function.esym != NULL)
2229 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2233 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2240 if (array->shape == NULL) {
2241 /* Expressions with rank > 1 should have "shape" properly set */
2242 if ( array->rank != 1 )
2243 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2244 return gfc_array_size(array, result);
2249 if (array->shape == NULL)
2252 mpz_init_set (*result, array->shape[dimen]);
2261 /* Given an array expression, figure out how many elements are in the
2262 array. Returns SUCCESS if this is possible, and sets the 'result'
2263 variable. Otherwise returns FAILURE. */
2266 gfc_array_size (gfc_expr *array, mpz_t *result)
2268 expand_info expand_save;
2273 switch (array->expr_type)
2276 gfc_push_suppress_errors ();
2278 expand_save = current_expand;
2280 current_expand.count = result;
2281 mpz_init_set_ui (*result, 0);
2283 current_expand.expand_work_function = count_elements;
2286 t = expand_constructor (array->value.constructor);
2288 gfc_pop_suppress_errors ();
2291 mpz_clear (*result);
2292 current_expand = expand_save;
2296 for (ref = array->ref; ref; ref = ref->next)
2298 if (ref->type != REF_ARRAY)
2301 if (ref->u.ar.type == AR_FULL)
2302 return spec_size (ref->u.ar.as, result);
2304 if (ref->u.ar.type == AR_SECTION)
2305 return ref_size (&ref->u.ar, result);
2308 return spec_size (array->symtree->n.sym->as, result);
2312 if (array->rank == 0 || array->shape == NULL)
2315 mpz_init_set_ui (*result, 1);
2317 for (i = 0; i < array->rank; i++)
2318 mpz_mul (*result, *result, array->shape[i]);
2327 /* Given an array reference, return the shape of the reference in an
2328 array of mpz_t integers. */
2331 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2341 for (; d < ar->as->rank; d++)
2342 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2348 for (i = 0; i < ar->dimen; i++)
2350 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2352 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2365 for (d--; d >= 0; d--)
2366 mpz_clear (shape[d]);
2372 /* Given an array expression, find the array reference structure that
2373 characterizes the reference. */
2376 gfc_find_array_ref (gfc_expr *e)
2380 for (ref = e->ref; ref; ref = ref->next)
2381 if (ref->type == REF_ARRAY
2382 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2386 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2392 /* Find out if an array shape is known at compile time. */
2395 gfc_is_compile_time_shape (gfc_array_spec *as)
2399 if (as->type != AS_EXPLICIT)
2402 for (i = 0; i < as->rank; i++)
2403 if (!gfc_is_constant_expr (as->lower[i])
2404 || !gfc_is_constant_expr (as->upper[i]))