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, bool match_star)
70 i = ar->dimen + ar->codimen;
72 ar->c_where[i] = gfc_current_locus;
73 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
75 /* We can't be sure of the difference between DIMEN_ELEMENT and
76 DIMEN_VECTOR until we know the type of the element itself at
79 ar->dimen_type[i] = DIMEN_UNKNOWN;
81 if (gfc_match_char (':') == MATCH_YES)
84 /* Get start element. */
85 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
89 m = gfc_match_init_expr (&ar->start[i]);
91 m = gfc_match_expr (&ar->start[i]);
94 gfc_error ("Expected array subscript at %C");
98 if (gfc_match_char (':') == MATCH_NO)
103 gfc_error ("Unexpected '*' in coarray subscript at %C");
107 /* Get an optional end element. Because we've seen the colon, we
108 definitely have a range along this dimension. */
110 ar->dimen_type[i] = DIMEN_RANGE;
112 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
115 m = gfc_match_init_expr (&ar->end[i]);
117 m = gfc_match_expr (&ar->end[i]);
119 if (m == MATCH_ERROR)
122 /* See if we have an optional stride. */
123 if (gfc_match_char (':') == MATCH_YES)
127 gfc_error ("Strides not allowed in coarray subscript at %C");
131 m = init ? gfc_match_init_expr (&ar->stride[i])
132 : gfc_match_expr (&ar->stride[i]);
135 gfc_error ("Expected array subscript stride at %C");
142 ar->dimen_type[i] = DIMEN_STAR;
148 /* Match an array reference, whether it is the whole array or a
149 particular elements or a section. If init is set, the reference has
150 to consist of init expressions. */
153 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
157 bool matched_bracket = false;
159 memset (ar, '\0', sizeof (ar));
161 ar->where = gfc_current_locus;
163 ar->type = AR_UNKNOWN;
165 if (gfc_match_char ('[') == MATCH_YES)
167 matched_bracket = true;
171 if (gfc_match_char ('(') != MATCH_YES)
178 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
180 m = match_subscript (ar, init, false);
181 if (m == MATCH_ERROR)
184 if (gfc_match_char (')') == MATCH_YES)
190 if (gfc_match_char (',') != MATCH_YES)
192 gfc_error ("Invalid form of array reference at %C");
197 gfc_error ("Array reference at %C cannot have more than %d dimensions",
202 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
210 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
212 gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
218 gfc_error ("Unexpected coarray designator at %C");
222 for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
224 m = match_subscript (ar, init, ar->codimen == (corank - 1));
225 if (m == MATCH_ERROR)
228 if (gfc_match_char (']') == MATCH_YES)
234 if (gfc_match_char (',') != MATCH_YES)
236 gfc_error ("Invalid form of coarray reference at %C");
241 gfc_error ("Array reference at %C cannot have more than %d dimensions",
248 /************** Array specification matching subroutines ***************/
250 /* Free all of the expressions associated with array bounds
254 gfc_free_array_spec (gfc_array_spec *as)
261 for (i = 0; i < as->rank + as->corank; i++)
263 gfc_free_expr (as->lower[i]);
264 gfc_free_expr (as->upper[i]);
271 /* Take an array bound, resolves the expression, that make up the
272 shape and check associated constraints. */
275 resolve_array_bound (gfc_expr *e, int check_constant)
280 if (gfc_resolve_expr (e) == FAILURE
281 || gfc_specification_expr (e) == FAILURE)
284 if (check_constant && gfc_is_constant_expr (e) == 0)
286 gfc_error ("Variable '%s' at %L in this context must be constant",
287 e->symtree->n.sym->name, &e->where);
295 /* Takes an array specification, resolves the expressions that make up
296 the shape and make sure everything is integral. */
299 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
307 for (i = 0; i < as->rank + as->corank; i++)
310 if (resolve_array_bound (e, check_constant) == FAILURE)
314 if (resolve_array_bound (e, check_constant) == FAILURE)
317 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
320 /* If the size is negative in this dimension, set it to zero. */
321 if (as->lower[i]->expr_type == EXPR_CONSTANT
322 && as->upper[i]->expr_type == EXPR_CONSTANT
323 && mpz_cmp (as->upper[i]->value.integer,
324 as->lower[i]->value.integer) < 0)
326 gfc_free_expr (as->upper[i]);
327 as->upper[i] = gfc_copy_expr (as->lower[i]);
328 mpz_sub_ui (as->upper[i]->value.integer,
329 as->upper[i]->value.integer, 1);
337 /* Match a single array element specification. The return values as
338 well as the upper and lower bounds of the array spec are filled
339 in according to what we see on the input. The caller makes sure
340 individual specifications make sense as a whole.
343 Parsed Lower Upper Returned
344 ------------------------------------
345 : NULL NULL AS_DEFERRED (*)
347 x: x NULL AS_ASSUMED_SHAPE
349 x:* x NULL AS_ASSUMED_SIZE
350 * 1 NULL AS_ASSUMED_SIZE
352 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
353 is fixed during the resolution of formal interfaces.
355 Anything else AS_UNKNOWN. */
358 match_array_element_spec (gfc_array_spec *as)
360 gfc_expr **upper, **lower;
363 lower = &as->lower[as->rank + as->corank - 1];
364 upper = &as->upper[as->rank + as->corank - 1];
366 if (gfc_match_char ('*') == MATCH_YES)
368 *lower = gfc_int_expr (1);
369 return AS_ASSUMED_SIZE;
372 if (gfc_match_char (':') == MATCH_YES)
375 m = gfc_match_expr (upper);
377 gfc_error ("Expected expression in array specification at %C");
380 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
383 if (gfc_match_char (':') == MATCH_NO)
385 *lower = gfc_int_expr (1);
392 if (gfc_match_char ('*') == MATCH_YES)
393 return AS_ASSUMED_SIZE;
395 m = gfc_match_expr (upper);
396 if (m == MATCH_ERROR)
399 return AS_ASSUMED_SHAPE;
400 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
407 /* Matches an array specification, incidentally figuring out what sort
408 it is. Match either a normal array specification, or a coarray spec
409 or both. Optionally allow [:] for coarrays. */
412 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
414 array_type current_type;
418 as = gfc_get_array_spec ();
422 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
431 if (gfc_match_char ('(') != MATCH_YES)
441 current_type = match_array_element_spec (as);
445 if (current_type == AS_UNKNOWN)
447 as->type = current_type;
451 { /* See how current spec meshes with the existing. */
456 if (current_type == AS_ASSUMED_SIZE)
458 as->type = AS_ASSUMED_SIZE;
462 if (current_type == AS_EXPLICIT)
465 gfc_error ("Bad array specification for an explicitly shaped "
470 case AS_ASSUMED_SHAPE:
471 if ((current_type == AS_ASSUMED_SHAPE)
472 || (current_type == AS_DEFERRED))
475 gfc_error ("Bad array specification for assumed shape "
480 if (current_type == AS_DEFERRED)
483 if (current_type == AS_ASSUMED_SHAPE)
485 as->type = AS_ASSUMED_SHAPE;
489 gfc_error ("Bad specification for deferred shape array at %C");
492 case AS_ASSUMED_SIZE:
493 gfc_error ("Bad specification for assumed size array at %C");
497 if (gfc_match_char (')') == MATCH_YES)
500 if (gfc_match_char (',') != MATCH_YES)
502 gfc_error ("Expected another dimension in array declaration at %C");
506 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
508 gfc_error ("Array specification at %C has more than %d dimensions",
513 if (as->corank + as->rank >= 7
514 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
515 "specification at %C with more than 7 dimensions")
524 if (gfc_match_char ('[') != MATCH_YES)
527 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
531 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
533 gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
540 current_type = match_array_element_spec (as);
542 if (current_type == AS_UNKNOWN)
546 as->cotype = current_type;
549 { /* See how current spec meshes with the existing. */
554 if (current_type == AS_ASSUMED_SIZE)
556 as->cotype = AS_ASSUMED_SIZE;
560 if (current_type == AS_EXPLICIT)
563 gfc_error ("Bad array specification for an explicitly "
564 "shaped array at %C");
568 case AS_ASSUMED_SHAPE:
569 if ((current_type == AS_ASSUMED_SHAPE)
570 || (current_type == AS_DEFERRED))
573 gfc_error ("Bad array specification for assumed shape "
578 if (current_type == AS_DEFERRED)
581 if (current_type == AS_ASSUMED_SHAPE)
583 as->cotype = AS_ASSUMED_SHAPE;
587 gfc_error ("Bad specification for deferred shape array at %C");
590 case AS_ASSUMED_SIZE:
591 gfc_error ("Bad specification for assumed size array at %C");
595 if (gfc_match_char (']') == MATCH_YES)
598 if (gfc_match_char (',') != MATCH_YES)
600 gfc_error ("Expected another dimension in array declaration at %C");
604 if (as->corank >= GFC_MAX_DIMENSIONS)
606 gfc_error ("Array specification at %C has more than %d "
607 "dimensions", GFC_MAX_DIMENSIONS);
612 if (current_type == AS_EXPLICIT)
614 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
618 if (as->cotype == AS_ASSUMED_SIZE)
619 as->cotype = AS_EXPLICIT;
622 as->type = as->cotype;
625 if (as->rank == 0 && as->corank == 0)
628 gfc_free_array_spec (as);
632 /* If a lower bounds of an assumed shape array is blank, put in one. */
633 if (as->type == AS_ASSUMED_SHAPE)
635 for (i = 0; i < as->rank + as->corank; i++)
637 if (as->lower[i] == NULL)
638 as->lower[i] = gfc_int_expr (1);
647 /* Something went wrong. */
648 gfc_free_array_spec (as);
653 /* Given a symbol and an array specification, modify the symbol to
654 have that array specification. The error locus is needed in case
655 something goes wrong. On failure, the caller must free the spec. */
658 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
666 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
670 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
681 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
682 the codimension is simply added. */
683 gcc_assert (as->rank == 0 && sym->as->corank == 0);
685 sym->as->cotype = as->cotype;
686 sym->as->corank = as->corank;
687 for (i = 0; i < as->corank; i++)
689 sym->as->lower[sym->as->rank + i] = as->lower[i];
690 sym->as->upper[sym->as->rank + i] = as->upper[i];
695 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
696 the dimension is added - but first the codimensions (if existing
697 need to be shifted to make space for the dimension. */
698 gcc_assert (as->corank == 0 && sym->as->rank == 0);
700 sym->as->rank = as->rank;
701 sym->as->type = as->type;
702 sym->as->cray_pointee = as->cray_pointee;
703 sym->as->cp_was_assumed = as->cp_was_assumed;
705 for (i = 0; i < sym->as->corank; i++)
707 sym->as->lower[as->rank + i] = sym->as->lower[i];
708 sym->as->upper[as->rank + i] = sym->as->upper[i];
710 for (i = 0; i < as->rank; i++)
712 sym->as->lower[i] = as->lower[i];
713 sym->as->upper[i] = as->upper[i];
722 /* Copy an array specification. */
725 gfc_copy_array_spec (gfc_array_spec *src)
727 gfc_array_spec *dest;
733 dest = gfc_get_array_spec ();
737 for (i = 0; i < dest->rank + dest->corank; i++)
739 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
740 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
747 /* Returns nonzero if the two expressions are equal. Only handles integer
751 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
753 if (bound1 == NULL || bound2 == NULL
754 || bound1->expr_type != EXPR_CONSTANT
755 || bound2->expr_type != EXPR_CONSTANT
756 || bound1->ts.type != BT_INTEGER
757 || bound2->ts.type != BT_INTEGER)
758 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
760 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
767 /* Compares two array specifications. They must be constant or deferred
771 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
775 if (as1 == NULL && as2 == NULL)
778 if (as1 == NULL || as2 == NULL)
781 if (as1->rank != as2->rank)
784 if (as1->corank != as2->corank)
790 if (as1->type != as2->type)
793 if (as1->type == AS_EXPLICIT)
794 for (i = 0; i < as1->rank + as1->corank; i++)
796 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
799 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
807 /****************** Array constructor functions ******************/
809 /* Start an array constructor. The constructor starts with zero
810 elements and should be appended to by gfc_append_constructor(). */
813 gfc_start_constructor (bt type, int kind, locus *where)
817 result = gfc_get_expr ();
819 result->expr_type = EXPR_ARRAY;
822 result->ts.type = type;
823 result->ts.kind = kind;
824 result->where = *where;
829 /* Given an array constructor expression, append the new expression
830 node onto the constructor. */
833 gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
837 if (base->value.constructor == NULL)
838 base->value.constructor = c = gfc_get_constructor ();
841 c = base->value.constructor;
845 c->next = gfc_get_constructor ();
852 && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
853 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
857 /* Given an array constructor expression, insert the new expression's
858 constructor onto the base's one according to the offset. */
861 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
863 gfc_constructor *c, *pre;
867 type = base->expr_type;
869 if (base->value.constructor == NULL)
870 base->value.constructor = c1;
873 c = pre = base->value.constructor;
876 if (type == EXPR_ARRAY)
878 t = mpz_cmp (c->n.offset, c1->n.offset);
886 gfc_error ("duplicated initializer");
907 base->value.constructor = c1;
913 /* Get a new constructor. */
916 gfc_get_constructor (void)
920 c = XCNEW (gfc_constructor);
924 mpz_init_set_si (c->n.offset, 0);
925 mpz_init_set_si (c->repeat, 0);
930 /* Free chains of gfc_constructor structures. */
933 gfc_free_constructor (gfc_constructor *p)
935 gfc_constructor *next;
945 gfc_free_expr (p->expr);
946 if (p->iterator != NULL)
947 gfc_free_iterator (p->iterator, 1);
948 mpz_clear (p->n.offset);
949 mpz_clear (p->repeat);
955 /* Given an expression node that might be an array constructor and a
956 symbol, make sure that no iterators in this or child constructors
957 use the symbol as an implied-DO iterator. Returns nonzero if a
958 duplicate was found. */
961 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
965 for (; c; c = c->next)
969 if (e->expr_type == EXPR_ARRAY
970 && check_duplicate_iterator (e->value.constructor, master))
973 if (c->iterator == NULL)
976 if (c->iterator->var->symtree->n.sym == master)
978 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
979 "same name", master->name, &c->where);
989 /* Forward declaration because these functions are mutually recursive. */
990 static match match_array_cons_element (gfc_constructor **);
992 /* Match a list of array elements. */
995 match_array_list (gfc_constructor **result)
997 gfc_constructor *p, *head, *tail, *new_cons;
1004 old_loc = gfc_current_locus;
1006 if (gfc_match_char ('(') == MATCH_NO)
1009 memset (&iter, '\0', sizeof (gfc_iterator));
1012 m = match_array_cons_element (&head);
1018 if (gfc_match_char (',') != MATCH_YES)
1026 m = gfc_match_iterator (&iter, 0);
1029 if (m == MATCH_ERROR)
1032 m = match_array_cons_element (&new_cons);
1033 if (m == MATCH_ERROR)
1040 goto cleanup; /* Could be a complex constant */
1043 tail->next = new_cons;
1046 if (gfc_match_char (',') != MATCH_YES)
1055 if (gfc_match_char (')') != MATCH_YES)
1058 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
1064 e = gfc_get_expr ();
1065 e->expr_type = EXPR_ARRAY;
1067 e->value.constructor = head;
1069 p = gfc_get_constructor ();
1070 p->where = gfc_current_locus;
1071 p->iterator = gfc_get_iterator ();
1072 *p->iterator = iter;
1080 gfc_error ("Syntax error in array constructor at %C");
1084 gfc_free_constructor (head);
1085 gfc_free_iterator (&iter, 0);
1086 gfc_current_locus = old_loc;
1091 /* Match a single element of an array constructor, which can be a
1092 single expression or a list of elements. */
1095 match_array_cons_element (gfc_constructor **result)
1101 m = match_array_list (result);
1105 m = gfc_match_expr (&expr);
1109 p = gfc_get_constructor ();
1110 p->where = gfc_current_locus;
1118 /* Match an array constructor. */
1121 gfc_match_array_constructor (gfc_expr **result)
1123 gfc_constructor *head, *tail, *new_cons;
1128 const char *end_delim;
1131 if (gfc_match (" (/") == MATCH_NO)
1133 if (gfc_match (" [") == MATCH_NO)
1137 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1138 "style array constructors at %C") == FAILURE)
1146 where = gfc_current_locus;
1150 /* Try to match an optional "type-spec ::" */
1151 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1153 seen_ts = (gfc_match (" ::") == MATCH_YES);
1157 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1158 "including type specification at %C") == FAILURE)
1164 gfc_current_locus = where;
1166 if (gfc_match (end_delim) == MATCH_YES)
1172 gfc_error ("Empty array constructor at %C is not allowed");
1179 m = match_array_cons_element (&new_cons);
1180 if (m == MATCH_ERROR)
1188 tail->next = new_cons;
1192 if (gfc_match_char (',') == MATCH_NO)
1196 if (gfc_match (end_delim) == MATCH_NO)
1200 expr = gfc_get_expr ();
1202 expr->expr_type = EXPR_ARRAY;
1204 expr->value.constructor = head;
1205 /* Size must be calculated at resolution time. */
1210 expr->ts.type = BT_UNKNOWN;
1213 expr->ts.u.cl->length_from_typespec = seen_ts;
1215 expr->where = where;
1222 gfc_error ("Syntax error in array constructor at %C");
1225 gfc_free_constructor (head);
1231 /************** Check array constructors for correctness **************/
1233 /* Given an expression, compare it's type with the type of the current
1234 constructor. Returns nonzero if an error was issued. The
1235 cons_state variable keeps track of whether the type of the
1236 constructor being read or resolved is known to be good, bad or just
1239 static gfc_typespec constructor_ts;
1241 { CONS_START, CONS_GOOD, CONS_BAD }
1245 check_element_type (gfc_expr *expr, bool convert)
1247 if (cons_state == CONS_BAD)
1248 return 0; /* Suppress further errors */
1250 if (cons_state == CONS_START)
1252 if (expr->ts.type == BT_UNKNOWN)
1253 cons_state = CONS_BAD;
1256 cons_state = CONS_GOOD;
1257 constructor_ts = expr->ts;
1263 if (gfc_compare_types (&constructor_ts, &expr->ts))
1267 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1269 gfc_error ("Element in %s array constructor at %L is %s",
1270 gfc_typename (&constructor_ts), &expr->where,
1271 gfc_typename (&expr->ts));
1273 cons_state = CONS_BAD;
1278 /* Recursive work function for gfc_check_constructor_type(). */
1281 check_constructor_type (gfc_constructor *c, bool convert)
1285 for (; c; c = c->next)
1289 if (e->expr_type == EXPR_ARRAY)
1291 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1297 if (check_element_type (e, convert))
1305 /* Check that all elements of an array constructor are the same type.
1306 On FAILURE, an error has been generated. */
1309 gfc_check_constructor_type (gfc_expr *e)
1313 if (e->ts.type != BT_UNKNOWN)
1315 cons_state = CONS_GOOD;
1316 constructor_ts = e->ts;
1320 cons_state = CONS_START;
1321 gfc_clear_ts (&constructor_ts);
1324 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1325 typespec, and we will now convert the values on the fly. */
1326 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1327 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1328 e->ts = constructor_ts;
1335 typedef struct cons_stack
1337 gfc_iterator *iterator;
1338 struct cons_stack *previous;
1342 static cons_stack *base;
1344 static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
1346 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1347 that that variable is an iteration variables. */
1350 gfc_check_iter_variable (gfc_expr *expr)
1355 sym = expr->symtree->n.sym;
1357 for (c = base; c; c = c->previous)
1358 if (sym == c->iterator->var->symtree->n.sym)
1365 /* Recursive work function for gfc_check_constructor(). This amounts
1366 to calling the check function for each expression in the
1367 constructor, giving variables with the names of iterators a pass. */
1370 check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
1376 for (; c; c = c->next)
1380 if (e->expr_type != EXPR_ARRAY)
1382 if ((*check_function) (e) == FAILURE)
1387 element.previous = base;
1388 element.iterator = c->iterator;
1391 t = check_constructor (e->value.constructor, check_function);
1392 base = element.previous;
1398 /* Nothing went wrong, so all OK. */
1403 /* Checks a constructor to see if it is a particular kind of
1404 expression -- specification, restricted, or initialization as
1405 determined by the check_function. */
1408 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1410 cons_stack *base_save;
1416 t = check_constructor (expr->value.constructor, check_function);
1424 /**************** Simplification of array constructors ****************/
1426 iterator_stack *iter_stack;
1430 gfc_constructor *new_head, *new_tail;
1431 int extract_count, extract_n;
1432 gfc_expr *extracted;
1436 gfc_component *component;
1439 gfc_try (*expand_work_function) (gfc_expr *);
1443 static expand_info current_expand;
1445 static gfc_try expand_constructor (gfc_constructor *);
1448 /* Work function that counts the number of elements present in a
1452 count_elements (gfc_expr *e)
1457 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1460 if (gfc_array_size (e, &result) == FAILURE)
1466 mpz_add (*current_expand.count, *current_expand.count, result);
1475 /* Work function that extracts a particular element from an array
1476 constructor, freeing the rest. */
1479 extract_element (gfc_expr *e)
1482 { /* Something unextractable */
1487 if (current_expand.extract_count == current_expand.extract_n)
1488 current_expand.extracted = e;
1492 current_expand.extract_count++;
1498 /* Work function that constructs a new constructor out of the old one,
1499 stringing new elements together. */
1502 expand (gfc_expr *e)
1504 if (current_expand.new_head == NULL)
1505 current_expand.new_head = current_expand.new_tail =
1506 gfc_get_constructor ();
1509 current_expand.new_tail->next = gfc_get_constructor ();
1510 current_expand.new_tail = current_expand.new_tail->next;
1513 current_expand.new_tail->where = e->where;
1514 current_expand.new_tail->expr = e;
1516 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1517 current_expand.new_tail->n.component = current_expand.component;
1518 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1523 /* Given an initialization expression that is a variable reference,
1524 substitute the current value of the iteration variable. */
1527 gfc_simplify_iterator_var (gfc_expr *e)
1531 for (p = iter_stack; p; p = p->prev)
1532 if (e->symtree == p->variable)
1536 return; /* Variable not found */
1538 gfc_replace_expr (e, gfc_int_expr (0));
1540 mpz_set (e->value.integer, p->value);
1546 /* Expand an expression with that is inside of a constructor,
1547 recursing into other constructors if present. */
1550 expand_expr (gfc_expr *e)
1552 if (e->expr_type == EXPR_ARRAY)
1553 return expand_constructor (e->value.constructor);
1555 e = gfc_copy_expr (e);
1557 if (gfc_simplify_expr (e, 1) == FAILURE)
1563 return current_expand.expand_work_function (e);
1568 expand_iterator (gfc_constructor *c)
1570 gfc_expr *start, *end, *step;
1571 iterator_stack frame;
1580 mpz_init (frame.value);
1583 start = gfc_copy_expr (c->iterator->start);
1584 if (gfc_simplify_expr (start, 1) == FAILURE)
1587 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1590 end = gfc_copy_expr (c->iterator->end);
1591 if (gfc_simplify_expr (end, 1) == FAILURE)
1594 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1597 step = gfc_copy_expr (c->iterator->step);
1598 if (gfc_simplify_expr (step, 1) == FAILURE)
1601 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1604 if (mpz_sgn (step->value.integer) == 0)
1606 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1610 /* Calculate the trip count of the loop. */
1611 mpz_sub (trip, end->value.integer, start->value.integer);
1612 mpz_add (trip, trip, step->value.integer);
1613 mpz_tdiv_q (trip, trip, step->value.integer);
1615 mpz_set (frame.value, start->value.integer);
1617 frame.prev = iter_stack;
1618 frame.variable = c->iterator->var->symtree;
1619 iter_stack = &frame;
1621 while (mpz_sgn (trip) > 0)
1623 if (expand_expr (c->expr) == FAILURE)
1626 mpz_add (frame.value, frame.value, step->value.integer);
1627 mpz_sub_ui (trip, trip, 1);
1633 gfc_free_expr (start);
1634 gfc_free_expr (end);
1635 gfc_free_expr (step);
1638 mpz_clear (frame.value);
1640 iter_stack = frame.prev;
1646 /* Expand a constructor into constant constructors without any
1647 iterators, calling the work function for each of the expanded
1648 expressions. The work function needs to either save or free the
1649 passed expression. */
1652 expand_constructor (gfc_constructor *c)
1656 for (; c; c = c->next)
1658 if (c->iterator != NULL)
1660 if (expand_iterator (c) == FAILURE)
1667 if (e->expr_type == EXPR_ARRAY)
1669 if (expand_constructor (e->value.constructor) == FAILURE)
1675 e = gfc_copy_expr (e);
1676 if (gfc_simplify_expr (e, 1) == FAILURE)
1681 current_expand.offset = &c->n.offset;
1682 current_expand.component = c->n.component;
1683 current_expand.repeat = &c->repeat;
1684 if (current_expand.expand_work_function (e) == FAILURE)
1691 /* Top level subroutine for expanding constructors. We only expand
1692 constructor if they are small enough. */
1695 gfc_expand_constructor (gfc_expr *e)
1697 expand_info expand_save;
1701 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1708 expand_save = current_expand;
1709 current_expand.new_head = current_expand.new_tail = NULL;
1713 current_expand.expand_work_function = expand;
1715 if (expand_constructor (e->value.constructor) == FAILURE)
1717 gfc_free_constructor (current_expand.new_head);
1722 gfc_free_constructor (e->value.constructor);
1723 e->value.constructor = current_expand.new_head;
1728 current_expand = expand_save;
1734 /* Work function for checking that an element of a constructor is a
1735 constant, after removal of any iteration variables. We return
1736 FAILURE if not so. */
1739 is_constant_element (gfc_expr *e)
1743 rv = gfc_is_constant_expr (e);
1746 return rv ? SUCCESS : FAILURE;
1750 /* Given an array constructor, determine if the constructor is
1751 constant or not by expanding it and making sure that all elements
1752 are constants. This is a bit of a hack since something like (/ (i,
1753 i=1,100000000) /) will take a while as* opposed to a more clever
1754 function that traverses the expression tree. FIXME. */
1757 gfc_constant_ac (gfc_expr *e)
1759 expand_info expand_save;
1761 gfc_constructor * con;
1765 if (e->value.constructor
1766 && e->value.constructor->expr->expr_type == EXPR_ARRAY)
1768 /* Expand the constructor. */
1770 expand_save = current_expand;
1771 current_expand.expand_work_function = is_constant_element;
1773 rc = expand_constructor (e->value.constructor);
1775 current_expand = expand_save;
1779 /* No need to expand this further. */
1780 for (con = e->value.constructor; con; con = con->next)
1782 if (con->expr->expr_type == EXPR_CONSTANT)
1786 if (!gfc_is_constant_expr (con->expr))
1799 /* Returns nonzero if an array constructor has been completely
1800 expanded (no iterators) and zero if iterators are present. */
1803 gfc_expanded_ac (gfc_expr *e)
1807 if (e->expr_type == EXPR_ARRAY)
1808 for (p = e->value.constructor; p; p = p->next)
1809 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1816 /*************** Type resolution of array constructors ***************/
1818 /* Recursive array list resolution function. All of the elements must
1819 be of the same type. */
1822 resolve_array_list (gfc_constructor *p)
1828 for (; p; p = p->next)
1830 if (p->iterator != NULL
1831 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1834 if (gfc_resolve_expr (p->expr) == FAILURE)
1841 /* Resolve character array constructor. If it has a specified constant character
1842 length, pad/truncate the elements here; if the length is not specified and
1843 all elements are of compile-time known length, emit an error as this is
1847 gfc_resolve_character_array_constructor (gfc_expr *expr)
1852 gcc_assert (expr->expr_type == EXPR_ARRAY);
1853 gcc_assert (expr->ts.type == BT_CHARACTER);
1855 if (expr->ts.u.cl == NULL)
1857 for (p = expr->value.constructor; p; p = p->next)
1858 if (p->expr->ts.u.cl != NULL)
1860 /* Ensure that if there is a char_len around that it is
1861 used; otherwise the middle-end confuses them! */
1862 expr->ts.u.cl = p->expr->ts.u.cl;
1866 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1873 if (expr->ts.u.cl->length == NULL)
1875 /* Check that all constant string elements have the same length until
1876 we reach the end or find a variable-length one. */
1878 for (p = expr->value.constructor; p; p = p->next)
1880 int current_length = -1;
1882 for (ref = p->expr->ref; ref; ref = ref->next)
1883 if (ref->type == REF_SUBSTRING
1884 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1885 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1888 if (p->expr->expr_type == EXPR_CONSTANT)
1889 current_length = p->expr->value.character.length;
1893 j = mpz_get_ui (ref->u.ss.end->value.integer)
1894 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1895 current_length = (int) j;
1897 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1898 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1901 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1902 current_length = (int) j;
1907 gcc_assert (current_length != -1);
1909 if (found_length == -1)
1910 found_length = current_length;
1911 else if (found_length != current_length)
1913 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1914 " constructor at %L", found_length, current_length,
1919 gcc_assert (found_length == current_length);
1922 gcc_assert (found_length != -1);
1924 /* Update the character length of the array constructor. */
1925 expr->ts.u.cl->length = gfc_int_expr (found_length);
1929 /* We've got a character length specified. It should be an integer,
1930 otherwise an error is signalled elsewhere. */
1931 gcc_assert (expr->ts.u.cl->length);
1933 /* If we've got a constant character length, pad according to this.
1934 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1935 max_length only if they pass. */
1936 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1938 /* Now pad/truncate the elements accordingly to the specified character
1939 length. This is ok inside this conditional, as in the case above
1940 (without typespec) all elements are verified to have the same length
1942 if (found_length != -1)
1943 for (p = expr->value.constructor; p; p = p->next)
1944 if (p->expr->expr_type == EXPR_CONSTANT)
1946 gfc_expr *cl = NULL;
1947 int current_length = -1;
1950 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1952 cl = p->expr->ts.u.cl->length;
1953 gfc_extract_int (cl, ¤t_length);
1956 /* If gfc_extract_int above set current_length, we implicitly
1957 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1959 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1962 || (current_length != -1 && current_length < found_length))
1963 gfc_set_constant_character_len (found_length, p->expr,
1964 has_ts ? -1 : found_length);
1972 /* Resolve all of the expressions in an array list. */
1975 gfc_resolve_array_constructor (gfc_expr *expr)
1979 t = resolve_array_list (expr->value.constructor);
1981 t = gfc_check_constructor_type (expr);
1983 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1984 the call to this function, so we don't need to call it here; if it was
1985 called twice, an error message there would be duplicated. */
1991 /* Copy an iterator structure. */
1993 static gfc_iterator *
1994 copy_iterator (gfc_iterator *src)
2001 dest = gfc_get_iterator ();
2003 dest->var = gfc_copy_expr (src->var);
2004 dest->start = gfc_copy_expr (src->start);
2005 dest->end = gfc_copy_expr (src->end);
2006 dest->step = gfc_copy_expr (src->step);
2012 /* Copy a constructor structure. */
2015 gfc_copy_constructor (gfc_constructor *src)
2017 gfc_constructor *dest;
2018 gfc_constructor *tail;
2027 dest = tail = gfc_get_constructor ();
2030 tail->next = gfc_get_constructor ();
2033 tail->where = src->where;
2034 tail->expr = gfc_copy_expr (src->expr);
2035 tail->iterator = copy_iterator (src->iterator);
2036 mpz_set (tail->n.offset, src->n.offset);
2037 tail->n.component = src->n.component;
2038 mpz_set (tail->repeat, src->repeat);
2046 /* Given an array expression and an element number (starting at zero),
2047 return a pointer to the array element. NULL is returned if the
2048 size of the array has been exceeded. The expression node returned
2049 remains a part of the array and should not be freed. Access is not
2050 efficient at all, but this is another place where things do not
2051 have to be particularly fast. */
2054 gfc_get_array_element (gfc_expr *array, int element)
2056 expand_info expand_save;
2060 expand_save = current_expand;
2061 current_expand.extract_n = element;
2062 current_expand.expand_work_function = extract_element;
2063 current_expand.extracted = NULL;
2064 current_expand.extract_count = 0;
2068 rc = expand_constructor (array->value.constructor);
2069 e = current_expand.extracted;
2070 current_expand = expand_save;
2079 /********* Subroutines for determining the size of an array *********/
2081 /* These are needed just to accommodate RESHAPE(). There are no
2082 diagnostics here, we just return a negative number if something
2086 /* Get the size of single dimension of an array specification. The
2087 array is guaranteed to be one dimensional. */
2090 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2095 if (dimen < 0 || dimen > as->rank - 1)
2096 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2098 if (as->type != AS_EXPLICIT
2099 || as->lower[dimen]->expr_type != EXPR_CONSTANT
2100 || as->upper[dimen]->expr_type != EXPR_CONSTANT
2101 || as->lower[dimen]->ts.type != BT_INTEGER
2102 || as->upper[dimen]->ts.type != BT_INTEGER)
2107 mpz_sub (*result, as->upper[dimen]->value.integer,
2108 as->lower[dimen]->value.integer);
2110 mpz_add_ui (*result, *result, 1);
2117 spec_size (gfc_array_spec *as, mpz_t *result)
2122 mpz_init_set_ui (*result, 1);
2124 for (d = 0; d < as->rank; d++)
2126 if (spec_dimen_size (as, d, &size) == FAILURE)
2128 mpz_clear (*result);
2132 mpz_mul (*result, *result, size);
2140 /* Get the number of elements in an array section. */
2143 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
2145 mpz_t upper, lower, stride;
2148 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
2149 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2151 switch (ar->dimen_type[dimen])
2155 mpz_set_ui (*result, 1);
2160 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2169 if (ar->start[dimen] == NULL)
2171 if (ar->as->lower[dimen] == NULL
2172 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
2174 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2178 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2180 mpz_set (lower, ar->start[dimen]->value.integer);
2183 if (ar->end[dimen] == NULL)
2185 if (ar->as->upper[dimen] == NULL
2186 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2188 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2192 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2194 mpz_set (upper, ar->end[dimen]->value.integer);
2197 if (ar->stride[dimen] == NULL)
2198 mpz_set_ui (stride, 1);
2201 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2203 mpz_set (stride, ar->stride[dimen]->value.integer);
2207 mpz_sub (*result, upper, lower);
2208 mpz_add (*result, *result, stride);
2209 mpz_div (*result, *result, stride);
2211 /* Zero stride caught earlier. */
2212 if (mpz_cmp_ui (*result, 0) < 0)
2213 mpz_set_ui (*result, 0);
2223 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2231 ref_size (gfc_array_ref *ar, mpz_t *result)
2236 mpz_init_set_ui (*result, 1);
2238 for (d = 0; d < ar->dimen; d++)
2240 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2242 mpz_clear (*result);
2246 mpz_mul (*result, *result, size);
2254 /* Given an array expression and a dimension, figure out how many
2255 elements it has along that dimension. Returns SUCCESS if we were
2256 able to return a result in the 'result' variable, FAILURE
2260 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2265 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2266 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2268 switch (array->expr_type)
2272 for (ref = array->ref; ref; ref = ref->next)
2274 if (ref->type != REF_ARRAY)
2277 if (ref->u.ar.type == AR_FULL)
2278 return spec_dimen_size (ref->u.ar.as, dimen, result);
2280 if (ref->u.ar.type == AR_SECTION)
2282 for (i = 0; dimen >= 0; i++)
2283 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2286 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2290 if (array->shape && array->shape[dimen])
2292 mpz_init_set (*result, array->shape[dimen]);
2296 if (array->symtree->n.sym->attr.generic
2297 && array->value.function.esym != NULL)
2299 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2303 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2310 if (array->shape == NULL) {
2311 /* Expressions with rank > 1 should have "shape" properly set */
2312 if ( array->rank != 1 )
2313 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2314 return gfc_array_size(array, result);
2319 if (array->shape == NULL)
2322 mpz_init_set (*result, array->shape[dimen]);
2331 /* Given an array expression, figure out how many elements are in the
2332 array. Returns SUCCESS if this is possible, and sets the 'result'
2333 variable. Otherwise returns FAILURE. */
2336 gfc_array_size (gfc_expr *array, mpz_t *result)
2338 expand_info expand_save;
2343 switch (array->expr_type)
2346 gfc_push_suppress_errors ();
2348 expand_save = current_expand;
2350 current_expand.count = result;
2351 mpz_init_set_ui (*result, 0);
2353 current_expand.expand_work_function = count_elements;
2356 t = expand_constructor (array->value.constructor);
2358 gfc_pop_suppress_errors ();
2361 mpz_clear (*result);
2362 current_expand = expand_save;
2366 for (ref = array->ref; ref; ref = ref->next)
2368 if (ref->type != REF_ARRAY)
2371 if (ref->u.ar.type == AR_FULL)
2372 return spec_size (ref->u.ar.as, result);
2374 if (ref->u.ar.type == AR_SECTION)
2375 return ref_size (&ref->u.ar, result);
2378 return spec_size (array->symtree->n.sym->as, result);
2382 if (array->rank == 0 || array->shape == NULL)
2385 mpz_init_set_ui (*result, 1);
2387 for (i = 0; i < array->rank; i++)
2388 mpz_mul (*result, *result, array->shape[i]);
2397 /* Given an array reference, return the shape of the reference in an
2398 array of mpz_t integers. */
2401 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2411 for (; d < ar->as->rank; d++)
2412 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2418 for (i = 0; i < ar->dimen; i++)
2420 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2422 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2435 for (d--; d >= 0; d--)
2436 mpz_clear (shape[d]);
2442 /* Given an array expression, find the array reference structure that
2443 characterizes the reference. */
2446 gfc_find_array_ref (gfc_expr *e)
2450 for (ref = e->ref; ref; ref = ref->next)
2451 if (ref->type == REF_ARRAY
2452 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2456 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2462 /* Find out if an array shape is known at compile time. */
2465 gfc_is_compile_time_shape (gfc_array_spec *as)
2469 if (as->type != AS_EXPLICIT)
2472 for (i = 0; i < as->rank; i++)
2473 if (!gfc_is_constant_expr (as->lower[i])
2474 || !gfc_is_constant_expr (as->upper[i]))