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)
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]);
95 gfc_error ("Expected array subscript at %C");
99 if (gfc_match_char (':') == MATCH_NO)
104 gfc_error ("Unexpected '*' in coarray subscript at %C");
108 /* Get an optional end element. Because we've seen the colon, we
109 definitely have a range along this dimension. */
111 ar->dimen_type[i] = DIMEN_RANGE;
113 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
116 m = gfc_match_init_expr (&ar->end[i]);
118 m = gfc_match_expr (&ar->end[i]);
120 if (m == MATCH_ERROR)
123 /* See if we have an optional stride. */
124 if (gfc_match_char (':') == MATCH_YES)
128 gfc_error ("Strides not allowed in coarray subscript at %C");
132 m = init ? gfc_match_init_expr (&ar->stride[i])
133 : gfc_match_expr (&ar->stride[i]);
136 gfc_error ("Expected array subscript stride at %C");
143 ar->dimen_type[i] = DIMEN_STAR;
149 /* Match an array reference, whether it is the whole array or a
150 particular elements or a section. If init is set, the reference has
151 to consist of init expressions. */
154 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
158 bool matched_bracket = false;
160 memset (ar, '\0', sizeof (ar));
162 ar->where = gfc_current_locus;
164 ar->type = AR_UNKNOWN;
166 if (gfc_match_char ('[') == MATCH_YES)
168 matched_bracket = true;
172 if (gfc_match_char ('(') != MATCH_YES)
179 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
181 m = match_subscript (ar, init, false);
182 if (m == MATCH_ERROR)
185 if (gfc_match_char (')') == MATCH_YES)
191 if (gfc_match_char (',') != MATCH_YES)
193 gfc_error ("Invalid form of array reference at %C");
198 gfc_error ("Array reference at %C cannot have more than %d dimensions",
203 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
211 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
213 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
219 gfc_error ("Unexpected coarray designator at %C");
223 for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
225 m = match_subscript (ar, init, ar->codimen == (corank - 1));
226 if (m == MATCH_ERROR)
229 if (gfc_match_char (']') == MATCH_YES)
235 if (gfc_match_char (',') != MATCH_YES)
237 gfc_error ("Invalid form of coarray reference at %C");
242 gfc_error ("Array reference at %C cannot have more than %d dimensions",
249 /************** Array specification matching subroutines ***************/
251 /* Free all of the expressions associated with array bounds
255 gfc_free_array_spec (gfc_array_spec *as)
262 for (i = 0; i < as->rank + as->corank; i++)
264 gfc_free_expr (as->lower[i]);
265 gfc_free_expr (as->upper[i]);
272 /* Take an array bound, resolves the expression, that make up the
273 shape and check associated constraints. */
276 resolve_array_bound (gfc_expr *e, int check_constant)
281 if (gfc_resolve_expr (e) == FAILURE
282 || gfc_specification_expr (e) == FAILURE)
285 if (check_constant && gfc_is_constant_expr (e) == 0)
287 gfc_error ("Variable '%s' at %L in this context must be constant",
288 e->symtree->n.sym->name, &e->where);
296 /* Takes an array specification, resolves the expressions that make up
297 the shape and make sure everything is integral. */
300 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
308 for (i = 0; i < as->rank + as->corank; i++)
311 if (resolve_array_bound (e, check_constant) == FAILURE)
315 if (resolve_array_bound (e, check_constant) == FAILURE)
318 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
321 /* If the size is negative in this dimension, set it to zero. */
322 if (as->lower[i]->expr_type == EXPR_CONSTANT
323 && as->upper[i]->expr_type == EXPR_CONSTANT
324 && mpz_cmp (as->upper[i]->value.integer,
325 as->lower[i]->value.integer) < 0)
327 gfc_free_expr (as->upper[i]);
328 as->upper[i] = gfc_copy_expr (as->lower[i]);
329 mpz_sub_ui (as->upper[i]->value.integer,
330 as->upper[i]->value.integer, 1);
338 /* Match a single array element specification. The return values as
339 well as the upper and lower bounds of the array spec are filled
340 in according to what we see on the input. The caller makes sure
341 individual specifications make sense as a whole.
344 Parsed Lower Upper Returned
345 ------------------------------------
346 : NULL NULL AS_DEFERRED (*)
348 x: x NULL AS_ASSUMED_SHAPE
350 x:* x NULL AS_ASSUMED_SIZE
351 * 1 NULL AS_ASSUMED_SIZE
353 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
354 is fixed during the resolution of formal interfaces.
356 Anything else AS_UNKNOWN. */
359 match_array_element_spec (gfc_array_spec *as)
361 gfc_expr **upper, **lower;
364 lower = &as->lower[as->rank + as->corank - 1];
365 upper = &as->upper[as->rank + as->corank - 1];
367 if (gfc_match_char ('*') == MATCH_YES)
369 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
370 return AS_ASSUMED_SIZE;
373 if (gfc_match_char (':') == MATCH_YES)
376 m = gfc_match_expr (upper);
378 gfc_error ("Expected expression in array specification at %C");
381 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
384 if (gfc_match_char (':') == MATCH_NO)
386 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
393 if (gfc_match_char ('*') == MATCH_YES)
394 return AS_ASSUMED_SIZE;
396 m = gfc_match_expr (upper);
397 if (m == MATCH_ERROR)
400 return AS_ASSUMED_SHAPE;
401 if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
408 /* Matches an array specification, incidentally figuring out what sort
409 it is. Match either a normal array specification, or a coarray spec
410 or both. Optionally allow [:] for coarrays. */
413 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
415 array_type current_type;
419 as = gfc_get_array_spec ();
423 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
432 if (gfc_match_char ('(') != MATCH_YES)
442 current_type = match_array_element_spec (as);
446 if (current_type == AS_UNKNOWN)
448 as->type = current_type;
452 { /* See how current spec meshes with the existing. */
457 if (current_type == AS_ASSUMED_SIZE)
459 as->type = AS_ASSUMED_SIZE;
463 if (current_type == AS_EXPLICIT)
466 gfc_error ("Bad array specification for an explicitly shaped "
471 case AS_ASSUMED_SHAPE:
472 if ((current_type == AS_ASSUMED_SHAPE)
473 || (current_type == AS_DEFERRED))
476 gfc_error ("Bad array specification for assumed shape "
481 if (current_type == AS_DEFERRED)
484 if (current_type == AS_ASSUMED_SHAPE)
486 as->type = AS_ASSUMED_SHAPE;
490 gfc_error ("Bad specification for deferred shape array at %C");
493 case AS_ASSUMED_SIZE:
494 gfc_error ("Bad specification for assumed size array at %C");
498 if (gfc_match_char (')') == MATCH_YES)
501 if (gfc_match_char (',') != MATCH_YES)
503 gfc_error ("Expected another dimension in array declaration at %C");
507 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
509 gfc_error ("Array specification at %C has more than %d dimensions",
514 if (as->corank + as->rank >= 7
515 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
516 "specification at %C with more than 7 dimensions")
525 if (gfc_match_char ('[') != MATCH_YES)
528 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
532 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
534 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
541 current_type = match_array_element_spec (as);
543 if (current_type == AS_UNKNOWN)
547 as->cotype = current_type;
550 { /* See how current spec meshes with the existing. */
555 if (current_type == AS_ASSUMED_SIZE)
557 as->cotype = AS_ASSUMED_SIZE;
561 if (current_type == AS_EXPLICIT)
564 gfc_error ("Bad array specification for an explicitly "
565 "shaped array at %C");
569 case AS_ASSUMED_SHAPE:
570 if ((current_type == AS_ASSUMED_SHAPE)
571 || (current_type == AS_DEFERRED))
574 gfc_error ("Bad array specification for assumed shape "
579 if (current_type == AS_DEFERRED)
582 if (current_type == AS_ASSUMED_SHAPE)
584 as->cotype = AS_ASSUMED_SHAPE;
588 gfc_error ("Bad specification for deferred shape array at %C");
591 case AS_ASSUMED_SIZE:
592 gfc_error ("Bad specification for assumed size array at %C");
596 if (gfc_match_char (']') == MATCH_YES)
599 if (gfc_match_char (',') != MATCH_YES)
601 gfc_error ("Expected another dimension in array declaration at %C");
605 if (as->corank >= GFC_MAX_DIMENSIONS)
607 gfc_error ("Array specification at %C has more than %d "
608 "dimensions", GFC_MAX_DIMENSIONS);
613 if (current_type == AS_EXPLICIT)
615 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
619 if (as->cotype == AS_ASSUMED_SIZE)
620 as->cotype = AS_EXPLICIT;
623 as->type = as->cotype;
626 if (as->rank == 0 && as->corank == 0)
629 gfc_free_array_spec (as);
633 /* If a lower bounds of an assumed shape array is blank, put in one. */
634 if (as->type == AS_ASSUMED_SHAPE)
636 for (i = 0; i < as->rank + as->corank; i++)
638 if (as->lower[i] == NULL)
639 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
648 /* Something went wrong. */
649 gfc_free_array_spec (as);
654 /* Given a symbol and an array specification, modify the symbol to
655 have that array specification. The error locus is needed in case
656 something goes wrong. On failure, the caller must free the spec. */
659 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
667 && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
671 && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
682 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
683 the codimension is simply added. */
684 gcc_assert (as->rank == 0 && sym->as->corank == 0);
686 sym->as->cotype = as->cotype;
687 sym->as->corank = as->corank;
688 for (i = 0; i < as->corank; i++)
690 sym->as->lower[sym->as->rank + i] = as->lower[i];
691 sym->as->upper[sym->as->rank + i] = as->upper[i];
696 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
697 the dimension is added - but first the codimensions (if existing
698 need to be shifted to make space for the dimension. */
699 gcc_assert (as->corank == 0 && sym->as->rank == 0);
701 sym->as->rank = as->rank;
702 sym->as->type = as->type;
703 sym->as->cray_pointee = as->cray_pointee;
704 sym->as->cp_was_assumed = as->cp_was_assumed;
706 for (i = 0; i < sym->as->corank; i++)
708 sym->as->lower[as->rank + i] = sym->as->lower[i];
709 sym->as->upper[as->rank + i] = sym->as->upper[i];
711 for (i = 0; i < as->rank; i++)
713 sym->as->lower[i] = as->lower[i];
714 sym->as->upper[i] = as->upper[i];
723 /* Copy an array specification. */
726 gfc_copy_array_spec (gfc_array_spec *src)
728 gfc_array_spec *dest;
734 dest = gfc_get_array_spec ();
738 for (i = 0; i < dest->rank + dest->corank; i++)
740 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
741 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
748 /* Returns nonzero if the two expressions are equal. Only handles integer
752 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
754 if (bound1 == NULL || bound2 == NULL
755 || bound1->expr_type != EXPR_CONSTANT
756 || bound2->expr_type != EXPR_CONSTANT
757 || bound1->ts.type != BT_INTEGER
758 || bound2->ts.type != BT_INTEGER)
759 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
761 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
768 /* Compares two array specifications. They must be constant or deferred
772 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
776 if (as1 == NULL && as2 == NULL)
779 if (as1 == NULL || as2 == NULL)
782 if (as1->rank != as2->rank)
785 if (as1->corank != as2->corank)
791 if (as1->type != as2->type)
794 if (as1->type == AS_EXPLICIT)
795 for (i = 0; i < as1->rank + as1->corank; i++)
797 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
800 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
808 /****************** Array constructor functions ******************/
811 /* Given an expression node that might be an array constructor and a
812 symbol, make sure that no iterators in this or child constructors
813 use the symbol as an implied-DO iterator. Returns nonzero if a
814 duplicate was found. */
817 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
822 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
826 if (e->expr_type == EXPR_ARRAY
827 && check_duplicate_iterator (e->value.constructor, master))
830 if (c->iterator == NULL)
833 if (c->iterator->var->symtree->n.sym == master)
835 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
836 "same name", master->name, &c->where);
846 /* Forward declaration because these functions are mutually recursive. */
847 static match match_array_cons_element (gfc_constructor_base *);
849 /* Match a list of array elements. */
852 match_array_list (gfc_constructor_base *result)
854 gfc_constructor_base head;
862 old_loc = gfc_current_locus;
864 if (gfc_match_char ('(') == MATCH_NO)
867 memset (&iter, '\0', sizeof (gfc_iterator));
870 m = match_array_cons_element (&head);
874 if (gfc_match_char (',') != MATCH_YES)
882 m = gfc_match_iterator (&iter, 0);
885 if (m == MATCH_ERROR)
888 m = match_array_cons_element (&head);
889 if (m == MATCH_ERROR)
896 goto cleanup; /* Could be a complex constant */
899 if (gfc_match_char (',') != MATCH_YES)
908 if (gfc_match_char (')') != MATCH_YES)
911 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
917 e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
918 e->value.constructor = head;
920 p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
921 p->iterator = gfc_get_iterator ();
927 gfc_error ("Syntax error in array constructor at %C");
931 gfc_constructor_free (head);
932 gfc_free_iterator (&iter, 0);
933 gfc_current_locus = old_loc;
938 /* Match a single element of an array constructor, which can be a
939 single expression or a list of elements. */
942 match_array_cons_element (gfc_constructor_base *result)
947 m = match_array_list (result);
951 m = gfc_match_expr (&expr);
955 gfc_constructor_append_expr (result, expr, &gfc_current_locus);
960 /* Match an array constructor. */
963 gfc_match_array_constructor (gfc_expr **result)
965 gfc_constructor_base head, new_cons;
970 const char *end_delim;
973 if (gfc_match (" (/") == MATCH_NO)
975 if (gfc_match (" [") == MATCH_NO)
979 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
980 "style array constructors at %C") == FAILURE)
988 where = gfc_current_locus;
989 head = new_cons = NULL;
992 /* Try to match an optional "type-spec ::" */
993 if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
995 seen_ts = (gfc_match (" ::") == MATCH_YES);
999 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1000 "including type specification at %C") == FAILURE)
1006 gfc_current_locus = where;
1008 if (gfc_match (end_delim) == MATCH_YES)
1014 gfc_error ("Empty array constructor at %C is not allowed");
1021 m = match_array_cons_element (&head);
1022 if (m == MATCH_ERROR)
1027 if (gfc_match_char (',') == MATCH_NO)
1031 if (gfc_match (end_delim) == MATCH_NO)
1035 /* Size must be calculated at resolution time. */
1038 expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1042 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1044 expr->value.constructor = head;
1046 expr->ts.u.cl->length_from_typespec = seen_ts;
1052 gfc_error ("Syntax error in array constructor at %C");
1055 gfc_constructor_free (head);
1061 /************** Check array constructors for correctness **************/
1063 /* Given an expression, compare it's type with the type of the current
1064 constructor. Returns nonzero if an error was issued. The
1065 cons_state variable keeps track of whether the type of the
1066 constructor being read or resolved is known to be good, bad or just
1069 static gfc_typespec constructor_ts;
1071 { CONS_START, CONS_GOOD, CONS_BAD }
1075 check_element_type (gfc_expr *expr, bool convert)
1077 if (cons_state == CONS_BAD)
1078 return 0; /* Suppress further errors */
1080 if (cons_state == CONS_START)
1082 if (expr->ts.type == BT_UNKNOWN)
1083 cons_state = CONS_BAD;
1086 cons_state = CONS_GOOD;
1087 constructor_ts = expr->ts;
1093 if (gfc_compare_types (&constructor_ts, &expr->ts))
1097 return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1099 gfc_error ("Element in %s array constructor at %L is %s",
1100 gfc_typename (&constructor_ts), &expr->where,
1101 gfc_typename (&expr->ts));
1103 cons_state = CONS_BAD;
1108 /* Recursive work function for gfc_check_constructor_type(). */
1111 check_constructor_type (gfc_constructor_base base, bool convert)
1116 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1120 if (e->expr_type == EXPR_ARRAY)
1122 if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1128 if (check_element_type (e, convert))
1136 /* Check that all elements of an array constructor are the same type.
1137 On FAILURE, an error has been generated. */
1140 gfc_check_constructor_type (gfc_expr *e)
1144 if (e->ts.type != BT_UNKNOWN)
1146 cons_state = CONS_GOOD;
1147 constructor_ts = e->ts;
1151 cons_state = CONS_START;
1152 gfc_clear_ts (&constructor_ts);
1155 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1156 typespec, and we will now convert the values on the fly. */
1157 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1158 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1159 e->ts = constructor_ts;
1166 typedef struct cons_stack
1168 gfc_iterator *iterator;
1169 struct cons_stack *previous;
1173 static cons_stack *base;
1175 static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1177 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1178 that that variable is an iteration variables. */
1181 gfc_check_iter_variable (gfc_expr *expr)
1186 sym = expr->symtree->n.sym;
1188 for (c = base; c; c = c->previous)
1189 if (sym == c->iterator->var->symtree->n.sym)
1196 /* Recursive work function for gfc_check_constructor(). This amounts
1197 to calling the check function for each expression in the
1198 constructor, giving variables with the names of iterators a pass. */
1201 check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1208 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1212 if (e->expr_type != EXPR_ARRAY)
1214 if ((*check_function) (e) == FAILURE)
1219 element.previous = base;
1220 element.iterator = c->iterator;
1223 t = check_constructor (e->value.constructor, check_function);
1224 base = element.previous;
1230 /* Nothing went wrong, so all OK. */
1235 /* Checks a constructor to see if it is a particular kind of
1236 expression -- specification, restricted, or initialization as
1237 determined by the check_function. */
1240 gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1242 cons_stack *base_save;
1248 t = check_constructor (expr->value.constructor, check_function);
1256 /**************** Simplification of array constructors ****************/
1258 iterator_stack *iter_stack;
1262 gfc_constructor_base base;
1263 int extract_count, extract_n;
1264 gfc_expr *extracted;
1268 gfc_component *component;
1270 gfc_try (*expand_work_function) (gfc_expr *);
1274 static expand_info current_expand;
1276 static gfc_try expand_constructor (gfc_constructor_base);
1279 /* Work function that counts the number of elements present in a
1283 count_elements (gfc_expr *e)
1288 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1291 if (gfc_array_size (e, &result) == FAILURE)
1297 mpz_add (*current_expand.count, *current_expand.count, result);
1306 /* Work function that extracts a particular element from an array
1307 constructor, freeing the rest. */
1310 extract_element (gfc_expr *e)
1313 { /* Something unextractable */
1318 if (current_expand.extract_count == current_expand.extract_n)
1319 current_expand.extracted = e;
1323 current_expand.extract_count++;
1329 /* Work function that constructs a new constructor out of the old one,
1330 stringing new elements together. */
1333 expand (gfc_expr *e)
1335 gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
1338 c->n.component = current_expand.component;
1343 /* Given an initialization expression that is a variable reference,
1344 substitute the current value of the iteration variable. */
1347 gfc_simplify_iterator_var (gfc_expr *e)
1351 for (p = iter_stack; p; p = p->prev)
1352 if (e->symtree == p->variable)
1356 return; /* Variable not found */
1358 gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1360 mpz_set (e->value.integer, p->value);
1366 /* Expand an expression with that is inside of a constructor,
1367 recursing into other constructors if present. */
1370 expand_expr (gfc_expr *e)
1372 if (e->expr_type == EXPR_ARRAY)
1373 return expand_constructor (e->value.constructor);
1375 e = gfc_copy_expr (e);
1377 if (gfc_simplify_expr (e, 1) == FAILURE)
1383 return current_expand.expand_work_function (e);
1388 expand_iterator (gfc_constructor *c)
1390 gfc_expr *start, *end, *step;
1391 iterator_stack frame;
1400 mpz_init (frame.value);
1403 start = gfc_copy_expr (c->iterator->start);
1404 if (gfc_simplify_expr (start, 1) == FAILURE)
1407 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1410 end = gfc_copy_expr (c->iterator->end);
1411 if (gfc_simplify_expr (end, 1) == FAILURE)
1414 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1417 step = gfc_copy_expr (c->iterator->step);
1418 if (gfc_simplify_expr (step, 1) == FAILURE)
1421 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1424 if (mpz_sgn (step->value.integer) == 0)
1426 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1430 /* Calculate the trip count of the loop. */
1431 mpz_sub (trip, end->value.integer, start->value.integer);
1432 mpz_add (trip, trip, step->value.integer);
1433 mpz_tdiv_q (trip, trip, step->value.integer);
1435 mpz_set (frame.value, start->value.integer);
1437 frame.prev = iter_stack;
1438 frame.variable = c->iterator->var->symtree;
1439 iter_stack = &frame;
1441 while (mpz_sgn (trip) > 0)
1443 if (expand_expr (c->expr) == FAILURE)
1446 mpz_add (frame.value, frame.value, step->value.integer);
1447 mpz_sub_ui (trip, trip, 1);
1453 gfc_free_expr (start);
1454 gfc_free_expr (end);
1455 gfc_free_expr (step);
1458 mpz_clear (frame.value);
1460 iter_stack = frame.prev;
1466 /* Expand a constructor into constant constructors without any
1467 iterators, calling the work function for each of the expanded
1468 expressions. The work function needs to either save or free the
1469 passed expression. */
1472 expand_constructor (gfc_constructor_base base)
1477 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1479 if (c->iterator != NULL)
1481 if (expand_iterator (c) == FAILURE)
1488 if (e->expr_type == EXPR_ARRAY)
1490 if (expand_constructor (e->value.constructor) == FAILURE)
1496 e = gfc_copy_expr (e);
1497 if (gfc_simplify_expr (e, 1) == FAILURE)
1502 current_expand.offset = &c->offset;
1503 current_expand.component = c->n.component;
1504 if (current_expand.expand_work_function (e) == FAILURE)
1511 /* Given an array expression and an element number (starting at zero),
1512 return a pointer to the array element. NULL is returned if the
1513 size of the array has been exceeded. The expression node returned
1514 remains a part of the array and should not be freed. Access is not
1515 efficient at all, but this is another place where things do not
1516 have to be particularly fast. */
1519 gfc_get_array_element (gfc_expr *array, int element)
1521 expand_info expand_save;
1525 expand_save = current_expand;
1526 current_expand.extract_n = element;
1527 current_expand.expand_work_function = extract_element;
1528 current_expand.extracted = NULL;
1529 current_expand.extract_count = 0;
1533 rc = expand_constructor (array->value.constructor);
1534 e = current_expand.extracted;
1535 current_expand = expand_save;
1544 /* Top level subroutine for expanding constructors. We only expand
1545 constructor if they are small enough. */
1548 gfc_expand_constructor (gfc_expr *e)
1550 expand_info expand_save;
1554 /* If we can successfully get an array element at the max array size then
1555 the array is too big to expand, so we just return. */
1556 f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1563 /* We now know the array is not too big so go ahead and try to expand it. */
1564 expand_save = current_expand;
1565 current_expand.base = NULL;
1569 current_expand.expand_work_function = expand;
1571 if (expand_constructor (e->value.constructor) == FAILURE)
1573 gfc_constructor_free (current_expand.base);
1578 gfc_constructor_free (e->value.constructor);
1579 e->value.constructor = current_expand.base;
1584 current_expand = expand_save;
1590 /* Work function for checking that an element of a constructor is a
1591 constant, after removal of any iteration variables. We return
1592 FAILURE if not so. */
1595 is_constant_element (gfc_expr *e)
1599 rv = gfc_is_constant_expr (e);
1602 return rv ? SUCCESS : FAILURE;
1606 /* Given an array constructor, determine if the constructor is
1607 constant or not by expanding it and making sure that all elements
1608 are constants. This is a bit of a hack since something like (/ (i,
1609 i=1,100000000) /) will take a while as* opposed to a more clever
1610 function that traverses the expression tree. FIXME. */
1613 gfc_constant_ac (gfc_expr *e)
1615 expand_info expand_save;
1619 expand_save = current_expand;
1620 current_expand.expand_work_function = is_constant_element;
1622 rc = expand_constructor (e->value.constructor);
1624 current_expand = expand_save;
1632 /* Returns nonzero if an array constructor has been completely
1633 expanded (no iterators) and zero if iterators are present. */
1636 gfc_expanded_ac (gfc_expr *e)
1640 if (e->expr_type == EXPR_ARRAY)
1641 for (c = gfc_constructor_first (e->value.constructor);
1642 c; c = gfc_constructor_next (c))
1643 if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1650 /*************** Type resolution of array constructors ***************/
1652 /* Recursive array list resolution function. All of the elements must
1653 be of the same type. */
1656 resolve_array_list (gfc_constructor_base base)
1663 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1665 if (c->iterator != NULL
1666 && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1669 if (gfc_resolve_expr (c->expr) == FAILURE)
1676 /* Resolve character array constructor. If it has a specified constant character
1677 length, pad/truncate the elements here; if the length is not specified and
1678 all elements are of compile-time known length, emit an error as this is
1682 gfc_resolve_character_array_constructor (gfc_expr *expr)
1687 gcc_assert (expr->expr_type == EXPR_ARRAY);
1688 gcc_assert (expr->ts.type == BT_CHARACTER);
1690 if (expr->ts.u.cl == NULL)
1692 for (p = gfc_constructor_first (expr->value.constructor);
1693 p; p = gfc_constructor_next (p))
1694 if (p->expr->ts.u.cl != NULL)
1696 /* Ensure that if there is a char_len around that it is
1697 used; otherwise the middle-end confuses them! */
1698 expr->ts.u.cl = p->expr->ts.u.cl;
1702 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1709 if (expr->ts.u.cl->length == NULL)
1711 /* Check that all constant string elements have the same length until
1712 we reach the end or find a variable-length one. */
1714 for (p = gfc_constructor_first (expr->value.constructor);
1715 p; p = gfc_constructor_next (p))
1717 int current_length = -1;
1719 for (ref = p->expr->ref; ref; ref = ref->next)
1720 if (ref->type == REF_SUBSTRING
1721 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1722 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1725 if (p->expr->expr_type == EXPR_CONSTANT)
1726 current_length = p->expr->value.character.length;
1730 j = mpz_get_ui (ref->u.ss.end->value.integer)
1731 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1732 current_length = (int) j;
1734 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1735 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1738 j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1739 current_length = (int) j;
1744 gcc_assert (current_length != -1);
1746 if (found_length == -1)
1747 found_length = current_length;
1748 else if (found_length != current_length)
1750 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1751 " constructor at %L", found_length, current_length,
1756 gcc_assert (found_length == current_length);
1759 gcc_assert (found_length != -1);
1761 /* Update the character length of the array constructor. */
1762 expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1763 NULL, found_length);
1767 /* We've got a character length specified. It should be an integer,
1768 otherwise an error is signalled elsewhere. */
1769 gcc_assert (expr->ts.u.cl->length);
1771 /* If we've got a constant character length, pad according to this.
1772 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1773 max_length only if they pass. */
1774 gfc_extract_int (expr->ts.u.cl->length, &found_length);
1776 /* Now pad/truncate the elements accordingly to the specified character
1777 length. This is ok inside this conditional, as in the case above
1778 (without typespec) all elements are verified to have the same length
1780 if (found_length != -1)
1781 for (p = gfc_constructor_first (expr->value.constructor);
1782 p; p = gfc_constructor_next (p))
1783 if (p->expr->expr_type == EXPR_CONSTANT)
1785 gfc_expr *cl = NULL;
1786 int current_length = -1;
1789 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1791 cl = p->expr->ts.u.cl->length;
1792 gfc_extract_int (cl, ¤t_length);
1795 /* If gfc_extract_int above set current_length, we implicitly
1796 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1798 has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1801 || (current_length != -1 && current_length < found_length))
1802 gfc_set_constant_character_len (found_length, p->expr,
1803 has_ts ? -1 : found_length);
1811 /* Resolve all of the expressions in an array list. */
1814 gfc_resolve_array_constructor (gfc_expr *expr)
1818 t = resolve_array_list (expr->value.constructor);
1820 t = gfc_check_constructor_type (expr);
1822 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1823 the call to this function, so we don't need to call it here; if it was
1824 called twice, an error message there would be duplicated. */
1830 /* Copy an iterator structure. */
1833 gfc_copy_iterator (gfc_iterator *src)
1840 dest = gfc_get_iterator ();
1842 dest->var = gfc_copy_expr (src->var);
1843 dest->start = gfc_copy_expr (src->start);
1844 dest->end = gfc_copy_expr (src->end);
1845 dest->step = gfc_copy_expr (src->step);
1851 /********* Subroutines for determining the size of an array *********/
1853 /* These are needed just to accommodate RESHAPE(). There are no
1854 diagnostics here, we just return a negative number if something
1858 /* Get the size of single dimension of an array specification. The
1859 array is guaranteed to be one dimensional. */
1862 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1867 if (dimen < 0 || dimen > as->rank - 1)
1868 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1870 if (as->type != AS_EXPLICIT
1871 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1872 || as->upper[dimen]->expr_type != EXPR_CONSTANT
1873 || as->lower[dimen]->ts.type != BT_INTEGER
1874 || as->upper[dimen]->ts.type != BT_INTEGER)
1879 mpz_sub (*result, as->upper[dimen]->value.integer,
1880 as->lower[dimen]->value.integer);
1882 mpz_add_ui (*result, *result, 1);
1889 spec_size (gfc_array_spec *as, mpz_t *result)
1894 mpz_init_set_ui (*result, 1);
1896 for (d = 0; d < as->rank; d++)
1898 if (spec_dimen_size (as, d, &size) == FAILURE)
1900 mpz_clear (*result);
1904 mpz_mul (*result, *result, size);
1912 /* Get the number of elements in an array section. */
1915 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1917 mpz_t upper, lower, stride;
1920 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1921 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1923 switch (ar->dimen_type[dimen])
1927 mpz_set_ui (*result, 1);
1932 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1941 if (ar->start[dimen] == NULL)
1943 if (ar->as->lower[dimen] == NULL
1944 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1946 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1950 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1952 mpz_set (lower, ar->start[dimen]->value.integer);
1955 if (ar->end[dimen] == NULL)
1957 if (ar->as->upper[dimen] == NULL
1958 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1960 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1964 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1966 mpz_set (upper, ar->end[dimen]->value.integer);
1969 if (ar->stride[dimen] == NULL)
1970 mpz_set_ui (stride, 1);
1973 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1975 mpz_set (stride, ar->stride[dimen]->value.integer);
1979 mpz_sub (*result, upper, lower);
1980 mpz_add (*result, *result, stride);
1981 mpz_div (*result, *result, stride);
1983 /* Zero stride caught earlier. */
1984 if (mpz_cmp_ui (*result, 0) < 0)
1985 mpz_set_ui (*result, 0);
1995 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2003 ref_size (gfc_array_ref *ar, mpz_t *result)
2008 mpz_init_set_ui (*result, 1);
2010 for (d = 0; d < ar->dimen; d++)
2012 if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
2014 mpz_clear (*result);
2018 mpz_mul (*result, *result, size);
2026 /* Given an array expression and a dimension, figure out how many
2027 elements it has along that dimension. Returns SUCCESS if we were
2028 able to return a result in the 'result' variable, FAILURE
2032 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2037 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2038 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2040 switch (array->expr_type)
2044 for (ref = array->ref; ref; ref = ref->next)
2046 if (ref->type != REF_ARRAY)
2049 if (ref->u.ar.type == AR_FULL)
2050 return spec_dimen_size (ref->u.ar.as, dimen, result);
2052 if (ref->u.ar.type == AR_SECTION)
2054 for (i = 0; dimen >= 0; i++)
2055 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2058 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
2062 if (array->shape && array->shape[dimen])
2064 mpz_init_set (*result, array->shape[dimen]);
2068 if (array->symtree->n.sym->attr.generic
2069 && array->value.function.esym != NULL)
2071 if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2075 else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2082 if (array->shape == NULL) {
2083 /* Expressions with rank > 1 should have "shape" properly set */
2084 if ( array->rank != 1 )
2085 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2086 return gfc_array_size(array, result);
2091 if (array->shape == NULL)
2094 mpz_init_set (*result, array->shape[dimen]);
2103 /* Given an array expression, figure out how many elements are in the
2104 array. Returns SUCCESS if this is possible, and sets the 'result'
2105 variable. Otherwise returns FAILURE. */
2108 gfc_array_size (gfc_expr *array, mpz_t *result)
2110 expand_info expand_save;
2115 switch (array->expr_type)
2118 gfc_push_suppress_errors ();
2120 expand_save = current_expand;
2122 current_expand.count = result;
2123 mpz_init_set_ui (*result, 0);
2125 current_expand.expand_work_function = count_elements;
2128 t = expand_constructor (array->value.constructor);
2130 gfc_pop_suppress_errors ();
2133 mpz_clear (*result);
2134 current_expand = expand_save;
2138 for (ref = array->ref; ref; ref = ref->next)
2140 if (ref->type != REF_ARRAY)
2143 if (ref->u.ar.type == AR_FULL)
2144 return spec_size (ref->u.ar.as, result);
2146 if (ref->u.ar.type == AR_SECTION)
2147 return ref_size (&ref->u.ar, result);
2150 return spec_size (array->symtree->n.sym->as, result);
2154 if (array->rank == 0 || array->shape == NULL)
2157 mpz_init_set_ui (*result, 1);
2159 for (i = 0; i < array->rank; i++)
2160 mpz_mul (*result, *result, array->shape[i]);
2169 /* Given an array reference, return the shape of the reference in an
2170 array of mpz_t integers. */
2173 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2183 for (; d < ar->as->rank; d++)
2184 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2190 for (i = 0; i < ar->dimen; i++)
2192 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2194 if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2207 for (d--; d >= 0; d--)
2208 mpz_clear (shape[d]);
2214 /* Given an array expression, find the array reference structure that
2215 characterizes the reference. */
2218 gfc_find_array_ref (gfc_expr *e)
2222 for (ref = e->ref; ref; ref = ref->next)
2223 if (ref->type == REF_ARRAY
2224 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
2225 || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
2229 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2235 /* Find out if an array shape is known at compile time. */
2238 gfc_is_compile_time_shape (gfc_array_spec *as)
2242 if (as->type != AS_EXPLICIT)
2245 for (i = 0; i < as->rank; i++)
2246 if (!gfc_is_constant_expr (as->lower[i])
2247 || !gfc_is_constant_expr (as->upper[i]))