2 Copyright (C) 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
27 /* This parameter is the size of the largest array constructor that we
28 will expand to an array constructor without iterators.
29 Constructors larger than this will remain in the iterator form. */
31 #define GFC_MAX_AC_EXPAND 100
34 /**************** Array reference matching subroutines *****************/
36 /* Copy an array reference structure. */
39 gfc_copy_array_ref (gfc_array_ref * src)
47 dest = gfc_get_array_ref ();
51 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
53 dest->start[i] = gfc_copy_expr (src->start[i]);
54 dest->end[i] = gfc_copy_expr (src->end[i]);
55 dest->stride[i] = gfc_copy_expr (src->stride[i]);
58 dest->offset = gfc_copy_expr (src->offset);
64 /* Match a single dimension of an array reference. This can be a
65 single element or an array section. Any modifications we've made
66 to the ar structure are cleaned up by the caller. If the init
67 is set, we require the subscript to be a valid initialization
71 match_subscript (gfc_array_ref * ar, int init)
78 ar->c_where[i] = gfc_current_locus;
79 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
81 /* We can't be sure of the difference between DIMEN_ELEMENT and
82 DIMEN_VECTOR until we know the type of the element itself at
85 ar->dimen_type[i] = DIMEN_UNKNOWN;
87 if (gfc_match_char (':') == MATCH_YES)
90 /* Get start element. */
92 m = gfc_match_init_expr (&ar->start[i]);
94 m = gfc_match_expr (&ar->start[i]);
97 gfc_error ("Expected array subscript at %C");
101 if (gfc_match_char (':') == MATCH_NO)
104 /* Get an optional end element. Because we've seen the colon, we
105 definitely have a range along this dimension. */
107 ar->dimen_type[i] = DIMEN_RANGE;
110 m = gfc_match_init_expr (&ar->end[i]);
112 m = gfc_match_expr (&ar->end[i]);
114 if (m == MATCH_ERROR)
117 /* See if we have an optional stride. */
118 if (gfc_match_char (':') == MATCH_YES)
120 m = init ? gfc_match_init_expr (&ar->stride[i])
121 : gfc_match_expr (&ar->stride[i]);
124 gfc_error ("Expected array subscript stride at %C");
133 /* Match an array reference, whether it is the whole array or a
134 particular elements or a section. If init is set, the reference has
135 to consist of init expressions. */
138 gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init)
142 memset (ar, '\0', sizeof (ar));
144 ar->where = gfc_current_locus;
147 if (gfc_match_char ('(') != MATCH_YES)
154 ar->type = AR_UNKNOWN;
156 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
158 m = match_subscript (ar, init);
159 if (m == MATCH_ERROR)
162 if (gfc_match_char (')') == MATCH_YES)
165 if (gfc_match_char (',') != MATCH_YES)
167 gfc_error ("Invalid form of array reference at %C");
172 gfc_error ("Array reference at %C cannot have more than "
173 stringize (GFC_MAX_DIMENSIONS) " dimensions");
185 /************** Array specification matching subroutines ***************/
187 /* Free all of the expressions associated with array bounds
191 gfc_free_array_spec (gfc_array_spec * as)
198 for (i = 0; i < as->rank; i++)
200 gfc_free_expr (as->lower[i]);
201 gfc_free_expr (as->upper[i]);
208 /* Take an array bound, resolves the expression, that make up the
209 shape and check associated constraints. */
212 resolve_array_bound (gfc_expr * e, int check_constant)
218 if (gfc_resolve_expr (e) == FAILURE
219 || gfc_specification_expr (e) == FAILURE)
222 if (check_constant && gfc_is_constant_expr (e) == 0)
224 gfc_error ("Variable '%s' at %L in this context must be constant",
225 e->symtree->n.sym->name, &e->where);
233 /* Takes an array specification, resolves the expressions that make up
234 the shape and make sure everything is integral. */
237 gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
245 for (i = 0; i < as->rank; i++)
248 if (resolve_array_bound (e, check_constant) == FAILURE)
252 if (resolve_array_bound (e, check_constant) == FAILURE)
260 /* Match a single array element specification. The return values as
261 well as the upper and lower bounds of the array spec are filled
262 in according to what we see on the input. The caller makes sure
263 individual specifications make sense as a whole.
266 Parsed Lower Upper Returned
267 ------------------------------------
268 : NULL NULL AS_DEFERRED (*)
270 x: x NULL AS_ASSUMED_SHAPE
272 x:* x NULL AS_ASSUMED_SIZE
273 * 1 NULL AS_ASSUMED_SIZE
275 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
276 is fixed during the resolution of formal interfaces.
278 Anything else AS_UNKNOWN. */
281 match_array_element_spec (gfc_array_spec * as)
283 gfc_expr **upper, **lower;
286 lower = &as->lower[as->rank - 1];
287 upper = &as->upper[as->rank - 1];
289 if (gfc_match_char ('*') == MATCH_YES)
291 *lower = gfc_int_expr (1);
292 return AS_ASSUMED_SIZE;
295 if (gfc_match_char (':') == MATCH_YES)
298 m = gfc_match_expr (upper);
300 gfc_error ("Expected expression in array specification at %C");
304 if (gfc_match_char (':') == MATCH_NO)
306 *lower = gfc_int_expr (1);
313 if (gfc_match_char ('*') == MATCH_YES)
314 return AS_ASSUMED_SIZE;
316 m = gfc_match_expr (upper);
317 if (m == MATCH_ERROR)
320 return AS_ASSUMED_SHAPE;
326 /* Matches an array specification, incidentally figuring out what sort
330 gfc_match_array_spec (gfc_array_spec ** asp)
332 array_type current_type;
336 if (gfc_match_char ('(') != MATCH_YES)
342 as = gfc_get_array_spec ();
344 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
354 current_type = match_array_element_spec (as);
358 if (current_type == AS_UNKNOWN)
360 as->type = current_type;
364 { /* See how current spec meshes with the existing */
369 if (current_type == AS_ASSUMED_SIZE)
371 as->type = AS_ASSUMED_SIZE;
375 if (current_type == AS_EXPLICIT)
379 ("Bad array specification for an explicitly shaped array"
384 case AS_ASSUMED_SHAPE:
385 if ((current_type == AS_ASSUMED_SHAPE)
386 || (current_type == AS_DEFERRED))
390 ("Bad array specification for assumed shape array at %C");
394 if (current_type == AS_DEFERRED)
397 if (current_type == AS_ASSUMED_SHAPE)
399 as->type = AS_ASSUMED_SHAPE;
403 gfc_error ("Bad specification for deferred shape array at %C");
406 case AS_ASSUMED_SIZE:
407 gfc_error ("Bad specification for assumed size array at %C");
411 if (gfc_match_char (')') == MATCH_YES)
414 if (gfc_match_char (',') != MATCH_YES)
416 gfc_error ("Expected another dimension in array declaration at %C");
420 if (as->rank >= GFC_MAX_DIMENSIONS)
422 gfc_error ("Array specification at %C has more than "
423 stringize (GFC_MAX_DIMENSIONS) " dimensions");
430 /* If a lower bounds of an assumed shape array is blank, put in one. */
431 if (as->type == AS_ASSUMED_SHAPE)
433 for (i = 0; i < as->rank; i++)
435 if (as->lower[i] == NULL)
436 as->lower[i] = gfc_int_expr (1);
443 /* Something went wrong. */
444 gfc_free_array_spec (as);
449 /* Given a symbol and an array specification, modify the symbol to
450 have that array specification. The error locus is needed in case
451 something goes wrong. On failure, the caller must free the spec. */
454 gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
460 if (gfc_add_dimension (&sym->attr, error_loc) == FAILURE)
469 /* Copy an array specification. */
472 gfc_copy_array_spec (gfc_array_spec * src)
474 gfc_array_spec *dest;
480 dest = gfc_get_array_spec ();
484 for (i = 0; i < dest->rank; i++)
486 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
487 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
493 /* Returns nonzero if the two expressions are equal. Only handles integer
497 compare_bounds (gfc_expr * bound1, gfc_expr * bound2)
499 if (bound1 == NULL || bound2 == NULL
500 || bound1->expr_type != EXPR_CONSTANT
501 || bound2->expr_type != EXPR_CONSTANT
502 || bound1->ts.type != BT_INTEGER
503 || bound2->ts.type != BT_INTEGER)
504 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
506 if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
512 /* Compares two array specifications. They must be constant or deferred
516 gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2)
520 if (as1 == NULL && as2 == NULL)
523 if (as1 == NULL || as2 == NULL)
526 if (as1->rank != as2->rank)
532 if (as1->type != as2->type)
535 if (as1->type == AS_EXPLICIT)
536 for (i = 0; i < as1->rank; i++)
538 if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
541 if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
549 /****************** Array constructor functions ******************/
551 /* Start an array constructor. The constructor starts with zero
552 elements and should be appended to by gfc_append_constructor(). */
555 gfc_start_constructor (bt type, int kind, locus * where)
559 result = gfc_get_expr ();
561 result->expr_type = EXPR_ARRAY;
564 result->ts.type = type;
565 result->ts.kind = kind;
566 result->where = *where;
571 /* Given an array constructor expression, append the new expression
572 node onto the constructor. */
575 gfc_append_constructor (gfc_expr * base, gfc_expr * new)
579 if (base->value.constructor == NULL)
580 base->value.constructor = c = gfc_get_constructor ();
583 c = base->value.constructor;
587 c->next = gfc_get_constructor ();
593 if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind)
594 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
598 /* Given an array constructor expression, insert the new expression's
599 constructor onto the base's one according to the offset. */
602 gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
604 gfc_constructor *c, *pre;
608 type = base->expr_type;
610 if (base->value.constructor == NULL)
611 base->value.constructor = c1;
614 c = pre = base->value.constructor;
617 if (type == EXPR_ARRAY)
619 t = mpz_cmp (c->n.offset, c1->n.offset);
627 gfc_error ("duplicated initializer");
648 base->value.constructor = c1;
654 /* Get a new constructor. */
657 gfc_get_constructor (void)
661 c = gfc_getmem (sizeof(gfc_constructor));
665 mpz_init_set_si (c->n.offset, 0);
666 mpz_init_set_si (c->repeat, 0);
671 /* Free chains of gfc_constructor structures. */
674 gfc_free_constructor (gfc_constructor * p)
676 gfc_constructor *next;
686 gfc_free_expr (p->expr);
687 if (p->iterator != NULL)
688 gfc_free_iterator (p->iterator, 1);
689 mpz_clear (p->n.offset);
690 mpz_clear (p->repeat);
696 /* Given an expression node that might be an array constructor and a
697 symbol, make sure that no iterators in this or child constructors
698 use the symbol as an implied-DO iterator. Returns nonzero if a
699 duplicate was found. */
702 check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
706 for (; c; c = c->next)
710 if (e->expr_type == EXPR_ARRAY
711 && check_duplicate_iterator (e->value.constructor, master))
714 if (c->iterator == NULL)
717 if (c->iterator->var->symtree->n.sym == master)
720 ("DO-iterator '%s' at %L is inside iterator of the same name",
721 master->name, &c->where);
731 /* Forward declaration because these functions are mutually recursive. */
732 static match match_array_cons_element (gfc_constructor **);
734 /* Match a list of array elements. */
737 match_array_list (gfc_constructor ** result)
739 gfc_constructor *p, *head, *tail, *new;
746 old_loc = gfc_current_locus;
748 if (gfc_match_char ('(') == MATCH_NO)
751 memset (&iter, '\0', sizeof (gfc_iterator));
754 m = match_array_cons_element (&head);
760 if (gfc_match_char (',') != MATCH_YES)
768 m = gfc_match_iterator (&iter, 0);
771 if (m == MATCH_ERROR)
774 m = match_array_cons_element (&new);
775 if (m == MATCH_ERROR)
782 goto cleanup; /* Could be a complex constant */
788 if (gfc_match_char (',') != MATCH_YES)
797 if (gfc_match_char (')') != MATCH_YES)
800 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
807 e->expr_type = EXPR_ARRAY;
809 e->value.constructor = head;
811 p = gfc_get_constructor ();
812 p->where = gfc_current_locus;
813 p->iterator = gfc_get_iterator ();
822 gfc_error ("Syntax error in array constructor at %C");
826 gfc_free_constructor (head);
827 gfc_free_iterator (&iter, 0);
828 gfc_current_locus = old_loc;
833 /* Match a single element of an array constructor, which can be a
834 single expression or a list of elements. */
837 match_array_cons_element (gfc_constructor ** result)
843 m = match_array_list (result);
847 m = gfc_match_expr (&expr);
851 p = gfc_get_constructor ();
852 p->where = gfc_current_locus;
860 /* Match an array constructor. */
863 gfc_match_array_constructor (gfc_expr ** result)
865 gfc_constructor *head, *tail, *new;
870 if (gfc_match (" (/") == MATCH_NO)
873 where = gfc_current_locus;
876 if (gfc_match (" /)") == MATCH_YES)
877 goto empty; /* Special case */
881 m = match_array_cons_element (&new);
882 if (m == MATCH_ERROR)
894 if (gfc_match_char (',') == MATCH_NO)
898 if (gfc_match (" /)") == MATCH_NO)
902 expr = gfc_get_expr ();
904 expr->expr_type = EXPR_ARRAY;
906 expr->value.constructor = head;
907 /* Size must be calculated at resolution time. */
916 gfc_error ("Syntax error in array constructor at %C");
919 gfc_free_constructor (head);
925 /************** Check array constructors for correctness **************/
927 /* Given an expression, compare it's type with the type of the current
928 constructor. Returns nonzero if an error was issued. The
929 cons_state variable keeps track of whether the type of the
930 constructor being read or resolved is known to be good, bad or just
933 static gfc_typespec constructor_ts;
935 { CONS_START, CONS_GOOD, CONS_BAD }
939 check_element_type (gfc_expr * expr)
942 if (cons_state == CONS_BAD)
943 return 0; /* Suppress further errors */
945 if (cons_state == CONS_START)
947 if (expr->ts.type == BT_UNKNOWN)
948 cons_state = CONS_BAD;
951 cons_state = CONS_GOOD;
952 constructor_ts = expr->ts;
958 if (gfc_compare_types (&constructor_ts, &expr->ts))
961 gfc_error ("Element in %s array constructor at %L is %s",
962 gfc_typename (&constructor_ts), &expr->where,
963 gfc_typename (&expr->ts));
965 cons_state = CONS_BAD;
970 /* Recursive work function for gfc_check_constructor_type(). */
973 check_constructor_type (gfc_constructor * c)
977 for (; c; c = c->next)
981 if (e->expr_type == EXPR_ARRAY)
983 if (check_constructor_type (e->value.constructor) == FAILURE)
989 if (check_element_type (e))
997 /* Check that all elements of an array constructor are the same type.
998 On FAILURE, an error has been generated. */
1001 gfc_check_constructor_type (gfc_expr * e)
1005 cons_state = CONS_START;
1006 gfc_clear_ts (&constructor_ts);
1008 t = check_constructor_type (e->value.constructor);
1009 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1010 e->ts = constructor_ts;
1017 typedef struct cons_stack
1019 gfc_iterator *iterator;
1020 struct cons_stack *previous;
1024 static cons_stack *base;
1026 static try check_constructor (gfc_constructor *, try (*)(gfc_expr *));
1028 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1029 that that variable is an iteration variables. */
1032 gfc_check_iter_variable (gfc_expr * expr)
1038 sym = expr->symtree->n.sym;
1040 for (c = base; c; c = c->previous)
1041 if (sym == c->iterator->var->symtree->n.sym)
1048 /* Recursive work function for gfc_check_constructor(). This amounts
1049 to calling the check function for each expression in the
1050 constructor, giving variables with the names of iterators a pass. */
1053 check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
1059 for (; c; c = c->next)
1063 if (e->expr_type != EXPR_ARRAY)
1065 if ((*check_function) (e) == FAILURE)
1070 element.previous = base;
1071 element.iterator = c->iterator;
1074 t = check_constructor (e->value.constructor, check_function);
1075 base = element.previous;
1081 /* Nothing went wrong, so all OK. */
1086 /* Checks a constructor to see if it is a particular kind of
1087 expression -- specification, restricted, or initialization as
1088 determined by the check_function. */
1091 gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *))
1093 cons_stack *base_save;
1099 t = check_constructor (expr->value.constructor, check_function);
1107 /**************** Simplification of array constructors ****************/
1109 iterator_stack *iter_stack;
1113 gfc_constructor *new_head, *new_tail;
1114 int extract_count, extract_n;
1115 gfc_expr *extracted;
1119 gfc_component *component;
1122 try (*expand_work_function) (gfc_expr *);
1126 static expand_info current_expand;
1128 static try expand_constructor (gfc_constructor *);
1131 /* Work function that counts the number of elements present in a
1135 count_elements (gfc_expr * e)
1140 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1143 if (gfc_array_size (e, &result) == FAILURE)
1149 mpz_add (*current_expand.count, *current_expand.count, result);
1158 /* Work function that extracts a particular element from an array
1159 constructor, freeing the rest. */
1162 extract_element (gfc_expr * e)
1166 { /* Something unextractable */
1171 if (current_expand.extract_count == current_expand.extract_n)
1172 current_expand.extracted = e;
1176 current_expand.extract_count++;
1181 /* Work function that constructs a new constructor out of the old one,
1182 stringing new elements together. */
1185 expand (gfc_expr * e)
1188 if (current_expand.new_head == NULL)
1189 current_expand.new_head = current_expand.new_tail =
1190 gfc_get_constructor ();
1193 current_expand.new_tail->next = gfc_get_constructor ();
1194 current_expand.new_tail = current_expand.new_tail->next;
1197 current_expand.new_tail->where = e->where;
1198 current_expand.new_tail->expr = e;
1200 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1201 current_expand.new_tail->n.component = current_expand.component;
1202 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1207 /* Given an initialization expression that is a variable reference,
1208 substitute the current value of the iteration variable. */
1211 gfc_simplify_iterator_var (gfc_expr * e)
1215 for (p = iter_stack; p; p = p->prev)
1216 if (e->symtree == p->variable)
1220 return; /* Variable not found */
1222 gfc_replace_expr (e, gfc_int_expr (0));
1224 mpz_set (e->value.integer, p->value);
1230 /* Expand an expression with that is inside of a constructor,
1231 recursing into other constructors if present. */
1234 expand_expr (gfc_expr * e)
1237 if (e->expr_type == EXPR_ARRAY)
1238 return expand_constructor (e->value.constructor);
1240 e = gfc_copy_expr (e);
1242 if (gfc_simplify_expr (e, 1) == FAILURE)
1248 return current_expand.expand_work_function (e);
1253 expand_iterator (gfc_constructor * c)
1255 gfc_expr *start, *end, *step;
1256 iterator_stack frame;
1265 mpz_init (frame.value);
1267 start = gfc_copy_expr (c->iterator->start);
1268 if (gfc_simplify_expr (start, 1) == FAILURE)
1271 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1274 end = gfc_copy_expr (c->iterator->end);
1275 if (gfc_simplify_expr (end, 1) == FAILURE)
1278 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1281 step = gfc_copy_expr (c->iterator->step);
1282 if (gfc_simplify_expr (step, 1) == FAILURE)
1285 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1288 if (mpz_sgn (step->value.integer) == 0)
1290 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1294 /* Calculate the trip count of the loop. */
1295 mpz_sub (trip, end->value.integer, start->value.integer);
1296 mpz_add (trip, trip, step->value.integer);
1297 mpz_tdiv_q (trip, trip, step->value.integer);
1299 mpz_set (frame.value, start->value.integer);
1301 frame.prev = iter_stack;
1302 frame.variable = c->iterator->var->symtree;
1303 iter_stack = &frame;
1305 while (mpz_sgn (trip) > 0)
1307 if (expand_expr (c->expr) == FAILURE)
1310 mpz_add (frame.value, frame.value, step->value.integer);
1311 mpz_sub_ui (trip, trip, 1);
1317 gfc_free_expr (start);
1318 gfc_free_expr (end);
1319 gfc_free_expr (step);
1322 mpz_clear (frame.value);
1324 iter_stack = frame.prev;
1330 /* Expand a constructor into constant constructors without any
1331 iterators, calling the work function for each of the expanded
1332 expressions. The work function needs to either save or free the
1333 passed expression. */
1336 expand_constructor (gfc_constructor * c)
1340 for (; c; c = c->next)
1342 if (c->iterator != NULL)
1344 if (expand_iterator (c) == FAILURE)
1351 if (e->expr_type == EXPR_ARRAY)
1353 if (expand_constructor (e->value.constructor) == FAILURE)
1359 e = gfc_copy_expr (e);
1360 if (gfc_simplify_expr (e, 1) == FAILURE)
1365 current_expand.offset = &c->n.offset;
1366 current_expand.component = c->n.component;
1367 current_expand.repeat = &c->repeat;
1368 if (current_expand.expand_work_function (e) == FAILURE)
1375 /* Top level subroutine for expanding constructors. We only expand
1376 constructor if they are small enough. */
1379 gfc_expand_constructor (gfc_expr * e)
1381 expand_info expand_save;
1385 f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1392 expand_save = current_expand;
1393 current_expand.new_head = current_expand.new_tail = NULL;
1397 current_expand.expand_work_function = expand;
1399 if (expand_constructor (e->value.constructor) == FAILURE)
1401 gfc_free_constructor (current_expand.new_head);
1406 gfc_free_constructor (e->value.constructor);
1407 e->value.constructor = current_expand.new_head;
1412 current_expand = expand_save;
1418 /* Work function for checking that an element of a constructor is a
1419 constant, after removal of any iteration variables. We return
1420 FAILURE if not so. */
1423 constant_element (gfc_expr * e)
1427 rv = gfc_is_constant_expr (e);
1430 return rv ? SUCCESS : FAILURE;
1434 /* Given an array constructor, determine if the constructor is
1435 constant or not by expanding it and making sure that all elements
1436 are constants. This is a bit of a hack since something like (/ (i,
1437 i=1,100000000) /) will take a while as* opposed to a more clever
1438 function that traverses the expression tree. FIXME. */
1441 gfc_constant_ac (gfc_expr * e)
1443 expand_info expand_save;
1447 expand_save = current_expand;
1448 current_expand.expand_work_function = constant_element;
1450 rc = expand_constructor (e->value.constructor);
1452 current_expand = expand_save;
1460 /* Returns nonzero if an array constructor has been completely
1461 expanded (no iterators) and zero if iterators are present. */
1464 gfc_expanded_ac (gfc_expr * e)
1468 if (e->expr_type == EXPR_ARRAY)
1469 for (p = e->value.constructor; p; p = p->next)
1470 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1477 /*************** Type resolution of array constructors ***************/
1479 /* Recursive array list resolution function. All of the elements must
1480 be of the same type. */
1483 resolve_array_list (gfc_constructor * p)
1489 for (; p; p = p->next)
1491 if (p->iterator != NULL
1492 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1495 if (gfc_resolve_expr (p->expr) == FAILURE)
1503 /* Resolve all of the expressions in an array list.
1504 TODO: String lengths. */
1507 gfc_resolve_array_constructor (gfc_expr * expr)
1511 t = resolve_array_list (expr->value.constructor);
1513 t = gfc_check_constructor_type (expr);
1519 /* Copy an iterator structure. */
1521 static gfc_iterator *
1522 copy_iterator (gfc_iterator * src)
1529 dest = gfc_get_iterator ();
1531 dest->var = gfc_copy_expr (src->var);
1532 dest->start = gfc_copy_expr (src->start);
1533 dest->end = gfc_copy_expr (src->end);
1534 dest->step = gfc_copy_expr (src->step);
1540 /* Copy a constructor structure. */
1543 gfc_copy_constructor (gfc_constructor * src)
1545 gfc_constructor *dest;
1546 gfc_constructor *tail;
1555 dest = tail = gfc_get_constructor ();
1558 tail->next = gfc_get_constructor ();
1561 tail->where = src->where;
1562 tail->expr = gfc_copy_expr (src->expr);
1563 tail->iterator = copy_iterator (src->iterator);
1564 mpz_set (tail->n.offset, src->n.offset);
1565 tail->n.component = src->n.component;
1566 mpz_set (tail->repeat, src->repeat);
1574 /* Given an array expression and an element number (starting at zero),
1575 return a pointer to the array element. NULL is returned if the
1576 size of the array has been exceeded. The expression node returned
1577 remains a part of the array and should not be freed. Access is not
1578 efficient at all, but this is another place where things do not
1579 have to be particularly fast. */
1582 gfc_get_array_element (gfc_expr * array, int element)
1584 expand_info expand_save;
1588 expand_save = current_expand;
1589 current_expand.extract_n = element;
1590 current_expand.expand_work_function = extract_element;
1591 current_expand.extracted = NULL;
1592 current_expand.extract_count = 0;
1596 rc = expand_constructor (array->value.constructor);
1597 e = current_expand.extracted;
1598 current_expand = expand_save;
1607 /********* Subroutines for determining the size of an array *********/
1609 /* These are needed just to accommodate RESHAPE(). There are no
1610 diagnostics here, we just return a negative number if something
1614 /* Get the size of single dimension of an array specification. The
1615 array is guaranteed to be one dimensional. */
1618 spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
1624 if (dimen < 0 || dimen > as->rank - 1)
1625 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1627 if (as->type != AS_EXPLICIT
1628 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1629 || as->upper[dimen]->expr_type != EXPR_CONSTANT)
1634 mpz_sub (*result, as->upper[dimen]->value.integer,
1635 as->lower[dimen]->value.integer);
1637 mpz_add_ui (*result, *result, 1);
1644 spec_size (gfc_array_spec * as, mpz_t * result)
1649 mpz_init_set_ui (*result, 1);
1651 for (d = 0; d < as->rank; d++)
1653 if (spec_dimen_size (as, d, &size) == FAILURE)
1655 mpz_clear (*result);
1659 mpz_mul (*result, *result, size);
1667 /* Get the number of elements in an array section. */
1670 ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
1672 mpz_t upper, lower, stride;
1675 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1676 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1678 switch (ar->dimen_type[dimen])
1682 mpz_set_ui (*result, 1);
1687 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1696 if (ar->start[dimen] == NULL)
1698 if (ar->as->lower[dimen] == NULL
1699 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1701 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1705 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1707 mpz_set (lower, ar->start[dimen]->value.integer);
1710 if (ar->end[dimen] == NULL)
1712 if (ar->as->upper[dimen] == NULL
1713 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1715 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1719 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1721 mpz_set (upper, ar->end[dimen]->value.integer);
1724 if (ar->stride[dimen] == NULL)
1725 mpz_set_ui (stride, 1);
1728 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1730 mpz_set (stride, ar->stride[dimen]->value.integer);
1734 mpz_sub (*result, upper, lower);
1735 mpz_add (*result, *result, stride);
1736 mpz_div (*result, *result, stride);
1738 /* Zero stride caught earlier. */
1739 if (mpz_cmp_ui (*result, 0) < 0)
1740 mpz_set_ui (*result, 0);
1750 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1758 ref_size (gfc_array_ref * ar, mpz_t * result)
1763 mpz_init_set_ui (*result, 1);
1765 for (d = 0; d < ar->dimen; d++)
1767 if (ref_dimen_size (ar, d, &size) == FAILURE)
1769 mpz_clear (*result);
1773 mpz_mul (*result, *result, size);
1781 /* Given an array expression and a dimension, figure out how many
1782 elements it has along that dimension. Returns SUCCESS if we were
1783 able to return a result in the 'result' variable, FAILURE
1787 gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
1792 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1793 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1795 switch (array->expr_type)
1799 for (ref = array->ref; ref; ref = ref->next)
1801 if (ref->type != REF_ARRAY)
1804 if (ref->u.ar.type == AR_FULL)
1805 return spec_dimen_size (ref->u.ar.as, dimen, result);
1807 if (ref->u.ar.type == AR_SECTION)
1809 for (i = 0; dimen >= 0; i++)
1810 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1813 return ref_dimen_size (&ref->u.ar, i - 1, result);
1817 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
1823 if (array->shape == NULL) {
1824 /* Expressions with rank > 1 should have "shape" properly set */
1825 if ( array->rank != 1 )
1826 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1827 return gfc_array_size(array, result);
1832 if (array->shape == NULL)
1835 mpz_init_set (*result, array->shape[dimen]);
1844 /* Given an array expression, figure out how many elements are in the
1845 array. Returns SUCCESS if this is possible, and sets the 'result'
1846 variable. Otherwise returns FAILURE. */
1849 gfc_array_size (gfc_expr * array, mpz_t * result)
1851 expand_info expand_save;
1856 switch (array->expr_type)
1859 flag = gfc_suppress_error;
1860 gfc_suppress_error = 1;
1862 expand_save = current_expand;
1864 current_expand.count = result;
1865 mpz_init_set_ui (*result, 0);
1867 current_expand.expand_work_function = count_elements;
1870 t = expand_constructor (array->value.constructor);
1871 gfc_suppress_error = flag;
1874 mpz_clear (*result);
1875 current_expand = expand_save;
1879 for (ref = array->ref; ref; ref = ref->next)
1881 if (ref->type != REF_ARRAY)
1884 if (ref->u.ar.type == AR_FULL)
1885 return spec_size (ref->u.ar.as, result);
1887 if (ref->u.ar.type == AR_SECTION)
1888 return ref_size (&ref->u.ar, result);
1891 return spec_size (array->symtree->n.sym->as, result);
1895 if (array->rank == 0 || array->shape == NULL)
1898 mpz_init_set_ui (*result, 1);
1900 for (i = 0; i < array->rank; i++)
1901 mpz_mul (*result, *result, array->shape[i]);
1910 /* Given an array reference, return the shape of the reference in an
1911 array of mpz_t integers. */
1914 gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape)
1924 for (; d < ar->as->rank; d++)
1925 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
1931 for (i = 0; i < ar->dimen; i++)
1933 if (ar->dimen_type[i] != DIMEN_ELEMENT)
1935 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
1948 for (d--; d >= 0; d--)
1949 mpz_clear (shape[d]);
1955 /* Given an array expression, find the array reference structure that
1956 characterizes the reference. */
1959 gfc_find_array_ref (gfc_expr * e)
1963 for (ref = e->ref; ref; ref = ref->next)
1964 if (ref->type == REF_ARRAY
1965 && (ref->u.ar.type == AR_FULL
1966 || ref->u.ar.type == AR_SECTION))
1970 gfc_internal_error ("gfc_find_array_ref(): No ref found");
1976 /* Find out if an array shape is known at compile time. */
1979 gfc_is_compile_time_shape (gfc_array_spec *as)
1983 if (as->type != AS_EXPLICIT)
1986 for (i = 0; i < as->rank; i++)
1987 if (!gfc_is_constant_expr (as->lower[i])
1988 || !gfc_is_constant_expr (as->upper[i]))