2 Copyright (C) 2000, 2001, 2002, 2004, 2005 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, 51 Franklin Street, Fifth Floor, 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, sym->name, 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;
869 const char *end_delim;
871 if (gfc_match (" (/") == MATCH_NO)
873 if (gfc_match (" [") == MATCH_NO)
877 if (gfc_notify_std (GFC_STD_F2003, "New in Fortran 2003: [...] "
878 "style array constructors at %C") == FAILURE)
886 where = gfc_current_locus;
889 if (gfc_match (end_delim) == MATCH_YES)
891 gfc_error ("Empty array constructor at %C is not allowed");
897 m = match_array_cons_element (&new);
898 if (m == MATCH_ERROR)
910 if (gfc_match_char (',') == MATCH_NO)
914 if (gfc_match (end_delim) == MATCH_NO)
917 expr = gfc_get_expr ();
919 expr->expr_type = EXPR_ARRAY;
921 expr->value.constructor = head;
922 /* Size must be calculated at resolution time. */
931 gfc_error ("Syntax error in array constructor at %C");
934 gfc_free_constructor (head);
940 /************** Check array constructors for correctness **************/
942 /* Given an expression, compare it's type with the type of the current
943 constructor. Returns nonzero if an error was issued. The
944 cons_state variable keeps track of whether the type of the
945 constructor being read or resolved is known to be good, bad or just
948 static gfc_typespec constructor_ts;
950 { CONS_START, CONS_GOOD, CONS_BAD }
954 check_element_type (gfc_expr * expr)
957 if (cons_state == CONS_BAD)
958 return 0; /* Suppress further errors */
960 if (cons_state == CONS_START)
962 if (expr->ts.type == BT_UNKNOWN)
963 cons_state = CONS_BAD;
966 cons_state = CONS_GOOD;
967 constructor_ts = expr->ts;
973 if (gfc_compare_types (&constructor_ts, &expr->ts))
976 gfc_error ("Element in %s array constructor at %L is %s",
977 gfc_typename (&constructor_ts), &expr->where,
978 gfc_typename (&expr->ts));
980 cons_state = CONS_BAD;
985 /* Recursive work function for gfc_check_constructor_type(). */
988 check_constructor_type (gfc_constructor * c)
992 for (; c; c = c->next)
996 if (e->expr_type == EXPR_ARRAY)
998 if (check_constructor_type (e->value.constructor) == FAILURE)
1004 if (check_element_type (e))
1012 /* Check that all elements of an array constructor are the same type.
1013 On FAILURE, an error has been generated. */
1016 gfc_check_constructor_type (gfc_expr * e)
1020 cons_state = CONS_START;
1021 gfc_clear_ts (&constructor_ts);
1023 t = check_constructor_type (e->value.constructor);
1024 if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1025 e->ts = constructor_ts;
1032 typedef struct cons_stack
1034 gfc_iterator *iterator;
1035 struct cons_stack *previous;
1039 static cons_stack *base;
1041 static try check_constructor (gfc_constructor *, try (*)(gfc_expr *));
1043 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1044 that that variable is an iteration variables. */
1047 gfc_check_iter_variable (gfc_expr * expr)
1053 sym = expr->symtree->n.sym;
1055 for (c = base; c; c = c->previous)
1056 if (sym == c->iterator->var->symtree->n.sym)
1063 /* Recursive work function for gfc_check_constructor(). This amounts
1064 to calling the check function for each expression in the
1065 constructor, giving variables with the names of iterators a pass. */
1068 check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
1074 for (; c; c = c->next)
1078 if (e->expr_type != EXPR_ARRAY)
1080 if ((*check_function) (e) == FAILURE)
1085 element.previous = base;
1086 element.iterator = c->iterator;
1089 t = check_constructor (e->value.constructor, check_function);
1090 base = element.previous;
1096 /* Nothing went wrong, so all OK. */
1101 /* Checks a constructor to see if it is a particular kind of
1102 expression -- specification, restricted, or initialization as
1103 determined by the check_function. */
1106 gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *))
1108 cons_stack *base_save;
1114 t = check_constructor (expr->value.constructor, check_function);
1122 /**************** Simplification of array constructors ****************/
1124 iterator_stack *iter_stack;
1128 gfc_constructor *new_head, *new_tail;
1129 int extract_count, extract_n;
1130 gfc_expr *extracted;
1134 gfc_component *component;
1137 try (*expand_work_function) (gfc_expr *);
1141 static expand_info current_expand;
1143 static try expand_constructor (gfc_constructor *);
1146 /* Work function that counts the number of elements present in a
1150 count_elements (gfc_expr * e)
1155 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1158 if (gfc_array_size (e, &result) == FAILURE)
1164 mpz_add (*current_expand.count, *current_expand.count, result);
1173 /* Work function that extracts a particular element from an array
1174 constructor, freeing the rest. */
1177 extract_element (gfc_expr * e)
1181 { /* Something unextractable */
1186 if (current_expand.extract_count == current_expand.extract_n)
1187 current_expand.extracted = e;
1191 current_expand.extract_count++;
1196 /* Work function that constructs a new constructor out of the old one,
1197 stringing new elements together. */
1200 expand (gfc_expr * e)
1203 if (current_expand.new_head == NULL)
1204 current_expand.new_head = current_expand.new_tail =
1205 gfc_get_constructor ();
1208 current_expand.new_tail->next = gfc_get_constructor ();
1209 current_expand.new_tail = current_expand.new_tail->next;
1212 current_expand.new_tail->where = e->where;
1213 current_expand.new_tail->expr = e;
1215 mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1216 current_expand.new_tail->n.component = current_expand.component;
1217 mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1222 /* Given an initialization expression that is a variable reference,
1223 substitute the current value of the iteration variable. */
1226 gfc_simplify_iterator_var (gfc_expr * e)
1230 for (p = iter_stack; p; p = p->prev)
1231 if (e->symtree == p->variable)
1235 return; /* Variable not found */
1237 gfc_replace_expr (e, gfc_int_expr (0));
1239 mpz_set (e->value.integer, p->value);
1245 /* Expand an expression with that is inside of a constructor,
1246 recursing into other constructors if present. */
1249 expand_expr (gfc_expr * e)
1252 if (e->expr_type == EXPR_ARRAY)
1253 return expand_constructor (e->value.constructor);
1255 e = gfc_copy_expr (e);
1257 if (gfc_simplify_expr (e, 1) == FAILURE)
1263 return current_expand.expand_work_function (e);
1268 expand_iterator (gfc_constructor * c)
1270 gfc_expr *start, *end, *step;
1271 iterator_stack frame;
1280 mpz_init (frame.value);
1282 start = gfc_copy_expr (c->iterator->start);
1283 if (gfc_simplify_expr (start, 1) == FAILURE)
1286 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1289 end = gfc_copy_expr (c->iterator->end);
1290 if (gfc_simplify_expr (end, 1) == FAILURE)
1293 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1296 step = gfc_copy_expr (c->iterator->step);
1297 if (gfc_simplify_expr (step, 1) == FAILURE)
1300 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1303 if (mpz_sgn (step->value.integer) == 0)
1305 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1309 /* Calculate the trip count of the loop. */
1310 mpz_sub (trip, end->value.integer, start->value.integer);
1311 mpz_add (trip, trip, step->value.integer);
1312 mpz_tdiv_q (trip, trip, step->value.integer);
1314 mpz_set (frame.value, start->value.integer);
1316 frame.prev = iter_stack;
1317 frame.variable = c->iterator->var->symtree;
1318 iter_stack = &frame;
1320 while (mpz_sgn (trip) > 0)
1322 if (expand_expr (c->expr) == FAILURE)
1325 mpz_add (frame.value, frame.value, step->value.integer);
1326 mpz_sub_ui (trip, trip, 1);
1332 gfc_free_expr (start);
1333 gfc_free_expr (end);
1334 gfc_free_expr (step);
1337 mpz_clear (frame.value);
1339 iter_stack = frame.prev;
1345 /* Expand a constructor into constant constructors without any
1346 iterators, calling the work function for each of the expanded
1347 expressions. The work function needs to either save or free the
1348 passed expression. */
1351 expand_constructor (gfc_constructor * c)
1355 for (; c; c = c->next)
1357 if (c->iterator != NULL)
1359 if (expand_iterator (c) == FAILURE)
1366 if (e->expr_type == EXPR_ARRAY)
1368 if (expand_constructor (e->value.constructor) == FAILURE)
1374 e = gfc_copy_expr (e);
1375 if (gfc_simplify_expr (e, 1) == FAILURE)
1380 current_expand.offset = &c->n.offset;
1381 current_expand.component = c->n.component;
1382 current_expand.repeat = &c->repeat;
1383 if (current_expand.expand_work_function (e) == FAILURE)
1390 /* Top level subroutine for expanding constructors. We only expand
1391 constructor if they are small enough. */
1394 gfc_expand_constructor (gfc_expr * e)
1396 expand_info expand_save;
1400 f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1407 expand_save = current_expand;
1408 current_expand.new_head = current_expand.new_tail = NULL;
1412 current_expand.expand_work_function = expand;
1414 if (expand_constructor (e->value.constructor) == FAILURE)
1416 gfc_free_constructor (current_expand.new_head);
1421 gfc_free_constructor (e->value.constructor);
1422 e->value.constructor = current_expand.new_head;
1427 current_expand = expand_save;
1433 /* Work function for checking that an element of a constructor is a
1434 constant, after removal of any iteration variables. We return
1435 FAILURE if not so. */
1438 constant_element (gfc_expr * e)
1442 rv = gfc_is_constant_expr (e);
1445 return rv ? SUCCESS : FAILURE;
1449 /* Given an array constructor, determine if the constructor is
1450 constant or not by expanding it and making sure that all elements
1451 are constants. This is a bit of a hack since something like (/ (i,
1452 i=1,100000000) /) will take a while as* opposed to a more clever
1453 function that traverses the expression tree. FIXME. */
1456 gfc_constant_ac (gfc_expr * e)
1458 expand_info expand_save;
1462 expand_save = current_expand;
1463 current_expand.expand_work_function = constant_element;
1465 rc = expand_constructor (e->value.constructor);
1467 current_expand = expand_save;
1475 /* Returns nonzero if an array constructor has been completely
1476 expanded (no iterators) and zero if iterators are present. */
1479 gfc_expanded_ac (gfc_expr * e)
1483 if (e->expr_type == EXPR_ARRAY)
1484 for (p = e->value.constructor; p; p = p->next)
1485 if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1492 /*************** Type resolution of array constructors ***************/
1494 /* Recursive array list resolution function. All of the elements must
1495 be of the same type. */
1498 resolve_array_list (gfc_constructor * p)
1504 for (; p; p = p->next)
1506 if (p->iterator != NULL
1507 && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1510 if (gfc_resolve_expr (p->expr) == FAILURE)
1517 /* Resolve character array constructor. If it is a constant character array and
1518 not specified character length, update character length to the maximum of
1519 its element constructors' length. */
1522 resolve_character_array_constructor (gfc_expr * expr)
1524 gfc_constructor * p;
1527 gcc_assert (expr->expr_type == EXPR_ARRAY);
1528 gcc_assert (expr->ts.type == BT_CHARACTER);
1532 if (expr->ts.cl == NULL || expr->ts.cl->length == NULL)
1534 /* Find the maximum length of the elements. Do nothing for variable array
1536 for (p = expr->value.constructor; p; p = p->next)
1537 if (p->expr->expr_type == EXPR_CONSTANT)
1538 max_length = MAX (p->expr->value.character.length, max_length);
1542 if (max_length != -1)
1544 /* Update the character length of the array constructor. */
1545 if (expr->ts.cl == NULL)
1546 expr->ts.cl = gfc_get_charlen ();
1547 expr->ts.cl->length = gfc_int_expr (max_length);
1548 /* Update the element constructors. */
1549 for (p = expr->value.constructor; p; p = p->next)
1550 gfc_set_constant_character_len (max_length, p->expr);
1555 /* Resolve all of the expressions in an array list. */
1558 gfc_resolve_array_constructor (gfc_expr * expr)
1562 t = resolve_array_list (expr->value.constructor);
1564 t = gfc_check_constructor_type (expr);
1565 if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
1566 resolve_character_array_constructor (expr);
1572 /* Copy an iterator structure. */
1574 static gfc_iterator *
1575 copy_iterator (gfc_iterator * src)
1582 dest = gfc_get_iterator ();
1584 dest->var = gfc_copy_expr (src->var);
1585 dest->start = gfc_copy_expr (src->start);
1586 dest->end = gfc_copy_expr (src->end);
1587 dest->step = gfc_copy_expr (src->step);
1593 /* Copy a constructor structure. */
1596 gfc_copy_constructor (gfc_constructor * src)
1598 gfc_constructor *dest;
1599 gfc_constructor *tail;
1608 dest = tail = gfc_get_constructor ();
1611 tail->next = gfc_get_constructor ();
1614 tail->where = src->where;
1615 tail->expr = gfc_copy_expr (src->expr);
1616 tail->iterator = copy_iterator (src->iterator);
1617 mpz_set (tail->n.offset, src->n.offset);
1618 tail->n.component = src->n.component;
1619 mpz_set (tail->repeat, src->repeat);
1627 /* Given an array expression and an element number (starting at zero),
1628 return a pointer to the array element. NULL is returned if the
1629 size of the array has been exceeded. The expression node returned
1630 remains a part of the array and should not be freed. Access is not
1631 efficient at all, but this is another place where things do not
1632 have to be particularly fast. */
1635 gfc_get_array_element (gfc_expr * array, int element)
1637 expand_info expand_save;
1641 expand_save = current_expand;
1642 current_expand.extract_n = element;
1643 current_expand.expand_work_function = extract_element;
1644 current_expand.extracted = NULL;
1645 current_expand.extract_count = 0;
1649 rc = expand_constructor (array->value.constructor);
1650 e = current_expand.extracted;
1651 current_expand = expand_save;
1660 /********* Subroutines for determining the size of an array *********/
1662 /* These are needed just to accommodate RESHAPE(). There are no
1663 diagnostics here, we just return a negative number if something
1667 /* Get the size of single dimension of an array specification. The
1668 array is guaranteed to be one dimensional. */
1671 spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
1677 if (dimen < 0 || dimen > as->rank - 1)
1678 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1680 if (as->type != AS_EXPLICIT
1681 || as->lower[dimen]->expr_type != EXPR_CONSTANT
1682 || as->upper[dimen]->expr_type != EXPR_CONSTANT)
1687 mpz_sub (*result, as->upper[dimen]->value.integer,
1688 as->lower[dimen]->value.integer);
1690 mpz_add_ui (*result, *result, 1);
1697 spec_size (gfc_array_spec * as, mpz_t * result)
1702 mpz_init_set_ui (*result, 1);
1704 for (d = 0; d < as->rank; d++)
1706 if (spec_dimen_size (as, d, &size) == FAILURE)
1708 mpz_clear (*result);
1712 mpz_mul (*result, *result, size);
1720 /* Get the number of elements in an array section. */
1723 ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
1725 mpz_t upper, lower, stride;
1728 if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1729 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1731 switch (ar->dimen_type[dimen])
1735 mpz_set_ui (*result, 1);
1740 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
1749 if (ar->start[dimen] == NULL)
1751 if (ar->as->lower[dimen] == NULL
1752 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1754 mpz_set (lower, ar->as->lower[dimen]->value.integer);
1758 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1760 mpz_set (lower, ar->start[dimen]->value.integer);
1763 if (ar->end[dimen] == NULL)
1765 if (ar->as->upper[dimen] == NULL
1766 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1768 mpz_set (upper, ar->as->upper[dimen]->value.integer);
1772 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1774 mpz_set (upper, ar->end[dimen]->value.integer);
1777 if (ar->stride[dimen] == NULL)
1778 mpz_set_ui (stride, 1);
1781 if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1783 mpz_set (stride, ar->stride[dimen]->value.integer);
1787 mpz_sub (*result, upper, lower);
1788 mpz_add (*result, *result, stride);
1789 mpz_div (*result, *result, stride);
1791 /* Zero stride caught earlier. */
1792 if (mpz_cmp_ui (*result, 0) < 0)
1793 mpz_set_ui (*result, 0);
1803 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1811 ref_size (gfc_array_ref * ar, mpz_t * result)
1816 mpz_init_set_ui (*result, 1);
1818 for (d = 0; d < ar->dimen; d++)
1820 if (ref_dimen_size (ar, d, &size) == FAILURE)
1822 mpz_clear (*result);
1826 mpz_mul (*result, *result, size);
1834 /* Given an array expression and a dimension, figure out how many
1835 elements it has along that dimension. Returns SUCCESS if we were
1836 able to return a result in the 'result' variable, FAILURE
1840 gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
1845 if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1846 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1848 switch (array->expr_type)
1852 for (ref = array->ref; ref; ref = ref->next)
1854 if (ref->type != REF_ARRAY)
1857 if (ref->u.ar.type == AR_FULL)
1858 return spec_dimen_size (ref->u.ar.as, dimen, result);
1860 if (ref->u.ar.type == AR_SECTION)
1862 for (i = 0; dimen >= 0; i++)
1863 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1866 return ref_dimen_size (&ref->u.ar, i - 1, result);
1870 if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
1876 if (array->shape == NULL) {
1877 /* Expressions with rank > 1 should have "shape" properly set */
1878 if ( array->rank != 1 )
1879 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1880 return gfc_array_size(array, result);
1885 if (array->shape == NULL)
1888 mpz_init_set (*result, array->shape[dimen]);
1897 /* Given an array expression, figure out how many elements are in the
1898 array. Returns SUCCESS if this is possible, and sets the 'result'
1899 variable. Otherwise returns FAILURE. */
1902 gfc_array_size (gfc_expr * array, mpz_t * result)
1904 expand_info expand_save;
1909 switch (array->expr_type)
1912 flag = gfc_suppress_error;
1913 gfc_suppress_error = 1;
1915 expand_save = current_expand;
1917 current_expand.count = result;
1918 mpz_init_set_ui (*result, 0);
1920 current_expand.expand_work_function = count_elements;
1923 t = expand_constructor (array->value.constructor);
1924 gfc_suppress_error = flag;
1927 mpz_clear (*result);
1928 current_expand = expand_save;
1932 for (ref = array->ref; ref; ref = ref->next)
1934 if (ref->type != REF_ARRAY)
1937 if (ref->u.ar.type == AR_FULL)
1938 return spec_size (ref->u.ar.as, result);
1940 if (ref->u.ar.type == AR_SECTION)
1941 return ref_size (&ref->u.ar, result);
1944 return spec_size (array->symtree->n.sym->as, result);
1948 if (array->rank == 0 || array->shape == NULL)
1951 mpz_init_set_ui (*result, 1);
1953 for (i = 0; i < array->rank; i++)
1954 mpz_mul (*result, *result, array->shape[i]);
1963 /* Given an array reference, return the shape of the reference in an
1964 array of mpz_t integers. */
1967 gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape)
1977 for (; d < ar->as->rank; d++)
1978 if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
1984 for (i = 0; i < ar->dimen; i++)
1986 if (ar->dimen_type[i] != DIMEN_ELEMENT)
1988 if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2001 for (d--; d >= 0; d--)
2002 mpz_clear (shape[d]);
2008 /* Given an array expression, find the array reference structure that
2009 characterizes the reference. */
2012 gfc_find_array_ref (gfc_expr * e)
2016 for (ref = e->ref; ref; ref = ref->next)
2017 if (ref->type == REF_ARRAY
2018 && (ref->u.ar.type == AR_FULL
2019 || ref->u.ar.type == AR_SECTION))
2023 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2029 /* Find out if an array shape is known at compile time. */
2032 gfc_is_compile_time_shape (gfc_array_spec *as)
2036 if (as->type != AS_EXPLICIT)
2039 for (i = 0; i < as->rank; i++)
2040 if (!gfc_is_constant_expr (as->lower[i])
2041 || !gfc_is_constant_expr (as->upper[i]))