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/>. */
26 #include "constructor.h"
28 /**************** Array reference matching subroutines *****************/
30 /* Copy an array reference structure. */
33 gfc_copy_array_ref (gfc_array_ref *src)
41 dest = gfc_get_array_ref ();
45 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
47 dest->start[i] = gfc_copy_expr (src->start[i]);
48 dest->end[i] = gfc_copy_expr (src->end[i]);
49 dest->stride[i] = gfc_copy_expr (src->stride[i]);
52 dest->offset = gfc_copy_expr (src->offset);
58 /* Match a single dimension of an array reference. This can be a
59 single element or an array section. Any modifications we've made
60 to the ar structure are cleaned up by the caller. If the init
61 is set, we require the subscript to be a valid initialization
65 match_subscript (gfc_array_ref *ar, int init, bool match_star)
67 match m = MATCH_ERROR;
71 i = ar->dimen + ar->codimen;
73 gfc_gobble_whitespace ();
74 ar->c_where[i] = gfc_current_locus;
75 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
77 /* We can't be sure of the difference between DIMEN_ELEMENT and
78 DIMEN_VECTOR until we know the type of the element itself at
81 ar->dimen_type[i] = DIMEN_UNKNOWN;
83 if (gfc_match_char (':') == MATCH_YES)
86 /* Get start element. */
87 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
91 m = gfc_match_init_expr (&ar->start[i]);
93 m = gfc_match_expr (&ar->start[i]);
95 if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES)
97 else if (m == MATCH_NO)
98 gfc_error ("Expected array subscript at %C");
102 if (gfc_match_char (':') == MATCH_NO)
107 gfc_error ("Unexpected '*' in coarray subscript at %C");
111 /* Get an optional end element. Because we've seen the colon, we
112 definitely have a range along this dimension. */
114 ar->dimen_type[i] = DIMEN_RANGE;
116 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
119 m = gfc_match_init_expr (&ar->end[i]);
121 m = gfc_match_expr (&ar->end[i]);
123 if (m == MATCH_ERROR)
126 /* See if we have an optional stride. */
127 if (gfc_match_char (':') == MATCH_YES)
131 gfc_error ("Strides not allowed in coarray subscript at %C");
135 m = init ? gfc_match_init_expr (&ar->stride[i])
136 : gfc_match_expr (&ar->stride[i]);
139 gfc_error ("Expected array subscript stride at %C");
146 ar->dimen_type[i] = DIMEN_STAR;
152 /* Match an array reference, whether it is the whole array or a
153 particular elements or a section. If init is set, the reference has
154 to consist of init expressions. */
157 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
161 bool matched_bracket = false;
163 memset (ar, '\0', sizeof (ar));
165 ar->where = gfc_current_locus;
167 ar->type = AR_UNKNOWN;
169 if (gfc_match_char ('[') == MATCH_YES)
171 matched_bracket = true;
175 if (gfc_match_char ('(') != MATCH_YES)
182 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
184 m = match_subscript (ar, init, false);
185 if (m == MATCH_ERROR)
188 if (gfc_match_char (')') == MATCH_YES)
194 if (gfc_match_char (',') != MATCH_YES)
196 gfc_error ("Invalid form of array reference at %C");
201 gfc_error ("Array reference at %C cannot have more than %d dimensions",
206 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
214 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
216 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
222 gfc_error ("Unexpected coarray designator at %C");
226 for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
228 m = match_subscript (ar, init, ar->codimen == (corank - 1));
229 if (m == MATCH_ERROR)
232 if (gfc_match_char (']') == MATCH_YES)
235 if (ar->codimen < corank)
237 gfc_error ("Too few codimensions at %C, expected %d not %d",
238 corank, ar->codimen);
241 if (ar->codimen > corank)
243 gfc_error ("Too many codimensions at %C, expected %d not %d",
244 corank, ar->codimen);
250 if (gfc_match_char (',') != MATCH_YES)
252 if (gfc_match_char ('*') == MATCH_YES)
253 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
254 ar->codimen + 1, corank);
256 gfc_error ("Invalid form of coarray reference at %C");
259 if (ar->codimen >= corank)
261 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
262 ar->codimen + 1, corank);
267 gfc_error ("Array reference at %C cannot have more than %d dimensions",
274 /************** Array specification matching subroutines ***************/
276 /* Free all of the expressions associated with array bounds
280 gfc_free_array_spec (gfc_array_spec *as)
287 for (i = 0; i < as->rank + as->corank; i++)
289 gfc_free_expr (as->lower[i]);
290 gfc_free_expr (as->upper[i]);
297 /* Take an array bound, resolves the expression, that make up the
298 shape and check associated constraints. */
301 resolve_array_bound (gfc_expr *e, int check_constant)
306 if (gfc_resolve_expr (e) == FAILURE
307 || gfc_specification_expr (e) == FAILURE)
310 if (check_constant && !gfc_is_constant_expr (e))
312 if (e->expr_type == EXPR_VARIABLE)
313 gfc_error ("Variable '%s' at %L in this context must be constant",
314 e->symtree->n.sym->name, &e->where);
316 gfc_error ("Expression at %L in this context must be constant",
325 /* Takes an array specification, resolves the expressions that make up
326 the shape and make sure everything is integral. */
329 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
337 for (i = 0; i < as->rank + as->corank; i++)
340 if (resolve_array_bound (e, check_constant) == FAILURE)
344 if (resolve_array_bound (e, check_constant) == FAILURE)
347 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
350 /* If the size is negative in this dimension, set it to zero. */
351 if (as->lower[i]->expr_type == EXPR_CONSTANT
352 && as->upper[i]->expr_type == EXPR_CONSTANT
353 && mpz_cmp (as->upper[i]->value.integer,
354 as->lower[i]->value.integer) < 0)
356 gfc_free_expr (as->upper[i]);
357 as->upper[i] = gfc_copy_expr (as->lower[i]);
358 mpz_sub_ui (as->upper[i]->value.integer,
359 as->upper[i]->value.integer, 1);
367 /* Match a single array element specification. The return values as
368 well as the upper and lower bounds of the array spec are filled
369 in according to what we see on the input. The caller makes sure
370 individual specifications make sense as a whole.
373 Parsed Lower Upper Returned
374 ------------------------------------
375 : NULL NULL AS_DEFERRED (*)
377 x: x NULL AS_ASSUMED_SHAPE
379 x:* x NULL AS_ASSUMED_SIZE
380 * 1 NULL AS_ASSUMED_SIZE
382 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
383 is fixed during the resolution of formal interfaces.
385 Anything else AS_UNKNOWN. */
388 match_array_element_spec (gfc_array_spec *as)
390 gfc_expr **upper, **lower;
393 lower = &as->lower[as->rank + as->corank - 1];
394 upper = &as->upper[as->rank + as->corank - 1];
396 if (gfc_match_char ('*') == MATCH_YES)
398 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
399 return AS_ASSUMED_SIZE;
402 if (gfc_match_char (':') == MATCH_YES)
405 m = gfc_match_expr (upper);
407 gfc_error ("Expected expression in array specification at %C");
410 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
413 if (gfc_match_char (':') == MATCH_NO)
415 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
422 if (gfc_match_char ('*') == MATCH_YES)
423 return AS_ASSUMED_SIZE;
425 m = gfc_match_expr (upper);
426 if (m == MATCH_ERROR)
429 return AS_ASSUMED_SHAPE;
430 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
437 /* Matches an array specification, incidentally figuring out what sort
438 it is. Match either a normal array specification, or a coarray spec
439 or both. Optionally allow [:] for coarrays. */
442 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
444 array_type current_type;
448 as = gfc_get_array_spec ();
453 if (gfc_match_char ('(') != MATCH_YES)
463 current_type = match_array_element_spec (as);
465 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
466 and implied-shape specifications. If the rank is at least 2, we can
467 distinguish between them. But for rank 1, we currently return
468 ASSUMED_SIZE; this gets adjusted later when we know for sure
469 whether the symbol parsed is a PARAMETER or not. */
473 if (current_type == AS_UNKNOWN)
475 as->type = current_type;
479 { /* See how current spec meshes with the existing. */
483 case AS_IMPLIED_SHAPE:
484 if (current_type != AS_ASSUMED_SHAPE)
486 gfc_error ("Bad array specification for implied-shape"
493 if (current_type == AS_ASSUMED_SIZE)
495 as->type = AS_ASSUMED_SIZE;
499 if (current_type == AS_EXPLICIT)
502 gfc_error ("Bad array specification for an explicitly shaped "
507 case AS_ASSUMED_SHAPE:
508 if ((current_type == AS_ASSUMED_SHAPE)
509 || (current_type == AS_DEFERRED))
512 gfc_error ("Bad array specification for assumed shape "
517 if (current_type == AS_DEFERRED)
520 if (current_type == AS_ASSUMED_SHAPE)
522 as->type = AS_ASSUMED_SHAPE;
526 gfc_error ("Bad specification for deferred shape array at %C");
529 case AS_ASSUMED_SIZE:
530 if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
532 as->type = AS_IMPLIED_SHAPE;
536 gfc_error ("Bad specification for assumed size array at %C");
540 if (gfc_match_char (')') == MATCH_YES)
543 if (gfc_match_char (',') != MATCH_YES)
545 gfc_error ("Expected another dimension in array declaration at %C");
549 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
551 gfc_error ("Array specification at %C has more than %d dimensions",
556 if (as->corank + as->rank >= 7
557 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
558 "specification at %C with more than 7 dimensions")
567 if (gfc_match_char ('[') != MATCH_YES)
570 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
574 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
576 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
580 if (as->rank >= GFC_MAX_DIMENSIONS)
582 gfc_error ("Array specification at %C has more than %d "
583 "dimensions", GFC_MAX_DIMENSIONS);
590 current_type = match_array_element_spec (as);
592 if (current_type == AS_UNKNOWN)
596 as->cotype = current_type;
599 { /* See how current spec meshes with the existing. */
600 case AS_IMPLIED_SHAPE:
605 if (current_type == AS_ASSUMED_SIZE)
607 as->cotype = AS_ASSUMED_SIZE;
611 if (current_type == AS_EXPLICIT)
614 gfc_error ("Bad array specification for an explicitly "
615 "shaped array at %C");
619 case AS_ASSUMED_SHAPE:
620 if ((current_type == AS_ASSUMED_SHAPE)
621 || (current_type == AS_DEFERRED))
624 gfc_error ("Bad array specification for assumed shape "
629 if (current_type == AS_DEFERRED)
632 if (current_type == AS_ASSUMED_SHAPE)
634 as->cotype = AS_ASSUMED_SHAPE;
638 gfc_error ("Bad specification for deferred shape array at %C");
641 case AS_ASSUMED_SIZE:
642 gfc_error ("Bad specification for assumed size array at %C");
646 if (gfc_match_char (']') == MATCH_YES)
649 if (gfc_match_char (',') != MATCH_YES)
651 gfc_error ("Expected another dimension in array declaration at %C");
655 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
657 gfc_error ("Array specification at %C has more than %d "
658 "dimensions", GFC_MAX_DIMENSIONS);
663 if (current_type == AS_EXPLICIT)
665 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
669 if (as->cotype == AS_ASSUMED_SIZE)
670 as->cotype = AS_EXPLICIT;
673 as->type = as->cotype;
676 if (as->rank == 0 && as->corank == 0)
679 gfc_free_array_spec (as);
683 /* If a lower bounds of an assumed shape array is blank, put in one. */
684 if (as->type == AS_ASSUMED_SHAPE)
686 for (i = 0; i < as->rank + as->corank; i++)
688 if (as->lower[i] == NULL)
689 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
698 /* Something went wrong. */
699 gfc_free_array_spec (as);
704 /* Given a symbol and an array specification, modify the symbol to
705 have that array specification. The error locus is needed in case
706 something goes wrong. On failure, the caller must free the spec. */
709 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
717 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
721 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
732 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
733 the codimension is simply added. */
734 gcc_assert (as->rank == 0 && sym->as->corank == 0);
736 sym->as->cotype = as->cotype;
737 sym->as->corank = as->corank;
738 for (i = 0; i < as->corank; i++)
740 sym->as->lower[sym->as->rank + i] = as->lower[i];
741 sym->as->upper[sym->as->rank + i] = as->upper[i];
746 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
747 the dimension is added - but first the codimensions (if existing
748 need to be shifted to make space for the dimension. */
749 gcc_assert (as->corank == 0 && sym->as->rank == 0);
751 sym->as->rank = as->rank;
752 sym->as->type = as->type;
753 sym->as->cray_pointee = as->cray_pointee;
754 sym->as->cp_was_assumed = as->cp_was_assumed;
756 for (i = 0; i < sym->as->corank; i++)
758 sym->as->lower[as->rank + i] = sym->as->lower[i];
759 sym->as->upper[as->rank + i] = sym->as->upper[i];
761 for (i = 0; i < as->rank; i++)
763 sym->as->lower[i] = as->lower[i];
764 sym->as->upper[i] = as->upper[i];
773 /* Copy an array specification. */
776 gfc_copy_array_spec (gfc_array_spec *src)
778 gfc_array_spec *dest;
784 dest = gfc_get_array_spec ();
788 for (i = 0; i < dest->rank + dest->corank; i++)
790 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
791 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
798 /* Returns nonzero if the two expressions are equal. Only handles integer
802 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
804 if (bound1 == NULL || bound2 == NULL
805 || bound1->expr_type != EXPR_CONSTANT
806 || bound2->expr_type != EXPR_CONSTANT
807 || bound1->ts.type != BT_INTEGER
808 || bound2->ts.type != BT_INTEGER)
809 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
811 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
818 /* Compares two array specifications. They must be constant or deferred
822 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
826 if (as1 == NULL && as2 == NULL)
829 if (as1 == NULL || as2 == NULL)
832 if (as1->rank != as2->rank)
835 if (as1->corank != as2->corank)
841 if (as1->type != as2->type)
844 if (as1->type == AS_EXPLICIT)
845 for (i = 0; i < as1->rank + as1->corank; i++)
847 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
850 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
858 /****************** Array constructor functions ******************/
861 /* Given an expression node that might be an array constructor and a
862 symbol, make sure that no iterators in this or child constructors
863 use the symbol as an implied-DO iterator. Returns nonzero if a
864 duplicate was found. */
867 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
872 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
876 if (e->expr_type == EXPR_ARRAY
877 && check_duplicate_iterator (e->value.constructor, master))
880 if (c->iterator == NULL)
883 if (c->iterator->var->symtree->n.sym == master)
885 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
886 "same name", master->name, &c->where);
896 /* Forward declaration because these functions are mutually recursive. */
897 static match match_array_cons_element (gfc_constructor_base *);
899 /* Match a list of array elements. */
902 match_array_list (gfc_constructor_base *result)
904 gfc_constructor_base head;
912 old_loc = gfc_current_locus;
914 if (gfc_match_char ('(') == MATCH_NO)
917 memset (&iter, '\0', sizeof (gfc_iterator));
920 m = match_array_cons_element (&head);
924 if (gfc_match_char (',') != MATCH_YES)
932 m = gfc_match_iterator (&iter, 0);
935 if (m == MATCH_ERROR)
938 m = match_array_cons_element (&head);
939 if (m == MATCH_ERROR)
946 goto cleanup; /* Could be a complex constant */
949 if (gfc_match_char (',') != MATCH_YES)
958 if (gfc_match_char (')') != MATCH_YES)
961 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
967 e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
968 e->value.constructor = head;
970 p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
971 p->iterator = gfc_get_iterator ();
977 gfc_error ("Syntax error in array constructor at %C");
981 gfc_constructor_free (head);
982 gfc_free_iterator (&iter, 0);
983 gfc_current_locus = old_loc;
988 /* Match a single element of an array constructor, which can be a
989 single expression or a list of elements. */
992 match_array_cons_element (gfc_constructor_base *result)
997 m = match_array_list (result);
1001 m = gfc_match_expr (&expr);
1005 gfc_constructor_append_expr (result, expr, &gfc_current_locus);
1010 /* Match an array constructor. */
1013 gfc_match_array_constructor (gfc_expr **result)
1015 gfc_constructor_base head, new_cons;
1020 const char *end_delim;
1023 if (gfc_match (" (/") == MATCH_NO)
1025 if (gfc_match (" [") == MATCH_NO)
1029 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1030 "style array constructors at %C") == FAILURE)
1038 where = gfc_current_locus;
1039 head = new_cons = NULL;
1042 /* Try to match an optional "type-spec ::" */
1043 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1045 seen_ts = (gfc_match (" ::") == MATCH_YES);
1049 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1050 "including type specification at %C") == FAILURE)
1055 gfc_error ("Type-spec at %L cannot contain a deferred "
1056 "type parameter", &where);
1063 gfc_current_locus = where;
1065 if (gfc_match (end_delim) == MATCH_YES)
1071 gfc_error ("Empty array constructor at %C is not allowed");
1078 m = match_array_cons_element (&head);
1079 if (m == MATCH_ERROR)
1084 if (gfc_match_char (',') == MATCH_NO)
1088 if (gfc_match (end_delim) == MATCH_NO)
1092 /* Size must be calculated at resolution time. */
1095 expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1099 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1101 expr->value.constructor = head;
1103 expr->ts.u.cl->length_from_typespec = seen_ts;
1109 gfc_error ("Syntax error in array constructor at %C");
1112 gfc_constructor_free (head);
1118 /************** Check array constructors for correctness **************/
1120 /* Given an expression, compare it's type with the type of the current
1121 constructor. Returns nonzero if an error was issued. The
1122 cons_state variable keeps track of whether the type of the
1123 constructor being read or resolved is known to be good, bad or just
1126 static gfc_typespec constructor_ts;
1128 { CONS_START, CONS_GOOD, CONS_BAD }
1132 check_element_type (gfc_expr *expr, bool convert)
1134 if (cons_state == CONS_BAD)
1135 return 0; /* Suppress further errors */
1137 if (cons_state == CONS_START)
1139 if (expr->ts.type == BT_UNKNOWN)
1140 cons_state = CONS_BAD;
1143 cons_state = CONS_GOOD;
1144 constructor_ts = expr->ts;
1150 if (gfc_compare_types (&constructor_ts, &expr->ts))
1154 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1156 gfc_error ("Element in %s array constructor at %L is %s",
1157 gfc_typename (&constructor_ts), &expr->where,
1158 gfc_typename (&expr->ts));
1160 cons_state = CONS_BAD;
1165 /* Recursive work function for gfc_check_constructor_type(). */
1168 check_constructor_type (gfc_constructor_base base, bool convert)
1173 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1177 if (e->expr_type == EXPR_ARRAY)
1179 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1185 if (check_element_type (e, convert))
1193 /* Check that all elements of an array constructor are the same type.
1194 On FAILURE, an error has been generated. */
1197 gfc_check_constructor_type (gfc_expr *e)
1201 if (e->ts.type != BT_UNKNOWN)
1203 cons_state = CONS_GOOD;
1204 constructor_ts = e->ts;
1208 cons_state = CONS_START;
1209 gfc_clear_ts (&constructor_ts);
1212 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1213 typespec, and we will now convert the values on the fly. */
1214 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1215 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1216 e->ts = constructor_ts;
1223 typedef struct cons_stack
1225 gfc_iterator *iterator;
1226 struct cons_stack *previous;
1230 static cons_stack *base;
1232 static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1234 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1235 that that variable is an iteration variables. */
1238 gfc_check_iter_variable (gfc_expr *expr)
1243 sym = expr->symtree->n.sym;
1245 for (c = base; c && c->iterator; c = c->previous)
1246 if (sym == c->iterator->var->symtree->n.sym)
1253 /* Recursive work function for gfc_check_constructor(). This amounts
1254 to calling the check function for each expression in the
1255 constructor, giving variables with the names of iterators a pass. */
1258 check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1265 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1269 if (e->expr_type != EXPR_ARRAY)
1271 if ((*check_function) (e) == FAILURE)
1276 element.previous = base;
1277 element.iterator = c->iterator;
1280 t = check_constructor (e->value.constructor, check_function);
1281 base = element.previous;
1287 /* Nothing went wrong, so all OK. */
1292 /* Checks a constructor to see if it is a particular kind of
1293 expression -- specification, restricted, or initialization as
1294 determined by the check_function. */
1297 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1299 cons_stack *base_save;
1305 t = check_constructor (expr->value.constructor, check_function);
1313 /**************** Simplification of array constructors ****************/
1315 iterator_stack *iter_stack;
1319 gfc_constructor_base base;
1320 int extract_count, extract_n;
1321 gfc_expr *extracted;
1325 gfc_component *component;
1328 gfc_try (*expand_work_function) (gfc_expr *);
1332 static expand_info current_expand;
1334 static gfc_try expand_constructor (gfc_constructor_base);
1337 /* Work function that counts the number of elements present in a
1341 count_elements (gfc_expr *e)
1346 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1349 if (gfc_array_size (e, &result) == FAILURE)
1355 mpz_add (*current_expand.count, *current_expand.count, result);
1364 /* Work function that extracts a particular element from an array
1365 constructor, freeing the rest. */
1368 extract_element (gfc_expr *e)
1371 { /* Something unextractable */
1376 if (current_expand.extract_count == current_expand.extract_n)
1377 current_expand.extracted = e;
1381 current_expand.extract_count++;
1387 /* Work function that constructs a new constructor out of the old one,
1388 stringing new elements together. */
1391 expand (gfc_expr *e)
1393 gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
1396 c->n.component = current_expand.component;
1401 /* Given an initialization expression that is a variable reference,
1402 substitute the current value of the iteration variable. */
1405 gfc_simplify_iterator_var (gfc_expr *e)
1409 for (p = iter_stack; p; p = p->prev)
1410 if (e->symtree == p->variable)
1414 return; /* Variable not found */
1416 gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1418 mpz_set (e->value.integer, p->value);
1424 /* Expand an expression with that is inside of a constructor,
1425 recursing into other constructors if present. */
1428 expand_expr (gfc_expr *e)
1430 if (e->expr_type == EXPR_ARRAY)
1431 return expand_constructor (e->value.constructor);
1433 e = gfc_copy_expr (e);
1435 if (gfc_simplify_expr (e, 1) == FAILURE)
1441 return current_expand.expand_work_function (e);
1446 expand_iterator (gfc_constructor *c)
1448 gfc_expr *start, *end, *step;
1449 iterator_stack frame;
1458 mpz_init (frame.value);
1461 start = gfc_copy_expr (c->iterator->start);
1462 if (gfc_simplify_expr (start, 1) == FAILURE)
1465 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1468 end = gfc_copy_expr (c->iterator->end);
1469 if (gfc_simplify_expr (end, 1) == FAILURE)
1472 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1475 step = gfc_copy_expr (c->iterator->step);
1476 if (gfc_simplify_expr (step, 1) == FAILURE)
1479 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1482 if (mpz_sgn (step->value.integer) == 0)
1484 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1488 /* Calculate the trip count of the loop. */
1489 mpz_sub (trip, end->value.integer, start->value.integer);
1490 mpz_add (trip, trip, step->value.integer);
1491 mpz_tdiv_q (trip, trip, step->value.integer);
1493 mpz_set (frame.value, start->value.integer);
1495 frame.prev = iter_stack;
1496 frame.variable = c->iterator->var->symtree;
1497 iter_stack = &frame;
1499 while (mpz_sgn (trip) > 0)
1501 if (expand_expr (c->expr) == FAILURE)
1504 mpz_add (frame.value, frame.value, step->value.integer);
1505 mpz_sub_ui (trip, trip, 1);
1511 gfc_free_expr (start);
1512 gfc_free_expr (end);
1513 gfc_free_expr (step);
1516 mpz_clear (frame.value);
1518 iter_stack = frame.prev;
1524 /* Expand a constructor into constant constructors without any
1525 iterators, calling the work function for each of the expanded
1526 expressions. The work function needs to either save or free the
1527 passed expression. */
1530 expand_constructor (gfc_constructor_base base)
1535 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1537 if (c->iterator != NULL)
1539 if (expand_iterator (c) == FAILURE)
1546 if (e->expr_type == EXPR_ARRAY)
1548 if (expand_constructor (e->value.constructor) == FAILURE)
1554 e = gfc_copy_expr (e);
1555 if (gfc_simplify_expr (e, 1) == FAILURE)
1560 current_expand.offset = &c->offset;
1561 current_expand.repeat = &c->repeat;
1562 current_expand.component = c->n.component;
1563 if (current_expand.expand_work_function (e) == FAILURE)
1570 /* Given an array expression and an element number (starting at zero),
1571 return a pointer to the array element. NULL is returned if the
1572 size of the array has been exceeded. The expression node returned
1573 remains a part of the array and should not be freed. Access is not
1574 efficient at all, but this is another place where things do not
1575 have to be particularly fast. */
1578 gfc_get_array_element (gfc_expr *array, int element)
1580 expand_info expand_save;
1584 expand_save = current_expand;
1585 current_expand.extract_n = element;
1586 current_expand.expand_work_function = extract_element;
1587 current_expand.extracted = NULL;
1588 current_expand.extract_count = 0;
1592 rc = expand_constructor (array->value.constructor);
1593 e = current_expand.extracted;
1594 current_expand = expand_save;
1603 /* Top level subroutine for expanding constructors. We only expand
1604 constructor if they are small enough. */
1607 gfc_expand_constructor (gfc_expr *e, bool fatal)
1609 expand_info expand_save;
1613 /* If we can successfully get an array element at the max array size then
1614 the array is too big to expand, so we just return. */
1615 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1621 gfc_error ("The number of elements in the array constructor "
1622 "at %L requires an increase of the allowed %d "
1623 "upper limit. See -fmax-array-constructor "
1624 "option", &e->where,
1625 gfc_option.flag_max_array_constructor);
1631 /* We now know the array is not too big so go ahead and try to expand it. */
1632 expand_save = current_expand;
1633 current_expand.base = NULL;
1637 current_expand.expand_work_function = expand;
1639 if (expand_constructor (e->value.constructor) == FAILURE)
1641 gfc_constructor_free (current_expand.base);
1646 gfc_constructor_free (e->value.constructor);
1647 e->value.constructor = current_expand.base;
1652 current_expand = expand_save;
1658 /* Work function for checking that an element of a constructor is a
1659 constant, after removal of any iteration variables. We return
1660 FAILURE if not so. */
1663 is_constant_element (gfc_expr *e)
1667 rv = gfc_is_constant_expr (e);
1670 return rv ? SUCCESS : FAILURE;
1674 /* Given an array constructor, determine if the constructor is
1675 constant or not by expanding it and making sure that all elements
1676 are constants. This is a bit of a hack since something like (/ (i,
1677 i=1,100000000) /) will take a while as* opposed to a more clever
1678 function that traverses the expression tree. FIXME. */
1681 gfc_constant_ac (gfc_expr *e)
1683 expand_info expand_save;
1687 expand_save = current_expand;
1688 current_expand.expand_work_function = is_constant_element;
1690 rc = expand_constructor (e->value.constructor);
1692 current_expand = expand_save;
1700 /* Returns nonzero if an array constructor has been completely
1701 expanded (no iterators) and zero if iterators are present. */
1704 gfc_expanded_ac (gfc_expr *e)
1708 if (e->expr_type == EXPR_ARRAY)
1709 for (c = gfc_constructor_first (e->value.constructor);
1710 c; c = gfc_constructor_next (c))
1711 if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1718 /*************** Type resolution of array constructors ***************/
1720 /* Recursive array list resolution function. All of the elements must
1721 be of the same type. */
1724 resolve_array_list (gfc_constructor_base base)
1731 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1733 if (c->iterator != NULL
1734 && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1737 if (gfc_resolve_expr (c->expr) == FAILURE)
1744 /* Resolve character array constructor. If it has a specified constant character
1745 length, pad/truncate the elements here; if the length is not specified and
1746 all elements are of compile-time known length, emit an error as this is
1750 gfc_resolve_character_array_constructor (gfc_expr *expr)
1755 gcc_assert (expr->expr_type == EXPR_ARRAY);
1756 gcc_assert (expr->ts.type == BT_CHARACTER);
1758 if (expr->ts.u.cl == NULL)
1760 for (p = gfc_constructor_first (expr->value.constructor);
1761 p; p = gfc_constructor_next (p))
1762 if (p->expr->ts.u.cl != NULL)
1764 /* Ensure that if there is a char_len around that it is
1765 used; otherwise the middle-end confuses them! */
1766 expr->ts.u.cl = p->expr->ts.u.cl;
1770 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1777 if (expr->ts.u.cl->length == NULL)
1779 /* Check that all constant string elements have the same length until
1780 we reach the end or find a variable-length one. */
1782 for (p = gfc_constructor_first (expr->value.constructor);
1783 p; p = gfc_constructor_next (p))
1785 int current_length = -1;
1787 for (ref = p->expr->ref; ref; ref = ref->next)
1788 if (ref->type == REF_SUBSTRING
1789 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1790 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1793 if (p->expr->expr_type == EXPR_CONSTANT)
1794 current_length = p->expr->value.character.length;
1798 j = mpz_get_ui (ref->u.ss.end->value.integer)
1799 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1800 current_length = (int) j;
1802 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1803 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1806 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1807 current_length = (int) j;
1812 gcc_assert (current_length != -1);
1814 if (found_length == -1)
1815 found_length = current_length;
1816 else if (found_length != current_length)
1818 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1819 " constructor at %L", found_length, current_length,
1824 gcc_assert (found_length == current_length);
1827 gcc_assert (found_length != -1);
1829 /* Update the character length of the array constructor. */
1830 expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1831 NULL, found_length);
1835 /* We've got a character length specified. It should be an integer,
1836 otherwise an error is signalled elsewhere. */
1837 gcc_assert (expr->ts.u.cl->length);
1839 /* If we've got a constant character length, pad according to this.
1840 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1841 max_length only if they pass. */
1842 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1844 /* Now pad/truncate the elements accordingly to the specified character
1845 length. This is ok inside this conditional, as in the case above
1846 (without typespec) all elements are verified to have the same length
1848 if (found_length != -1)
1849 for (p = gfc_constructor_first (expr->value.constructor);
1850 p; p = gfc_constructor_next (p))
1851 if (p->expr->expr_type == EXPR_CONSTANT)
1853 gfc_expr *cl = NULL;
1854 int current_length = -1;
1857 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1859 cl = p->expr->ts.u.cl->length;
1860 gfc_extract_int (cl, ¤t_length);
1863 /* If gfc_extract_int above set current_length, we implicitly
1864 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1866 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1869 || (current_length != -1 && current_length != found_length))
1870 gfc_set_constant_character_len (found_length, p->expr,
1871 has_ts ? -1 : found_length);
1879 /* Resolve all of the expressions in an array list. */
1882 gfc_resolve_array_constructor (gfc_expr *expr)
1886 t = resolve_array_list (expr->value.constructor);
1888 t = gfc_check_constructor_type (expr);
1890 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1891 the call to this function, so we don't need to call it here; if it was
1892 called twice, an error message there would be duplicated. */
1898 /* Copy an iterator structure. */
1901 gfc_copy_iterator (gfc_iterator *src)
1908 dest = gfc_get_iterator ();
1910 dest->var = gfc_copy_expr (src->var);
1911 dest->start = gfc_copy_expr (src->start);
1912 dest->end = gfc_copy_expr (src->end);
1913 dest->step = gfc_copy_expr (src->step);
1919 /********* Subroutines for determining the size of an array *********/
1921 /* These are needed just to accommodate RESHAPE(). There are no
1922 diagnostics here, we just return a negative number if something
1926 /* Get the size of single dimension of an array specification. The
1927 array is guaranteed to be one dimensional. */
1930 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1935 if (dimen < 0 || dimen > as->rank - 1)
1936 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1938 if (as->type != AS_EXPLICIT
1939 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1940 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1941 || as->lower[dimen]->ts.type != BT_INTEGER
1942 || as->upper[dimen]->ts.type != BT_INTEGER)
1947 mpz_sub (*result, as->upper[dimen]->value.integer,
1948 as->lower[dimen]->value.integer);
1950 mpz_add_ui (*result, *result, 1);
1957 spec_size (gfc_array_spec *as, mpz_t *result)
1962 mpz_init_set_ui (*result, 1);
1964 for (d = 0; d < as->rank; d++)
1966 if (spec_dimen_size (as, d, &size) == FAILURE)
1968 mpz_clear (*result);
1972 mpz_mul (*result, *result, size);
1980 /* Get the number of elements in an array section. Optionally, also supply
1984 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
1986 mpz_t upper, lower, stride;
1989 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1990 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1992 switch (ar->dimen_type[dimen])
1996 mpz_set_ui (*result, 1);
2001 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2010 if (ar->start[dimen] == NULL)
2012 if (ar->as->lower[dimen] == NULL
2013 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
2015 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2019 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2021 mpz_set (lower, ar->start[dimen]->value.integer);
2024 if (ar->end[dimen] == NULL)
2026 if (ar->as->upper[dimen] == NULL
2027 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2029 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2033 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2035 mpz_set (upper, ar->end[dimen]->value.integer);
2038 if (ar->stride[dimen] == NULL)
2039 mpz_set_ui (stride, 1);
2042 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2044 mpz_set (stride, ar->stride[dimen]->value.integer);
2048 mpz_sub (*result, upper, lower);
2049 mpz_add (*result, *result, stride);
2050 mpz_div (*result, *result, stride);
2052 /* Zero stride caught earlier. */
2053 if (mpz_cmp_ui (*result, 0) < 0)
2054 mpz_set_ui (*result, 0);
2061 mpz_sub_ui (*end, *result, 1UL);
2062 mpz_mul (*end, *end, stride);
2063 mpz_add (*end, *end, lower);
2073 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2081 ref_size (gfc_array_ref *ar, mpz_t *result)
2086 mpz_init_set_ui (*result, 1);
2088 for (d = 0; d < ar->dimen; d++)
2090 if (gfc_ref_dimen_size (ar, d, &size, NULL) == FAILURE)
2092 mpz_clear (*result);
2096 mpz_mul (*result, *result, size);
2104 /* Given an array expression and a dimension, figure out how many
2105 elements it has along that dimension. Returns SUCCESS if we were
2106 able to return a result in the 'result' variable, FAILURE
2110 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2115 if (array->ts.type == BT_CLASS)
2118 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2119 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2121 switch (array->expr_type)
2125 for (ref = array->ref; ref; ref = ref->next)
2127 if (ref->type != REF_ARRAY)
2130 if (ref->u.ar.type == AR_FULL)
2131 return spec_dimen_size (ref->u.ar.as, dimen, result);
2133 if (ref->u.ar.type == AR_SECTION)
2135 for (i = 0; dimen >= 0; i++)
2136 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2139 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2143 if (array->shape && array->shape[dimen])
2145 mpz_init_set (*result, array->shape[dimen]);
2149 if (array->symtree->n.sym->attr.generic
2150 && array->value.function.esym != NULL)
2152 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2156 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2163 if (array->shape == NULL) {
2164 /* Expressions with rank > 1 should have "shape" properly set */
2165 if ( array->rank != 1 )
2166 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2167 return gfc_array_size(array, result);
2172 if (array->shape == NULL)
2175 mpz_init_set (*result, array->shape[dimen]);
2184 /* Given an array expression, figure out how many elements are in the
2185 array. Returns SUCCESS if this is possible, and sets the 'result'
2186 variable. Otherwise returns FAILURE. */
2189 gfc_array_size (gfc_expr *array, mpz_t *result)
2191 expand_info expand_save;
2196 if (array->ts.type == BT_CLASS)
2199 switch (array->expr_type)
2202 gfc_push_suppress_errors ();
2204 expand_save = current_expand;
2206 current_expand.count = result;
2207 mpz_init_set_ui (*result, 0);
2209 current_expand.expand_work_function = count_elements;
2212 t = expand_constructor (array->value.constructor);
2214 gfc_pop_suppress_errors ();
2217 mpz_clear (*result);
2218 current_expand = expand_save;
2222 for (ref = array->ref; ref; ref = ref->next)
2224 if (ref->type != REF_ARRAY)
2227 if (ref->u.ar.type == AR_FULL)
2228 return spec_size (ref->u.ar.as, result);
2230 if (ref->u.ar.type == AR_SECTION)
2231 return ref_size (&ref->u.ar, result);
2234 return spec_size (array->symtree->n.sym->as, result);
2238 if (array->rank == 0 || array->shape == NULL)
2241 mpz_init_set_ui (*result, 1);
2243 for (i = 0; i < array->rank; i++)
2244 mpz_mul (*result, *result, array->shape[i]);
2253 /* Given an array reference, return the shape of the reference in an
2254 array of mpz_t integers. */
2257 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2267 for (; d < ar->as->rank; d++)
2268 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2274 for (i = 0; i < ar->dimen; i++)
2276 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2278 if (gfc_ref_dimen_size (ar, i, &shape[d], NULL) == FAILURE)
2291 gfc_clear_shape (shape, d);
2296 /* Given an array expression, find the array reference structure that
2297 characterizes the reference. */
2300 gfc_find_array_ref (gfc_expr *e)
2304 for (ref = e->ref; ref; ref = ref->next)
2305 if (ref->type == REF_ARRAY
2306 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2310 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2316 /* Find out if an array shape is known at compile time. */
2319 gfc_is_compile_time_shape (gfc_array_spec *as)
2323 if (as->type != AS_EXPLICIT)
2326 for (i = 0; i < as->rank; i++)
2327 if (!gfc_is_constant_expr (as->lower[i])
2328 || !gfc_is_constant_expr (as->upper[i]))