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
28 /* This parameter is the size of the largest array constructor that we
29 will expand to an array constructor without iterators.
30 Constructors larger than this will remain in the iterator form. */
32 #define GFC_MAX_AC_EXPAND 100
35 /**************** Array reference matching subroutines *****************/
37 /* Copy an array reference structure. */
40 gfc_copy_array_ref (gfc_array_ref
* src
)
48 dest
= gfc_get_array_ref ();
52 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
54 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
55 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
56 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
59 dest
->offset
= gfc_copy_expr (src
->offset
);
65 /* Match a single dimension of an array reference. This can be a
66 single element or an array section. Any modifications we've made
67 to the ar structure are cleaned up by the caller. If the init
68 is set, we require the subscript to be a valid initialization
72 match_subscript (gfc_array_ref
* ar
, int init
)
79 ar
->c_where
[i
] = gfc_current_locus
;
80 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
82 /* We can't be sure of the difference between DIMEN_ELEMENT and
83 DIMEN_VECTOR until we know the type of the element itself at
86 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
88 if (gfc_match_char (':') == MATCH_YES
)
91 /* Get start element. */
93 m
= gfc_match_init_expr (&ar
->start
[i
]);
95 m
= gfc_match_expr (&ar
->start
[i
]);
98 gfc_error ("Expected array subscript at %C");
102 if (gfc_match_char (':') == MATCH_NO
)
105 /* Get an optional end element. Because we've seen the colon, we
106 definitely have a range along this dimension. */
108 ar
->dimen_type
[i
] = DIMEN_RANGE
;
111 m
= gfc_match_init_expr (&ar
->end
[i
]);
113 m
= gfc_match_expr (&ar
->end
[i
]);
115 if (m
== MATCH_ERROR
)
118 /* See if we have an optional stride. */
119 if (gfc_match_char (':') == MATCH_YES
)
121 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
122 : gfc_match_expr (&ar
->stride
[i
]);
125 gfc_error ("Expected array subscript stride at %C");
134 /* Match an array reference, whether it is the whole array or a
135 particular elements or a section. If init is set, the reference has
136 to consist of init expressions. */
139 gfc_match_array_ref (gfc_array_ref
* ar
, gfc_array_spec
* as
, int init
)
143 memset (ar
, '\0', sizeof (ar
));
145 ar
->where
= gfc_current_locus
;
148 if (gfc_match_char ('(') != MATCH_YES
)
155 ar
->type
= AR_UNKNOWN
;
157 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
159 m
= match_subscript (ar
, init
);
160 if (m
== MATCH_ERROR
)
163 if (gfc_match_char (')') == MATCH_YES
)
166 if (gfc_match_char (',') != MATCH_YES
)
168 gfc_error ("Invalid form of array reference at %C");
173 gfc_error ("Array reference at %C cannot have more than "
174 stringize (GFC_MAX_DIMENSIONS
) " dimensions");
186 /************** Array specification matching subroutines ***************/
188 /* Free all of the expressions associated with array bounds
192 gfc_free_array_spec (gfc_array_spec
* as
)
199 for (i
= 0; i
< as
->rank
; i
++)
201 gfc_free_expr (as
->lower
[i
]);
202 gfc_free_expr (as
->upper
[i
]);
209 /* Take an array bound, resolves the expression, that make up the
210 shape and check associated constraints. */
213 resolve_array_bound (gfc_expr
* e
, int check_constant
)
219 if (gfc_resolve_expr (e
) == FAILURE
220 || gfc_specification_expr (e
) == FAILURE
)
223 if (check_constant
&& gfc_is_constant_expr (e
) == 0)
225 gfc_error ("Variable '%s' at %L in this context must be constant",
226 e
->symtree
->n
.sym
->name
, &e
->where
);
234 /* Takes an array specification, resolves the expressions that make up
235 the shape and make sure everything is integral. */
238 gfc_resolve_array_spec (gfc_array_spec
* as
, int check_constant
)
246 for (i
= 0; i
< as
->rank
; i
++)
249 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
253 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
261 /* Match a single array element specification. The return values as
262 well as the upper and lower bounds of the array spec are filled
263 in according to what we see on the input. The caller makes sure
264 individual specifications make sense as a whole.
267 Parsed Lower Upper Returned
268 ------------------------------------
269 : NULL NULL AS_DEFERRED (*)
271 x: x NULL AS_ASSUMED_SHAPE
273 x:* x NULL AS_ASSUMED_SIZE
274 * 1 NULL AS_ASSUMED_SIZE
276 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
277 is fixed during the resolution of formal interfaces.
279 Anything else AS_UNKNOWN. */
282 match_array_element_spec (gfc_array_spec
* as
)
284 gfc_expr
**upper
, **lower
;
287 lower
= &as
->lower
[as
->rank
- 1];
288 upper
= &as
->upper
[as
->rank
- 1];
290 if (gfc_match_char ('*') == MATCH_YES
)
292 *lower
= gfc_int_expr (1);
293 return AS_ASSUMED_SIZE
;
296 if (gfc_match_char (':') == MATCH_YES
)
299 m
= gfc_match_expr (upper
);
301 gfc_error ("Expected expression in array specification at %C");
305 if (gfc_match_char (':') == MATCH_NO
)
307 *lower
= gfc_int_expr (1);
314 if (gfc_match_char ('*') == MATCH_YES
)
315 return AS_ASSUMED_SIZE
;
317 m
= gfc_match_expr (upper
);
318 if (m
== MATCH_ERROR
)
321 return AS_ASSUMED_SHAPE
;
327 /* Matches an array specification, incidentally figuring out what sort
331 gfc_match_array_spec (gfc_array_spec
** asp
)
333 array_type current_type
;
337 if (gfc_match_char ('(') != MATCH_YES
)
343 as
= gfc_get_array_spec ();
345 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
355 current_type
= match_array_element_spec (as
);
359 if (current_type
== AS_UNKNOWN
)
361 as
->type
= current_type
;
365 { /* See how current spec meshes with the existing */
370 if (current_type
== AS_ASSUMED_SIZE
)
372 as
->type
= AS_ASSUMED_SIZE
;
376 if (current_type
== AS_EXPLICIT
)
380 ("Bad array specification for an explicitly shaped array"
385 case AS_ASSUMED_SHAPE
:
386 if ((current_type
== AS_ASSUMED_SHAPE
)
387 || (current_type
== AS_DEFERRED
))
391 ("Bad array specification for assumed shape array at %C");
395 if (current_type
== AS_DEFERRED
)
398 if (current_type
== AS_ASSUMED_SHAPE
)
400 as
->type
= AS_ASSUMED_SHAPE
;
404 gfc_error ("Bad specification for deferred shape array at %C");
407 case AS_ASSUMED_SIZE
:
408 gfc_error ("Bad specification for assumed size array at %C");
412 if (gfc_match_char (')') == MATCH_YES
)
415 if (gfc_match_char (',') != MATCH_YES
)
417 gfc_error ("Expected another dimension in array declaration at %C");
421 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
423 gfc_error ("Array specification at %C has more than "
424 stringize (GFC_MAX_DIMENSIONS
) " dimensions");
431 /* If a lower bounds of an assumed shape array is blank, put in one. */
432 if (as
->type
== AS_ASSUMED_SHAPE
)
434 for (i
= 0; i
< as
->rank
; i
++)
436 if (as
->lower
[i
] == NULL
)
437 as
->lower
[i
] = gfc_int_expr (1);
444 /* Something went wrong. */
445 gfc_free_array_spec (as
);
450 /* Given a symbol and an array specification, modify the symbol to
451 have that array specification. The error locus is needed in case
452 something goes wrong. On failure, the caller must free the spec. */
455 gfc_set_array_spec (gfc_symbol
* sym
, gfc_array_spec
* as
, locus
* error_loc
)
461 if (gfc_add_dimension (&sym
->attr
, error_loc
) == FAILURE
)
470 /* Copy an array specification. */
473 gfc_copy_array_spec (gfc_array_spec
* src
)
475 gfc_array_spec
*dest
;
481 dest
= gfc_get_array_spec ();
485 for (i
= 0; i
< dest
->rank
; i
++)
487 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
488 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
494 /* Returns nonzero if the two expressions are equal. Only handles integer
498 compare_bounds (gfc_expr
* bound1
, gfc_expr
* bound2
)
500 if (bound1
== NULL
|| bound2
== NULL
501 || bound1
->expr_type
!= EXPR_CONSTANT
502 || bound2
->expr_type
!= EXPR_CONSTANT
503 || bound1
->ts
.type
!= BT_INTEGER
504 || bound2
->ts
.type
!= BT_INTEGER
)
505 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
507 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
513 /* Compares two array specifications. They must be constant or deferred
517 gfc_compare_array_spec (gfc_array_spec
* as1
, gfc_array_spec
* as2
)
521 if (as1
== NULL
&& as2
== NULL
)
524 if (as1
== NULL
|| as2
== NULL
)
527 if (as1
->rank
!= as2
->rank
)
533 if (as1
->type
!= as2
->type
)
536 if (as1
->type
== AS_EXPLICIT
)
537 for (i
= 0; i
< as1
->rank
; i
++)
539 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
542 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
550 /****************** Array constructor functions ******************/
552 /* Start an array constructor. The constructor starts with zero
553 elements and should be appended to by gfc_append_constructor(). */
556 gfc_start_constructor (bt type
, int kind
, locus
* where
)
560 result
= gfc_get_expr ();
562 result
->expr_type
= EXPR_ARRAY
;
565 result
->ts
.type
= type
;
566 result
->ts
.kind
= kind
;
567 result
->where
= *where
;
572 /* Given an array constructor expression, append the new expression
573 node onto the constructor. */
576 gfc_append_constructor (gfc_expr
* base
, gfc_expr
* new)
580 if (base
->value
.constructor
== NULL
)
581 base
->value
.constructor
= c
= gfc_get_constructor ();
584 c
= base
->value
.constructor
;
588 c
->next
= gfc_get_constructor ();
594 if (new->ts
.type
!= base
->ts
.type
|| new->ts
.kind
!= base
->ts
.kind
)
595 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
599 /* Given an array constructor expression, insert the new expression's
600 constructor onto the base's one according to the offset. */
603 gfc_insert_constructor (gfc_expr
* base
, gfc_constructor
* c1
)
605 gfc_constructor
*c
, *pre
;
609 type
= base
->expr_type
;
611 if (base
->value
.constructor
== NULL
)
612 base
->value
.constructor
= c1
;
615 c
= pre
= base
->value
.constructor
;
618 if (type
== EXPR_ARRAY
)
620 t
= mpz_cmp (c
->n
.offset
, c1
->n
.offset
);
628 gfc_error ("duplicated initializer");
649 base
->value
.constructor
= c1
;
655 /* Get a new constructor. */
658 gfc_get_constructor (void)
662 c
= gfc_getmem (sizeof(gfc_constructor
));
666 mpz_init_set_si (c
->n
.offset
, 0);
667 mpz_init_set_si (c
->repeat
, 0);
672 /* Free chains of gfc_constructor structures. */
675 gfc_free_constructor (gfc_constructor
* p
)
677 gfc_constructor
*next
;
687 gfc_free_expr (p
->expr
);
688 if (p
->iterator
!= NULL
)
689 gfc_free_iterator (p
->iterator
, 1);
690 mpz_clear (p
->n
.offset
);
691 mpz_clear (p
->repeat
);
697 /* Given an expression node that might be an array constructor and a
698 symbol, make sure that no iterators in this or child constructors
699 use the symbol as an implied-DO iterator. Returns nonzero if a
700 duplicate was found. */
703 check_duplicate_iterator (gfc_constructor
* c
, gfc_symbol
* master
)
707 for (; c
; c
= c
->next
)
711 if (e
->expr_type
== EXPR_ARRAY
712 && check_duplicate_iterator (e
->value
.constructor
, master
))
715 if (c
->iterator
== NULL
)
718 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
721 ("DO-iterator '%s' at %L is inside iterator of the same name",
722 master
->name
, &c
->where
);
732 /* Forward declaration because these functions are mutually recursive. */
733 static match
match_array_cons_element (gfc_constructor
**);
735 /* Match a list of array elements. */
738 match_array_list (gfc_constructor
** result
)
740 gfc_constructor
*p
, *head
, *tail
, *new;
747 old_loc
= gfc_current_locus
;
749 if (gfc_match_char ('(') == MATCH_NO
)
752 memset (&iter
, '\0', sizeof (gfc_iterator
));
755 m
= match_array_cons_element (&head
);
761 if (gfc_match_char (',') != MATCH_YES
)
769 m
= gfc_match_iterator (&iter
, 0);
772 if (m
== MATCH_ERROR
)
775 m
= match_array_cons_element (&new);
776 if (m
== MATCH_ERROR
)
783 goto cleanup
; /* Could be a complex constant */
789 if (gfc_match_char (',') != MATCH_YES
)
798 if (gfc_match_char (')') != MATCH_YES
)
801 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
808 e
->expr_type
= EXPR_ARRAY
;
810 e
->value
.constructor
= head
;
812 p
= gfc_get_constructor ();
813 p
->where
= gfc_current_locus
;
814 p
->iterator
= gfc_get_iterator ();
823 gfc_error ("Syntax error in array constructor at %C");
827 gfc_free_constructor (head
);
828 gfc_free_iterator (&iter
, 0);
829 gfc_current_locus
= old_loc
;
834 /* Match a single element of an array constructor, which can be a
835 single expression or a list of elements. */
838 match_array_cons_element (gfc_constructor
** result
)
844 m
= match_array_list (result
);
848 m
= gfc_match_expr (&expr
);
852 p
= gfc_get_constructor ();
853 p
->where
= gfc_current_locus
;
861 /* Match an array constructor. */
864 gfc_match_array_constructor (gfc_expr
** result
)
866 gfc_constructor
*head
, *tail
, *new;
871 if (gfc_match (" (/") == MATCH_NO
)
874 where
= gfc_current_locus
;
877 if (gfc_match (" /)") == MATCH_YES
)
878 goto empty
; /* Special case */
882 m
= match_array_cons_element (&new);
883 if (m
== MATCH_ERROR
)
895 if (gfc_match_char (',') == MATCH_NO
)
899 if (gfc_match (" /)") == MATCH_NO
)
903 expr
= gfc_get_expr ();
905 expr
->expr_type
= EXPR_ARRAY
;
907 expr
->value
.constructor
= head
;
908 /* Size must be calculated at resolution time. */
917 gfc_error ("Syntax error in array constructor at %C");
920 gfc_free_constructor (head
);
926 /************** Check array constructors for correctness **************/
928 /* Given an expression, compare it's type with the type of the current
929 constructor. Returns nonzero if an error was issued. The
930 cons_state variable keeps track of whether the type of the
931 constructor being read or resolved is known to be good, bad or just
934 static gfc_typespec constructor_ts
;
936 { CONS_START
, CONS_GOOD
, CONS_BAD
}
940 check_element_type (gfc_expr
* expr
)
943 if (cons_state
== CONS_BAD
)
944 return 0; /* Suppress further errors */
946 if (cons_state
== CONS_START
)
948 if (expr
->ts
.type
== BT_UNKNOWN
)
949 cons_state
= CONS_BAD
;
952 cons_state
= CONS_GOOD
;
953 constructor_ts
= expr
->ts
;
959 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
962 gfc_error ("Element in %s array constructor at %L is %s",
963 gfc_typename (&constructor_ts
), &expr
->where
,
964 gfc_typename (&expr
->ts
));
966 cons_state
= CONS_BAD
;
971 /* Recursive work function for gfc_check_constructor_type(). */
974 check_constructor_type (gfc_constructor
* c
)
978 for (; c
; c
= c
->next
)
982 if (e
->expr_type
== EXPR_ARRAY
)
984 if (check_constructor_type (e
->value
.constructor
) == FAILURE
)
990 if (check_element_type (e
))
998 /* Check that all elements of an array constructor are the same type.
999 On FAILURE, an error has been generated. */
1002 gfc_check_constructor_type (gfc_expr
* e
)
1006 cons_state
= CONS_START
;
1007 gfc_clear_ts (&constructor_ts
);
1009 t
= check_constructor_type (e
->value
.constructor
);
1010 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1011 e
->ts
= constructor_ts
;
1018 typedef struct cons_stack
1020 gfc_iterator
*iterator
;
1021 struct cons_stack
*previous
;
1025 static cons_stack
*base
;
1027 static try check_constructor (gfc_constructor
*, try (*)(gfc_expr
*));
1029 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1030 that that variable is an iteration variables. */
1033 gfc_check_iter_variable (gfc_expr
* expr
)
1039 sym
= expr
->symtree
->n
.sym
;
1041 for (c
= base
; c
; c
= c
->previous
)
1042 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1049 /* Recursive work function for gfc_check_constructor(). This amounts
1050 to calling the check function for each expression in the
1051 constructor, giving variables with the names of iterators a pass. */
1054 check_constructor (gfc_constructor
* c
, try (*check_function
) (gfc_expr
*))
1060 for (; c
; c
= c
->next
)
1064 if (e
->expr_type
!= EXPR_ARRAY
)
1066 if ((*check_function
) (e
) == FAILURE
)
1071 element
.previous
= base
;
1072 element
.iterator
= c
->iterator
;
1075 t
= check_constructor (e
->value
.constructor
, check_function
);
1076 base
= element
.previous
;
1082 /* Nothing went wrong, so all OK. */
1087 /* Checks a constructor to see if it is a particular kind of
1088 expression -- specification, restricted, or initialization as
1089 determined by the check_function. */
1092 gfc_check_constructor (gfc_expr
* expr
, try (*check_function
) (gfc_expr
*))
1094 cons_stack
*base_save
;
1100 t
= check_constructor (expr
->value
.constructor
, check_function
);
1108 /**************** Simplification of array constructors ****************/
1110 iterator_stack
*iter_stack
;
1114 gfc_constructor
*new_head
, *new_tail
;
1115 int extract_count
, extract_n
;
1116 gfc_expr
*extracted
;
1120 gfc_component
*component
;
1123 try (*expand_work_function
) (gfc_expr
*);
1127 static expand_info current_expand
;
1129 static try expand_constructor (gfc_constructor
*);
1132 /* Work function that counts the number of elements present in a
1136 count_elements (gfc_expr
* e
)
1141 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1144 if (gfc_array_size (e
, &result
) == FAILURE
)
1150 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1159 /* Work function that extracts a particular element from an array
1160 constructor, freeing the rest. */
1163 extract_element (gfc_expr
* e
)
1167 { /* Something unextractable */
1172 if (current_expand
.extract_count
== current_expand
.extract_n
)
1173 current_expand
.extracted
= e
;
1177 current_expand
.extract_count
++;
1182 /* Work function that constructs a new constructor out of the old one,
1183 stringing new elements together. */
1186 expand (gfc_expr
* e
)
1189 if (current_expand
.new_head
== NULL
)
1190 current_expand
.new_head
= current_expand
.new_tail
=
1191 gfc_get_constructor ();
1194 current_expand
.new_tail
->next
= gfc_get_constructor ();
1195 current_expand
.new_tail
= current_expand
.new_tail
->next
;
1198 current_expand
.new_tail
->where
= e
->where
;
1199 current_expand
.new_tail
->expr
= e
;
1201 mpz_set (current_expand
.new_tail
->n
.offset
, *current_expand
.offset
);
1202 current_expand
.new_tail
->n
.component
= current_expand
.component
;
1203 mpz_set (current_expand
.new_tail
->repeat
, *current_expand
.repeat
);
1208 /* Given an initialization expression that is a variable reference,
1209 substitute the current value of the iteration variable. */
1212 gfc_simplify_iterator_var (gfc_expr
* e
)
1216 for (p
= iter_stack
; p
; p
= p
->prev
)
1217 if (e
->symtree
== p
->variable
)
1221 return; /* Variable not found */
1223 gfc_replace_expr (e
, gfc_int_expr (0));
1225 mpz_set (e
->value
.integer
, p
->value
);
1231 /* Expand an expression with that is inside of a constructor,
1232 recursing into other constructors if present. */
1235 expand_expr (gfc_expr
* e
)
1238 if (e
->expr_type
== EXPR_ARRAY
)
1239 return expand_constructor (e
->value
.constructor
);
1241 e
= gfc_copy_expr (e
);
1243 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1249 return current_expand
.expand_work_function (e
);
1254 expand_iterator (gfc_constructor
* c
)
1256 gfc_expr
*start
, *end
, *step
;
1257 iterator_stack frame
;
1266 mpz_init (frame
.value
);
1268 start
= gfc_copy_expr (c
->iterator
->start
);
1269 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1272 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1275 end
= gfc_copy_expr (c
->iterator
->end
);
1276 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1279 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1282 step
= gfc_copy_expr (c
->iterator
->step
);
1283 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1286 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1289 if (mpz_sgn (step
->value
.integer
) == 0)
1291 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1295 /* Calculate the trip count of the loop. */
1296 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1297 mpz_add (trip
, trip
, step
->value
.integer
);
1298 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1300 mpz_set (frame
.value
, start
->value
.integer
);
1302 frame
.prev
= iter_stack
;
1303 frame
.variable
= c
->iterator
->var
->symtree
;
1304 iter_stack
= &frame
;
1306 while (mpz_sgn (trip
) > 0)
1308 if (expand_expr (c
->expr
) == FAILURE
)
1311 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1312 mpz_sub_ui (trip
, trip
, 1);
1318 gfc_free_expr (start
);
1319 gfc_free_expr (end
);
1320 gfc_free_expr (step
);
1323 mpz_clear (frame
.value
);
1325 iter_stack
= frame
.prev
;
1331 /* Expand a constructor into constant constructors without any
1332 iterators, calling the work function for each of the expanded
1333 expressions. The work function needs to either save or free the
1334 passed expression. */
1337 expand_constructor (gfc_constructor
* c
)
1341 for (; c
; c
= c
->next
)
1343 if (c
->iterator
!= NULL
)
1345 if (expand_iterator (c
) == FAILURE
)
1352 if (e
->expr_type
== EXPR_ARRAY
)
1354 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1360 e
= gfc_copy_expr (e
);
1361 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1366 current_expand
.offset
= &c
->n
.offset
;
1367 current_expand
.component
= c
->n
.component
;
1368 current_expand
.repeat
= &c
->repeat
;
1369 if (current_expand
.expand_work_function (e
) == FAILURE
)
1376 /* Top level subroutine for expanding constructors. We only expand
1377 constructor if they are small enough. */
1380 gfc_expand_constructor (gfc_expr
* e
)
1382 expand_info expand_save
;
1386 f
= gfc_get_array_element (e
, GFC_MAX_AC_EXPAND
);
1393 expand_save
= current_expand
;
1394 current_expand
.new_head
= current_expand
.new_tail
= NULL
;
1398 current_expand
.expand_work_function
= expand
;
1400 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1402 gfc_free_constructor (current_expand
.new_head
);
1407 gfc_free_constructor (e
->value
.constructor
);
1408 e
->value
.constructor
= current_expand
.new_head
;
1413 current_expand
= expand_save
;
1419 /* Work function for checking that an element of a constructor is a
1420 constant, after removal of any iteration variables. We return
1421 FAILURE if not so. */
1424 constant_element (gfc_expr
* e
)
1428 rv
= gfc_is_constant_expr (e
);
1431 return rv
? SUCCESS
: FAILURE
;
1435 /* Given an array constructor, determine if the constructor is
1436 constant or not by expanding it and making sure that all elements
1437 are constants. This is a bit of a hack since something like (/ (i,
1438 i=1,100000000) /) will take a while as* opposed to a more clever
1439 function that traverses the expression tree. FIXME. */
1442 gfc_constant_ac (gfc_expr
* e
)
1444 expand_info expand_save
;
1448 expand_save
= current_expand
;
1449 current_expand
.expand_work_function
= constant_element
;
1451 rc
= expand_constructor (e
->value
.constructor
);
1453 current_expand
= expand_save
;
1461 /* Returns nonzero if an array constructor has been completely
1462 expanded (no iterators) and zero if iterators are present. */
1465 gfc_expanded_ac (gfc_expr
* e
)
1469 if (e
->expr_type
== EXPR_ARRAY
)
1470 for (p
= e
->value
.constructor
; p
; p
= p
->next
)
1471 if (p
->iterator
!= NULL
|| !gfc_expanded_ac (p
->expr
))
1478 /*************** Type resolution of array constructors ***************/
1480 /* Recursive array list resolution function. All of the elements must
1481 be of the same type. */
1484 resolve_array_list (gfc_constructor
* p
)
1490 for (; p
; p
= p
->next
)
1492 if (p
->iterator
!= NULL
1493 && gfc_resolve_iterator (p
->iterator
) == FAILURE
)
1496 if (gfc_resolve_expr (p
->expr
) == FAILURE
)
1504 /* Resolve all of the expressions in an array list.
1505 TODO: String lengths. */
1508 gfc_resolve_array_constructor (gfc_expr
* expr
)
1512 t
= resolve_array_list (expr
->value
.constructor
);
1514 t
= gfc_check_constructor_type (expr
);
1520 /* Copy an iterator structure. */
1522 static gfc_iterator
*
1523 copy_iterator (gfc_iterator
* src
)
1530 dest
= gfc_get_iterator ();
1532 dest
->var
= gfc_copy_expr (src
->var
);
1533 dest
->start
= gfc_copy_expr (src
->start
);
1534 dest
->end
= gfc_copy_expr (src
->end
);
1535 dest
->step
= gfc_copy_expr (src
->step
);
1541 /* Copy a constructor structure. */
1544 gfc_copy_constructor (gfc_constructor
* src
)
1546 gfc_constructor
*dest
;
1547 gfc_constructor
*tail
;
1556 dest
= tail
= gfc_get_constructor ();
1559 tail
->next
= gfc_get_constructor ();
1562 tail
->where
= src
->where
;
1563 tail
->expr
= gfc_copy_expr (src
->expr
);
1564 tail
->iterator
= copy_iterator (src
->iterator
);
1565 mpz_set (tail
->n
.offset
, src
->n
.offset
);
1566 tail
->n
.component
= src
->n
.component
;
1567 mpz_set (tail
->repeat
, src
->repeat
);
1575 /* Given an array expression and an element number (starting at zero),
1576 return a pointer to the array element. NULL is returned if the
1577 size of the array has been exceeded. The expression node returned
1578 remains a part of the array and should not be freed. Access is not
1579 efficient at all, but this is another place where things do not
1580 have to be particularly fast. */
1583 gfc_get_array_element (gfc_expr
* array
, int element
)
1585 expand_info expand_save
;
1589 expand_save
= current_expand
;
1590 current_expand
.extract_n
= element
;
1591 current_expand
.expand_work_function
= extract_element
;
1592 current_expand
.extracted
= NULL
;
1593 current_expand
.extract_count
= 0;
1597 rc
= expand_constructor (array
->value
.constructor
);
1598 e
= current_expand
.extracted
;
1599 current_expand
= expand_save
;
1608 /********* Subroutines for determining the size of an array *********/
1610 /* These are needed just to accommodate RESHAPE(). There are no
1611 diagnostics here, we just return a negative number if something
1615 /* Get the size of single dimension of an array specification. The
1616 array is guaranteed to be one dimensional. */
1619 spec_dimen_size (gfc_array_spec
* as
, int dimen
, mpz_t
* result
)
1625 if (dimen
< 0 || dimen
> as
->rank
- 1)
1626 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1628 if (as
->type
!= AS_EXPLICIT
1629 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
1630 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1635 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
1636 as
->lower
[dimen
]->value
.integer
);
1638 mpz_add_ui (*result
, *result
, 1);
1645 spec_size (gfc_array_spec
* as
, mpz_t
* result
)
1650 mpz_init_set_ui (*result
, 1);
1652 for (d
= 0; d
< as
->rank
; d
++)
1654 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
1656 mpz_clear (*result
);
1660 mpz_mul (*result
, *result
, size
);
1668 /* Get the number of elements in an array section. */
1671 ref_dimen_size (gfc_array_ref
* ar
, int dimen
, mpz_t
* result
)
1673 mpz_t upper
, lower
, stride
;
1676 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
1677 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1679 switch (ar
->dimen_type
[dimen
])
1683 mpz_set_ui (*result
, 1);
1688 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
1697 if (ar
->start
[dimen
] == NULL
)
1699 if (ar
->as
->lower
[dimen
] == NULL
1700 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1702 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
1706 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1708 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
1711 if (ar
->end
[dimen
] == NULL
)
1713 if (ar
->as
->upper
[dimen
] == NULL
1714 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1716 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
1720 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1722 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
1725 if (ar
->stride
[dimen
] == NULL
)
1726 mpz_set_ui (stride
, 1);
1729 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1731 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
1735 mpz_sub (*result
, upper
, lower
);
1736 mpz_add (*result
, *result
, stride
);
1737 mpz_div (*result
, *result
, stride
);
1739 /* Zero stride caught earlier. */
1740 if (mpz_cmp_ui (*result
, 0) < 0)
1741 mpz_set_ui (*result
, 0);
1751 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1759 ref_size (gfc_array_ref
* ar
, mpz_t
* result
)
1764 mpz_init_set_ui (*result
, 1);
1766 for (d
= 0; d
< ar
->dimen
; d
++)
1768 if (ref_dimen_size (ar
, d
, &size
) == FAILURE
)
1770 mpz_clear (*result
);
1774 mpz_mul (*result
, *result
, size
);
1782 /* Given an array expression and a dimension, figure out how many
1783 elements it has along that dimension. Returns SUCCESS if we were
1784 able to return a result in the 'result' variable, FAILURE
1788 gfc_array_dimen_size (gfc_expr
* array
, int dimen
, mpz_t
* result
)
1793 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
1794 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1796 switch (array
->expr_type
)
1800 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1802 if (ref
->type
!= REF_ARRAY
)
1805 if (ref
->u
.ar
.type
== AR_FULL
)
1806 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
1808 if (ref
->u
.ar
.type
== AR_SECTION
)
1810 for (i
= 0; dimen
>= 0; i
++)
1811 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1814 return ref_dimen_size (&ref
->u
.ar
, i
- 1, result
);
1818 if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
) == FAILURE
)
1824 if (array
->shape
== NULL
) {
1825 /* Expressions with rank > 1 should have "shape" properly set */
1826 if ( array
->rank
!= 1 )
1827 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1828 return gfc_array_size(array
, result
);
1833 if (array
->shape
== NULL
)
1836 mpz_init_set (*result
, array
->shape
[dimen
]);
1845 /* Given an array expression, figure out how many elements are in the
1846 array. Returns SUCCESS if this is possible, and sets the 'result'
1847 variable. Otherwise returns FAILURE. */
1850 gfc_array_size (gfc_expr
* array
, mpz_t
* result
)
1852 expand_info expand_save
;
1857 switch (array
->expr_type
)
1860 flag
= gfc_suppress_error
;
1861 gfc_suppress_error
= 1;
1863 expand_save
= current_expand
;
1865 current_expand
.count
= result
;
1866 mpz_init_set_ui (*result
, 0);
1868 current_expand
.expand_work_function
= count_elements
;
1871 t
= expand_constructor (array
->value
.constructor
);
1872 gfc_suppress_error
= flag
;
1875 mpz_clear (*result
);
1876 current_expand
= expand_save
;
1880 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1882 if (ref
->type
!= REF_ARRAY
)
1885 if (ref
->u
.ar
.type
== AR_FULL
)
1886 return spec_size (ref
->u
.ar
.as
, result
);
1888 if (ref
->u
.ar
.type
== AR_SECTION
)
1889 return ref_size (&ref
->u
.ar
, result
);
1892 return spec_size (array
->symtree
->n
.sym
->as
, result
);
1896 if (array
->rank
== 0 || array
->shape
== NULL
)
1899 mpz_init_set_ui (*result
, 1);
1901 for (i
= 0; i
< array
->rank
; i
++)
1902 mpz_mul (*result
, *result
, array
->shape
[i
]);
1911 /* Given an array reference, return the shape of the reference in an
1912 array of mpz_t integers. */
1915 gfc_array_ref_shape (gfc_array_ref
* ar
, mpz_t
* shape
)
1925 for (; d
< ar
->as
->rank
; d
++)
1926 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
1932 for (i
= 0; i
< ar
->dimen
; i
++)
1934 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
1936 if (ref_dimen_size (ar
, i
, &shape
[d
]) == FAILURE
)
1949 for (d
--; d
>= 0; d
--)
1950 mpz_clear (shape
[d
]);
1956 /* Given an array expression, find the array reference structure that
1957 characterizes the reference. */
1960 gfc_find_array_ref (gfc_expr
* e
)
1964 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1965 if (ref
->type
== REF_ARRAY
1966 && (ref
->u
.ar
.type
== AR_FULL
1967 || ref
->u
.ar
.type
== AR_SECTION
))
1971 gfc_internal_error ("gfc_find_array_ref(): No ref found");
1977 /* Find out if an array shape is known at compile time. */
1980 gfc_is_compile_time_shape (gfc_array_spec
*as
)
1984 if (as
->type
!= AS_EXPLICIT
)
1987 for (i
= 0; i
< as
->rank
; i
++)
1988 if (!gfc_is_constant_expr (as
->lower
[i
])
1989 || !gfc_is_constant_expr (as
->upper
[i
]))