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 ar->c_where[i] = gfc_current_locus;
74 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
76 /* We can't be sure of the difference between DIMEN_ELEMENT and
77 DIMEN_VECTOR until we know the type of the element itself at
80 ar->dimen_type[i] = DIMEN_UNKNOWN;
82 if (gfc_match_char (':') == MATCH_YES)
85 /* Get start element. */
86 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
90 m = gfc_match_init_expr (&ar->start[i]);
92 m = gfc_match_expr (&ar->start[i]);
94 if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES)
96 else if (m == MATCH_NO)
97 gfc_error ("Expected array subscript at %C");
101 if (gfc_match_char (':') == MATCH_NO)
106 gfc_error ("Unexpected '*' in coarray subscript at %C");
110 /* Get an optional end element. Because we've seen the colon, we
111 definitely have a range along this dimension. */
113 ar->dimen_type[i] = DIMEN_RANGE;
115 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
118 m = gfc_match_init_expr (&ar->end[i]);
120 m = gfc_match_expr (&ar->end[i]);
122 if (m == MATCH_ERROR)
125 /* See if we have an optional stride. */
126 if (gfc_match_char (':') == MATCH_YES)
130 gfc_error ("Strides not allowed in coarray subscript at %C");
134 m = init ? gfc_match_init_expr (&ar->stride[i])
135 : gfc_match_expr (&ar->stride[i]);
138 gfc_error ("Expected array subscript stride at %C");
145 ar->dimen_type[i] = DIMEN_STAR;
151 /* Match an array reference, whether it is the whole array or a
152 particular elements or a section. If init is set, the reference has
153 to consist of init expressions. */
156 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
160 bool matched_bracket = false;
162 memset (ar, '\0', sizeof (ar));
164 ar->where = gfc_current_locus;
166 ar->type = AR_UNKNOWN;
168 if (gfc_match_char ('[') == MATCH_YES)
170 matched_bracket = true;
174 if (gfc_match_char ('(') != MATCH_YES)
181 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
183 m = match_subscript (ar, init, false);
184 if (m == MATCH_ERROR)
187 if (gfc_match_char (')') == MATCH_YES)
193 if (gfc_match_char (',') != MATCH_YES)
195 gfc_error ("Invalid form of array reference at %C");
200 gfc_error ("Array reference at %C cannot have more than %d dimensions",
205 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
213 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
215 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
221 gfc_error ("Unexpected coarray designator at %C");
225 for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
227 m = match_subscript (ar, init, ar->codimen == (corank - 1));
228 if (m == MATCH_ERROR)
231 if (gfc_match_char (']') == MATCH_YES)
234 if (ar->codimen < corank)
236 gfc_error ("Too few codimensions at %C, expected %d not %d",
237 corank, ar->codimen);
243 if (gfc_match_char (',') != MATCH_YES)
245 if (gfc_match_char ('*') == MATCH_YES)
246 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
247 ar->codimen + 1, corank);
249 gfc_error ("Invalid form of coarray reference at %C");
252 if (ar->codimen >= corank)
254 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
255 ar->codimen + 1, corank);
260 gfc_error ("Array reference at %C cannot have more than %d dimensions",
267 /************** Array specification matching subroutines ***************/
269 /* Free all of the expressions associated with array bounds
273 gfc_free_array_spec (gfc_array_spec *as)
280 for (i = 0; i < as->rank + as->corank; i++)
282 gfc_free_expr (as->lower[i]);
283 gfc_free_expr (as->upper[i]);
290 /* Take an array bound, resolves the expression, that make up the
291 shape and check associated constraints. */
294 resolve_array_bound (gfc_expr *e, int check_constant)
299 if (gfc_resolve_expr (e) == FAILURE
300 || gfc_specification_expr (e) == FAILURE)
303 if (check_constant && !gfc_is_constant_expr (e))
305 if (e->expr_type == EXPR_VARIABLE)
306 gfc_error ("Variable '%s' at %L in this context must be constant",
307 e->symtree->n.sym->name, &e->where);
309 gfc_error ("Expression at %L in this context must be constant",
318 /* Takes an array specification, resolves the expressions that make up
319 the shape and make sure everything is integral. */
322 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
330 for (i = 0; i < as->rank + as->corank; i++)
333 if (resolve_array_bound (e, check_constant) == FAILURE)
337 if (resolve_array_bound (e, check_constant) == FAILURE)
340 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
343 /* If the size is negative in this dimension, set it to zero. */
344 if (as->lower[i]->expr_type == EXPR_CONSTANT
345 && as->upper[i]->expr_type == EXPR_CONSTANT
346 && mpz_cmp (as->upper[i]->value.integer,
347 as->lower[i]->value.integer) < 0)
349 gfc_free_expr (as->upper[i]);
350 as->upper[i] = gfc_copy_expr (as->lower[i]);
351 mpz_sub_ui (as->upper[i]->value.integer,
352 as->upper[i]->value.integer, 1);
360 /* Match a single array element specification. The return values as
361 well as the upper and lower bounds of the array spec are filled
362 in according to what we see on the input. The caller makes sure
363 individual specifications make sense as a whole.
366 Parsed Lower Upper Returned
367 ------------------------------------
368 : NULL NULL AS_DEFERRED (*)
370 x: x NULL AS_ASSUMED_SHAPE
372 x:* x NULL AS_ASSUMED_SIZE
373 * 1 NULL AS_ASSUMED_SIZE
375 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
376 is fixed during the resolution of formal interfaces.
378 Anything else AS_UNKNOWN. */
381 match_array_element_spec (gfc_array_spec *as)
383 gfc_expr **upper, **lower;
386 lower = &as->lower[as->rank + as->corank - 1];
387 upper = &as->upper[as->rank + as->corank - 1];
389 if (gfc_match_char ('*') == MATCH_YES)
391 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
392 return AS_ASSUMED_SIZE;
395 if (gfc_match_char (':') == MATCH_YES)
398 m = gfc_match_expr (upper);
400 gfc_error ("Expected expression in array specification at %C");
403 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
406 if (gfc_match_char (':') == MATCH_NO)
408 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
415 if (gfc_match_char ('*') == MATCH_YES)
416 return AS_ASSUMED_SIZE;
418 m = gfc_match_expr (upper);
419 if (m == MATCH_ERROR)
422 return AS_ASSUMED_SHAPE;
423 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
430 /* Matches an array specification, incidentally figuring out what sort
431 it is. Match either a normal array specification, or a coarray spec
432 or both. Optionally allow [:] for coarrays. */
435 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
437 array_type current_type;
441 as = gfc_get_array_spec ();
445 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
454 if (gfc_match_char ('(') != MATCH_YES)
464 current_type = match_array_element_spec (as);
468 if (current_type == AS_UNKNOWN)
470 as->type = current_type;
474 { /* See how current spec meshes with the existing. */
479 if (current_type == AS_ASSUMED_SIZE)
481 as->type = AS_ASSUMED_SIZE;
485 if (current_type == AS_EXPLICIT)
488 gfc_error ("Bad array specification for an explicitly shaped "
493 case AS_ASSUMED_SHAPE:
494 if ((current_type == AS_ASSUMED_SHAPE)
495 || (current_type == AS_DEFERRED))
498 gfc_error ("Bad array specification for assumed shape "
503 if (current_type == AS_DEFERRED)
506 if (current_type == AS_ASSUMED_SHAPE)
508 as->type = AS_ASSUMED_SHAPE;
512 gfc_error ("Bad specification for deferred shape array at %C");
515 case AS_ASSUMED_SIZE:
516 gfc_error ("Bad specification for assumed size array at %C");
520 if (gfc_match_char (')') == MATCH_YES)
523 if (gfc_match_char (',') != MATCH_YES)
525 gfc_error ("Expected another dimension in array declaration at %C");
529 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
531 gfc_error ("Array specification at %C has more than %d dimensions",
536 if (as->corank + as->rank >= 7
537 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
538 "specification at %C with more than 7 dimensions")
547 if (gfc_match_char ('[') != MATCH_YES)
550 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
554 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
556 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
563 current_type = match_array_element_spec (as);
565 if (current_type == AS_UNKNOWN)
569 as->cotype = current_type;
572 { /* See how current spec meshes with the existing. */
577 if (current_type == AS_ASSUMED_SIZE)
579 as->cotype = AS_ASSUMED_SIZE;
583 if (current_type == AS_EXPLICIT)
586 gfc_error ("Bad array specification for an explicitly "
587 "shaped array at %C");
591 case AS_ASSUMED_SHAPE:
592 if ((current_type == AS_ASSUMED_SHAPE)
593 || (current_type == AS_DEFERRED))
596 gfc_error ("Bad array specification for assumed shape "
601 if (current_type == AS_DEFERRED)
604 if (current_type == AS_ASSUMED_SHAPE)
606 as->cotype = AS_ASSUMED_SHAPE;
610 gfc_error ("Bad specification for deferred shape array at %C");
613 case AS_ASSUMED_SIZE:
614 gfc_error ("Bad specification for assumed size array at %C");
618 if (gfc_match_char (']') == MATCH_YES)
621 if (gfc_match_char (',') != MATCH_YES)
623 gfc_error ("Expected another dimension in array declaration at %C");
627 if (as->corank >= GFC_MAX_DIMENSIONS)
629 gfc_error ("Array specification at %C has more than %d "
630 "dimensions", GFC_MAX_DIMENSIONS);
635 if (current_type == AS_EXPLICIT)
637 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
641 if (as->cotype == AS_ASSUMED_SIZE)
642 as->cotype = AS_EXPLICIT;
645 as->type = as->cotype;
648 if (as->rank == 0 && as->corank == 0)
651 gfc_free_array_spec (as);
655 /* If a lower bounds of an assumed shape array is blank, put in one. */
656 if (as->type == AS_ASSUMED_SHAPE)
658 for (i = 0; i < as->rank + as->corank; i++)
660 if (as->lower[i] == NULL)
661 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
670 /* Something went wrong. */
671 gfc_free_array_spec (as);
676 /* Given a symbol and an array specification, modify the symbol to
677 have that array specification. The error locus is needed in case
678 something goes wrong. On failure, the caller must free the spec. */
681 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
689 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
693 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
704 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
705 the codimension is simply added. */
706 gcc_assert (as->rank == 0 && sym->as->corank == 0);
708 sym->as->cotype = as->cotype;
709 sym->as->corank = as->corank;
710 for (i = 0; i < as->corank; i++)
712 sym->as->lower[sym->as->rank + i] = as->lower[i];
713 sym->as->upper[sym->as->rank + i] = as->upper[i];
718 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
719 the dimension is added - but first the codimensions (if existing
720 need to be shifted to make space for the dimension. */
721 gcc_assert (as->corank == 0 && sym->as->rank == 0);
723 sym->as->rank = as->rank;
724 sym->as->type = as->type;
725 sym->as->cray_pointee = as->cray_pointee;
726 sym->as->cp_was_assumed = as->cp_was_assumed;
728 for (i = 0; i < sym->as->corank; i++)
730 sym->as->lower[as->rank + i] = sym->as->lower[i];
731 sym->as->upper[as->rank + i] = sym->as->upper[i];
733 for (i = 0; i < as->rank; i++)
735 sym->as->lower[i] = as->lower[i];
736 sym->as->upper[i] = as->upper[i];
745 /* Copy an array specification. */
748 gfc_copy_array_spec (gfc_array_spec *src)
750 gfc_array_spec *dest;
756 dest = gfc_get_array_spec ();
760 for (i = 0; i < dest->rank + dest->corank; i++)
762 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
763 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
770 /* Returns nonzero if the two expressions are equal. Only handles integer
774 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
776 if (bound1 == NULL || bound2 == NULL
777 || bound1->expr_type != EXPR_CONSTANT
778 || bound2->expr_type != EXPR_CONSTANT
779 || bound1->ts.type != BT_INTEGER
780 || bound2->ts.type != BT_INTEGER)
781 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
783 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
790 /* Compares two array specifications. They must be constant or deferred
794 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
798 if (as1 == NULL && as2 == NULL)
801 if (as1 == NULL || as2 == NULL)
804 if (as1->rank != as2->rank)
807 if (as1->corank != as2->corank)
813 if (as1->type != as2->type)
816 if (as1->type == AS_EXPLICIT)
817 for (i = 0; i < as1->rank + as1->corank; i++)
819 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
822 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
830 /****************** Array constructor functions ******************/
833 /* Given an expression node that might be an array constructor and a
834 symbol, make sure that no iterators in this or child constructors
835 use the symbol as an implied-DO iterator. Returns nonzero if a
836 duplicate was found. */
839 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
844 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
848 if (e->expr_type == EXPR_ARRAY
849 && check_duplicate_iterator (e->value.constructor, master))
852 if (c->iterator == NULL)
855 if (c->iterator->var->symtree->n.sym == master)
857 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
858 "same name", master->name, &c->where);
868 /* Forward declaration because these functions are mutually recursive. */
869 static match match_array_cons_element (gfc_constructor_base *);
871 /* Match a list of array elements. */
874 match_array_list (gfc_constructor_base *result)
876 gfc_constructor_base head;
884 old_loc = gfc_current_locus;
886 if (gfc_match_char ('(') == MATCH_NO)
889 memset (&iter, '\0', sizeof (gfc_iterator));
892 m = match_array_cons_element (&head);
896 if (gfc_match_char (',') != MATCH_YES)
904 m = gfc_match_iterator (&iter, 0);
907 if (m == MATCH_ERROR)
910 m = match_array_cons_element (&head);
911 if (m == MATCH_ERROR)
918 goto cleanup; /* Could be a complex constant */
921 if (gfc_match_char (',') != MATCH_YES)
930 if (gfc_match_char (')') != MATCH_YES)
933 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
939 e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
940 e->value.constructor = head;
942 p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
943 p->iterator = gfc_get_iterator ();
949 gfc_error ("Syntax error in array constructor at %C");
953 gfc_constructor_free (head);
954 gfc_free_iterator (&iter, 0);
955 gfc_current_locus = old_loc;
960 /* Match a single element of an array constructor, which can be a
961 single expression or a list of elements. */
964 match_array_cons_element (gfc_constructor_base *result)
969 m = match_array_list (result);
973 m = gfc_match_expr (&expr);
977 gfc_constructor_append_expr (result, expr, &gfc_current_locus);
982 /* Match an array constructor. */
985 gfc_match_array_constructor (gfc_expr **result)
987 gfc_constructor_base head, new_cons;
992 const char *end_delim;
995 if (gfc_match (" (/") == MATCH_NO)
997 if (gfc_match (" [") == MATCH_NO)
1001 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1002 "style array constructors at %C") == FAILURE)
1010 where = gfc_current_locus;
1011 head = new_cons = NULL;
1014 /* Try to match an optional "type-spec ::" */
1015 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1017 seen_ts = (gfc_match (" ::") == MATCH_YES);
1021 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1022 "including type specification at %C") == FAILURE)
1028 gfc_current_locus = where;
1030 if (gfc_match (end_delim) == MATCH_YES)
1036 gfc_error ("Empty array constructor at %C is not allowed");
1043 m = match_array_cons_element (&head);
1044 if (m == MATCH_ERROR)
1049 if (gfc_match_char (',') == MATCH_NO)
1053 if (gfc_match (end_delim) == MATCH_NO)
1057 /* Size must be calculated at resolution time. */
1060 expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1064 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1066 expr->value.constructor = head;
1068 expr->ts.u.cl->length_from_typespec = seen_ts;
1074 gfc_error ("Syntax error in array constructor at %C");
1077 gfc_constructor_free (head);
1083 /************** Check array constructors for correctness **************/
1085 /* Given an expression, compare it's type with the type of the current
1086 constructor. Returns nonzero if an error was issued. The
1087 cons_state variable keeps track of whether the type of the
1088 constructor being read or resolved is known to be good, bad or just
1091 static gfc_typespec constructor_ts;
1093 { CONS_START, CONS_GOOD, CONS_BAD }
1097 check_element_type (gfc_expr *expr, bool convert)
1099 if (cons_state == CONS_BAD)
1100 return 0; /* Suppress further errors */
1102 if (cons_state == CONS_START)
1104 if (expr->ts.type == BT_UNKNOWN)
1105 cons_state = CONS_BAD;
1108 cons_state = CONS_GOOD;
1109 constructor_ts = expr->ts;
1115 if (gfc_compare_types (&constructor_ts, &expr->ts))
1119 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1121 gfc_error ("Element in %s array constructor at %L is %s",
1122 gfc_typename (&constructor_ts), &expr->where,
1123 gfc_typename (&expr->ts));
1125 cons_state = CONS_BAD;
1130 /* Recursive work function for gfc_check_constructor_type(). */
1133 check_constructor_type (gfc_constructor_base base, bool convert)
1138 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1142 if (e->expr_type == EXPR_ARRAY)
1144 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1150 if (check_element_type (e, convert))
1158 /* Check that all elements of an array constructor are the same type.
1159 On FAILURE, an error has been generated. */
1162 gfc_check_constructor_type (gfc_expr *e)
1166 if (e->ts.type != BT_UNKNOWN)
1168 cons_state = CONS_GOOD;
1169 constructor_ts = e->ts;
1173 cons_state = CONS_START;
1174 gfc_clear_ts (&constructor_ts);
1177 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1178 typespec, and we will now convert the values on the fly. */
1179 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1180 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1181 e->ts = constructor_ts;
1188 typedef struct cons_stack
1190 gfc_iterator *iterator;
1191 struct cons_stack *previous;
1195 static cons_stack *base;
1197 static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1199 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1200 that that variable is an iteration variables. */
1203 gfc_check_iter_variable (gfc_expr *expr)
1208 sym = expr->symtree->n.sym;
1210 for (c = base; c; c = c->previous)
1211 if (sym == c->iterator->var->symtree->n.sym)
1218 /* Recursive work function for gfc_check_constructor(). This amounts
1219 to calling the check function for each expression in the
1220 constructor, giving variables with the names of iterators a pass. */
1223 check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1230 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1234 if (e->expr_type != EXPR_ARRAY)
1236 if ((*check_function) (e) == FAILURE)
1241 element.previous = base;
1242 element.iterator = c->iterator;
1245 t = check_constructor (e->value.constructor, check_function);
1246 base = element.previous;
1252 /* Nothing went wrong, so all OK. */
1257 /* Checks a constructor to see if it is a particular kind of
1258 expression -- specification, restricted, or initialization as
1259 determined by the check_function. */
1262 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1264 cons_stack *base_save;
1270 t = check_constructor (expr->value.constructor, check_function);
1278 /**************** Simplification of array constructors ****************/
1280 iterator_stack *iter_stack;
1284 gfc_constructor_base base;
1285 int extract_count, extract_n;
1286 gfc_expr *extracted;
1290 gfc_component *component;
1292 gfc_try (*expand_work_function) (gfc_expr *);
1296 static expand_info current_expand;
1298 static gfc_try expand_constructor (gfc_constructor_base);
1301 /* Work function that counts the number of elements present in a
1305 count_elements (gfc_expr *e)
1310 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1313 if (gfc_array_size (e, &result) == FAILURE)
1319 mpz_add (*current_expand.count, *current_expand.count, result);
1328 /* Work function that extracts a particular element from an array
1329 constructor, freeing the rest. */
1332 extract_element (gfc_expr *e)
1335 { /* Something unextractable */
1340 if (current_expand.extract_count == current_expand.extract_n)
1341 current_expand.extracted = e;
1345 current_expand.extract_count++;
1351 /* Work function that constructs a new constructor out of the old one,
1352 stringing new elements together. */
1355 expand (gfc_expr *e)
1357 gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
1360 c->n.component = current_expand.component;
1365 /* Given an initialization expression that is a variable reference,
1366 substitute the current value of the iteration variable. */
1369 gfc_simplify_iterator_var (gfc_expr *e)
1373 for (p = iter_stack; p; p = p->prev)
1374 if (e->symtree == p->variable)
1378 return; /* Variable not found */
1380 gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1382 mpz_set (e->value.integer, p->value);
1388 /* Expand an expression with that is inside of a constructor,
1389 recursing into other constructors if present. */
1392 expand_expr (gfc_expr *e)
1394 if (e->expr_type == EXPR_ARRAY)
1395 return expand_constructor (e->value.constructor);
1397 e = gfc_copy_expr (e);
1399 if (gfc_simplify_expr (e, 1) == FAILURE)
1405 return current_expand.expand_work_function (e);
1410 expand_iterator (gfc_constructor *c)
1412 gfc_expr *start, *end, *step;
1413 iterator_stack frame;
1422 mpz_init (frame.value);
1425 start = gfc_copy_expr (c->iterator->start);
1426 if (gfc_simplify_expr (start, 1) == FAILURE)
1429 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1432 end = gfc_copy_expr (c->iterator->end);
1433 if (gfc_simplify_expr (end, 1) == FAILURE)
1436 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1439 step = gfc_copy_expr (c->iterator->step);
1440 if (gfc_simplify_expr (step, 1) == FAILURE)
1443 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1446 if (mpz_sgn (step->value.integer) == 0)
1448 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1452 /* Calculate the trip count of the loop. */
1453 mpz_sub (trip, end->value.integer, start->value.integer);
1454 mpz_add (trip, trip, step->value.integer);
1455 mpz_tdiv_q (trip, trip, step->value.integer);
1457 mpz_set (frame.value, start->value.integer);
1459 frame.prev = iter_stack;
1460 frame.variable = c->iterator->var->symtree;
1461 iter_stack = &frame;
1463 while (mpz_sgn (trip) > 0)
1465 if (expand_expr (c->expr) == FAILURE)
1468 mpz_add (frame.value, frame.value, step->value.integer);
1469 mpz_sub_ui (trip, trip, 1);
1475 gfc_free_expr (start);
1476 gfc_free_expr (end);
1477 gfc_free_expr (step);
1480 mpz_clear (frame.value);
1482 iter_stack = frame.prev;
1488 /* Expand a constructor into constant constructors without any
1489 iterators, calling the work function for each of the expanded
1490 expressions. The work function needs to either save or free the
1491 passed expression. */
1494 expand_constructor (gfc_constructor_base base)
1499 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1501 if (c->iterator != NULL)
1503 if (expand_iterator (c) == FAILURE)
1510 if (e->expr_type == EXPR_ARRAY)
1512 if (expand_constructor (e->value.constructor) == FAILURE)
1518 e = gfc_copy_expr (e);
1519 if (gfc_simplify_expr (e, 1) == FAILURE)
1524 current_expand.offset = &c->offset;
1525 current_expand.component = c->n.component;
1526 if (current_expand.expand_work_function (e) == FAILURE)
1533 /* Given an array expression and an element number (starting at zero),
1534 return a pointer to the array element. NULL is returned if the
1535 size of the array has been exceeded. The expression node returned
1536 remains a part of the array and should not be freed. Access is not
1537 efficient at all, but this is another place where things do not
1538 have to be particularly fast. */
1541 gfc_get_array_element (gfc_expr *array, int element)
1543 expand_info expand_save;
1547 expand_save = current_expand;
1548 current_expand.extract_n = element;
1549 current_expand.expand_work_function = extract_element;
1550 current_expand.extracted = NULL;
1551 current_expand.extract_count = 0;
1555 rc = expand_constructor (array->value.constructor);
1556 e = current_expand.extracted;
1557 current_expand = expand_save;
1566 /* Top level subroutine for expanding constructors. We only expand
1567 constructor if they are small enough. */
1570 gfc_expand_constructor (gfc_expr *e, bool fatal)
1572 expand_info expand_save;
1576 /* If we can successfully get an array element at the max array size then
1577 the array is too big to expand, so we just return. */
1578 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1584 gfc_error ("The number of elements in the array constructor "
1585 "at %L requires an increase of the allowed %d "
1586 "upper limit. See -fmax-array-constructor "
1587 "option", &e->where,
1588 gfc_option.flag_max_array_constructor);
1594 /* We now know the array is not too big so go ahead and try to expand it. */
1595 expand_save = current_expand;
1596 current_expand.base = NULL;
1600 current_expand.expand_work_function = expand;
1602 if (expand_constructor (e->value.constructor) == FAILURE)
1604 gfc_constructor_free (current_expand.base);
1609 gfc_constructor_free (e->value.constructor);
1610 e->value.constructor = current_expand.base;
1615 current_expand = expand_save;
1621 /* Work function for checking that an element of a constructor is a
1622 constant, after removal of any iteration variables. We return
1623 FAILURE if not so. */
1626 is_constant_element (gfc_expr *e)
1630 rv = gfc_is_constant_expr (e);
1633 return rv ? SUCCESS : FAILURE;
1637 /* Given an array constructor, determine if the constructor is
1638 constant or not by expanding it and making sure that all elements
1639 are constants. This is a bit of a hack since something like (/ (i,
1640 i=1,100000000) /) will take a while as* opposed to a more clever
1641 function that traverses the expression tree. FIXME. */
1644 gfc_constant_ac (gfc_expr *e)
1646 expand_info expand_save;
1650 expand_save = current_expand;
1651 current_expand.expand_work_function = is_constant_element;
1653 rc = expand_constructor (e->value.constructor);
1655 current_expand = expand_save;
1663 /* Returns nonzero if an array constructor has been completely
1664 expanded (no iterators) and zero if iterators are present. */
1667 gfc_expanded_ac (gfc_expr *e)
1671 if (e->expr_type == EXPR_ARRAY)
1672 for (c = gfc_constructor_first (e->value.constructor);
1673 c; c = gfc_constructor_next (c))
1674 if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1681 /*************** Type resolution of array constructors ***************/
1683 /* Recursive array list resolution function. All of the elements must
1684 be of the same type. */
1687 resolve_array_list (gfc_constructor_base base)
1694 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1696 if (c->iterator != NULL
1697 && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1700 if (gfc_resolve_expr (c->expr) == FAILURE)
1707 /* Resolve character array constructor. If it has a specified constant character
1708 length, pad/truncate the elements here; if the length is not specified and
1709 all elements are of compile-time known length, emit an error as this is
1713 gfc_resolve_character_array_constructor (gfc_expr *expr)
1718 gcc_assert (expr->expr_type == EXPR_ARRAY);
1719 gcc_assert (expr->ts.type == BT_CHARACTER);
1721 if (expr->ts.u.cl == NULL)
1723 for (p = gfc_constructor_first (expr->value.constructor);
1724 p; p = gfc_constructor_next (p))
1725 if (p->expr->ts.u.cl != NULL)
1727 /* Ensure that if there is a char_len around that it is
1728 used; otherwise the middle-end confuses them! */
1729 expr->ts.u.cl = p->expr->ts.u.cl;
1733 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1740 if (expr->ts.u.cl->length == NULL)
1742 /* Check that all constant string elements have the same length until
1743 we reach the end or find a variable-length one. */
1745 for (p = gfc_constructor_first (expr->value.constructor);
1746 p; p = gfc_constructor_next (p))
1748 int current_length = -1;
1750 for (ref = p->expr->ref; ref; ref = ref->next)
1751 if (ref->type == REF_SUBSTRING
1752 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1753 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1756 if (p->expr->expr_type == EXPR_CONSTANT)
1757 current_length = p->expr->value.character.length;
1761 j = mpz_get_ui (ref->u.ss.end->value.integer)
1762 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1763 current_length = (int) j;
1765 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1766 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1769 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1770 current_length = (int) j;
1775 gcc_assert (current_length != -1);
1777 if (found_length == -1)
1778 found_length = current_length;
1779 else if (found_length != current_length)
1781 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1782 " constructor at %L", found_length, current_length,
1787 gcc_assert (found_length == current_length);
1790 gcc_assert (found_length != -1);
1792 /* Update the character length of the array constructor. */
1793 expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1794 NULL, found_length);
1798 /* We've got a character length specified. It should be an integer,
1799 otherwise an error is signalled elsewhere. */
1800 gcc_assert (expr->ts.u.cl->length);
1802 /* If we've got a constant character length, pad according to this.
1803 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1804 max_length only if they pass. */
1805 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1807 /* Now pad/truncate the elements accordingly to the specified character
1808 length. This is ok inside this conditional, as in the case above
1809 (without typespec) all elements are verified to have the same length
1811 if (found_length != -1)
1812 for (p = gfc_constructor_first (expr->value.constructor);
1813 p; p = gfc_constructor_next (p))
1814 if (p->expr->expr_type == EXPR_CONSTANT)
1816 gfc_expr *cl = NULL;
1817 int current_length = -1;
1820 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1822 cl = p->expr->ts.u.cl->length;
1823 gfc_extract_int (cl, ¤t_length);
1826 /* If gfc_extract_int above set current_length, we implicitly
1827 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1829 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1832 || (current_length != -1 && current_length < found_length))
1833 gfc_set_constant_character_len (found_length, p->expr,
1834 has_ts ? -1 : found_length);
1842 /* Resolve all of the expressions in an array list. */
1845 gfc_resolve_array_constructor (gfc_expr *expr)
1849 t = resolve_array_list (expr->value.constructor);
1851 t = gfc_check_constructor_type (expr);
1853 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1854 the call to this function, so we don't need to call it here; if it was
1855 called twice, an error message there would be duplicated. */
1861 /* Copy an iterator structure. */
1864 gfc_copy_iterator (gfc_iterator *src)
1871 dest = gfc_get_iterator ();
1873 dest->var = gfc_copy_expr (src->var);
1874 dest->start = gfc_copy_expr (src->start);
1875 dest->end = gfc_copy_expr (src->end);
1876 dest->step = gfc_copy_expr (src->step);
1882 /********* Subroutines for determining the size of an array *********/
1884 /* These are needed just to accommodate RESHAPE(). There are no
1885 diagnostics here, we just return a negative number if something
1889 /* Get the size of single dimension of an array specification. The
1890 array is guaranteed to be one dimensional. */
1893 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1898 if (dimen < 0 || dimen > as->rank - 1)
1899 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1901 if (as->type != AS_EXPLICIT
1902 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1903 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1904 || as->lower[dimen]->ts.type != BT_INTEGER
1905 || as->upper[dimen]->ts.type != BT_INTEGER)
1910 mpz_sub (*result, as->upper[dimen]->value.integer,
1911 as->lower[dimen]->value.integer);
1913 mpz_add_ui (*result, *result, 1);
1920 spec_size (gfc_array_spec *as, mpz_t *result)
1925 mpz_init_set_ui (*result, 1);
1927 for (d = 0; d < as->rank; d++)
1929 if (spec_dimen_size (as, d, &size) == FAILURE)
1931 mpz_clear (*result);
1935 mpz_mul (*result, *result, size);
1943 /* Get the number of elements in an array section. */
1946 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1948 mpz_t upper, lower, stride;
1951 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1952 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1954 switch (ar->dimen_type[dimen])
1958 mpz_set_ui (*result, 1);
1963 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1972 if (ar->start[dimen] == NULL)
1974 if (ar->as->lower[dimen] == NULL
1975 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1977 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1981 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1983 mpz_set (lower, ar->start[dimen]->value.integer);
1986 if (ar->end[dimen] == NULL)
1988 if (ar->as->upper[dimen] == NULL
1989 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1991 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1995 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1997 mpz_set (upper, ar->end[dimen]->value.integer);
2000 if (ar->stride[dimen] == NULL)
2001 mpz_set_ui (stride, 1);
2004 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2006 mpz_set (stride, ar->stride[dimen]->value.integer);
2010 mpz_sub (*result, upper, lower);
2011 mpz_add (*result, *result, stride);
2012 mpz_div (*result, *result, stride);
2014 /* Zero stride caught earlier. */
2015 if (mpz_cmp_ui (*result, 0) < 0)
2016 mpz_set_ui (*result, 0);
2026 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2034 ref_size (gfc_array_ref *ar, mpz_t *result)
2039 mpz_init_set_ui (*result, 1);
2041 for (d = 0; d < ar->dimen; d++)
2043 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2045 mpz_clear (*result);
2049 mpz_mul (*result, *result, size);
2057 /* Given an array expression and a dimension, figure out how many
2058 elements it has along that dimension. Returns SUCCESS if we were
2059 able to return a result in the 'result' variable, FAILURE
2063 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2068 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2069 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2071 switch (array->expr_type)
2075 for (ref = array->ref; ref; ref = ref->next)
2077 if (ref->type != REF_ARRAY)
2080 if (ref->u.ar.type == AR_FULL)
2081 return spec_dimen_size (ref->u.ar.as, dimen, result);
2083 if (ref->u.ar.type == AR_SECTION)
2085 for (i = 0; dimen >= 0; i++)
2086 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2089 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2093 if (array->shape && array->shape[dimen])
2095 mpz_init_set (*result, array->shape[dimen]);
2099 if (array->symtree->n.sym->attr.generic
2100 && array->value.function.esym != NULL)
2102 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2106 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2113 if (array->shape == NULL) {
2114 /* Expressions with rank > 1 should have "shape" properly set */
2115 if ( array->rank != 1 )
2116 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2117 return gfc_array_size(array, result);
2122 if (array->shape == NULL)
2125 mpz_init_set (*result, array->shape[dimen]);
2134 /* Given an array expression, figure out how many elements are in the
2135 array. Returns SUCCESS if this is possible, and sets the 'result'
2136 variable. Otherwise returns FAILURE. */
2139 gfc_array_size (gfc_expr *array, mpz_t *result)
2141 expand_info expand_save;
2146 switch (array->expr_type)
2149 gfc_push_suppress_errors ();
2151 expand_save = current_expand;
2153 current_expand.count = result;
2154 mpz_init_set_ui (*result, 0);
2156 current_expand.expand_work_function = count_elements;
2159 t = expand_constructor (array->value.constructor);
2161 gfc_pop_suppress_errors ();
2164 mpz_clear (*result);
2165 current_expand = expand_save;
2169 for (ref = array->ref; ref; ref = ref->next)
2171 if (ref->type != REF_ARRAY)
2174 if (ref->u.ar.type == AR_FULL)
2175 return spec_size (ref->u.ar.as, result);
2177 if (ref->u.ar.type == AR_SECTION)
2178 return ref_size (&ref->u.ar, result);
2181 return spec_size (array->symtree->n.sym->as, result);
2185 if (array->rank == 0 || array->shape == NULL)
2188 mpz_init_set_ui (*result, 1);
2190 for (i = 0; i < array->rank; i++)
2191 mpz_mul (*result, *result, array->shape[i]);
2200 /* Given an array reference, return the shape of the reference in an
2201 array of mpz_t integers. */
2204 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2214 for (; d < ar->as->rank; d++)
2215 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2221 for (i = 0; i < ar->dimen; i++)
2223 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2225 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2238 for (d--; d >= 0; d--)
2239 mpz_clear (shape[d]);
2245 /* Given an array expression, find the array reference structure that
2246 characterizes the reference. */
2249 gfc_find_array_ref (gfc_expr *e)
2253 for (ref = e->ref; ref; ref = ref->next)
2254 if (ref->type == REF_ARRAY
2255 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
2256 || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
2260 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2266 /* Find out if an array shape is known at compile time. */
2269 gfc_is_compile_time_shape (gfc_array_spec *as)
2273 if (as->type != AS_EXPLICIT)
2276 for (i = 0; i < as->rank; i++)
2277 if (!gfc_is_constant_expr (as->lower[i])
2278 || !gfc_is_constant_expr (as->upper[i]))