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
29 /* This parameter is the size of the largest array constructor that we
30 will expand to an array constructor without iterators.
31 Constructors larger than this will remain in the iterator form. */
33 #define GFC_MAX_AC_EXPAND 100
36 /**************** Array reference matching subroutines *****************/
38 /* Copy an array reference structure. */
41 gfc_copy_array_ref (gfc_array_ref
* src
)
49 dest
= gfc_get_array_ref ();
53 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
55 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
56 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
57 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
60 dest
->offset
= gfc_copy_expr (src
->offset
);
66 /* Match a single dimension of an array reference. This can be a
67 single element or an array section. Any modifications we've made
68 to the ar structure are cleaned up by the caller. If the init
69 is set, we require the subscript to be a valid initialization
73 match_subscript (gfc_array_ref
* ar
, int init
)
80 ar
->c_where
[i
] = gfc_current_locus
;
81 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
83 /* We can't be sure of the difference between DIMEN_ELEMENT and
84 DIMEN_VECTOR until we know the type of the element itself at
87 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
89 if (gfc_match_char (':') == MATCH_YES
)
92 /* Get start element. */
94 m
= gfc_match_init_expr (&ar
->start
[i
]);
96 m
= gfc_match_expr (&ar
->start
[i
]);
99 gfc_error ("Expected array subscript at %C");
103 if (gfc_match_char (':') == MATCH_NO
)
106 /* Get an optional end element. Because we've seen the colon, we
107 definitely have a range along this dimension. */
109 ar
->dimen_type
[i
] = DIMEN_RANGE
;
112 m
= gfc_match_init_expr (&ar
->end
[i
]);
114 m
= gfc_match_expr (&ar
->end
[i
]);
116 if (m
== MATCH_ERROR
)
119 /* See if we have an optional stride. */
120 if (gfc_match_char (':') == MATCH_YES
)
122 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
123 : gfc_match_expr (&ar
->stride
[i
]);
126 gfc_error ("Expected array subscript stride at %C");
135 /* Match an array reference, whether it is the whole array or a
136 particular elements or a section. If init is set, the reference has
137 to consist of init expressions. */
140 gfc_match_array_ref (gfc_array_ref
* ar
, gfc_array_spec
* as
, int init
)
144 memset (ar
, '\0', sizeof (ar
));
146 ar
->where
= gfc_current_locus
;
149 if (gfc_match_char ('(') != MATCH_YES
)
156 ar
->type
= AR_UNKNOWN
;
158 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
160 m
= match_subscript (ar
, init
);
161 if (m
== MATCH_ERROR
)
164 if (gfc_match_char (')') == MATCH_YES
)
167 if (gfc_match_char (',') != MATCH_YES
)
169 gfc_error ("Invalid form of array reference at %C");
174 gfc_error ("Array reference at %C cannot have more than "
175 stringize (GFC_MAX_DIMENSIONS
) " dimensions");
187 /************** Array specification matching subroutines ***************/
189 /* Free all of the expressions associated with array bounds
193 gfc_free_array_spec (gfc_array_spec
* as
)
200 for (i
= 0; i
< as
->rank
; i
++)
202 gfc_free_expr (as
->lower
[i
]);
203 gfc_free_expr (as
->upper
[i
]);
210 /* Take an array bound, resolves the expression, that make up the
211 shape and check associated constraints. */
214 resolve_array_bound (gfc_expr
* e
, int check_constant
)
220 if (gfc_resolve_expr (e
) == FAILURE
221 || gfc_specification_expr (e
) == FAILURE
)
224 if (check_constant
&& gfc_is_constant_expr (e
) == 0)
226 gfc_error ("Variable '%s' at %L in this context must be constant",
227 e
->symtree
->n
.sym
->name
, &e
->where
);
235 /* Takes an array specification, resolves the expressions that make up
236 the shape and make sure everything is integral. */
239 gfc_resolve_array_spec (gfc_array_spec
* as
, int check_constant
)
247 for (i
= 0; i
< as
->rank
; i
++)
250 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
254 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
262 /* Match a single array element specification. The return values as
263 well as the upper and lower bounds of the array spec are filled
264 in according to what we see on the input. The caller makes sure
265 individual specifications make sense as a whole.
268 Parsed Lower Upper Returned
269 ------------------------------------
270 : NULL NULL AS_DEFERRED (*)
272 x: x NULL AS_ASSUMED_SHAPE
274 x:* x NULL AS_ASSUMED_SIZE
275 * 1 NULL AS_ASSUMED_SIZE
277 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
278 is fixed during the resolution of formal interfaces.
280 Anything else AS_UNKNOWN. */
283 match_array_element_spec (gfc_array_spec
* as
)
285 gfc_expr
**upper
, **lower
;
288 lower
= &as
->lower
[as
->rank
- 1];
289 upper
= &as
->upper
[as
->rank
- 1];
291 if (gfc_match_char ('*') == MATCH_YES
)
293 *lower
= gfc_int_expr (1);
294 return AS_ASSUMED_SIZE
;
297 if (gfc_match_char (':') == MATCH_YES
)
300 m
= gfc_match_expr (upper
);
302 gfc_error ("Expected expression in array specification at %C");
306 if (gfc_match_char (':') == MATCH_NO
)
308 *lower
= gfc_int_expr (1);
315 if (gfc_match_char ('*') == MATCH_YES
)
316 return AS_ASSUMED_SIZE
;
318 m
= gfc_match_expr (upper
);
319 if (m
== MATCH_ERROR
)
322 return AS_ASSUMED_SHAPE
;
328 /* Matches an array specification, incidentally figuring out what sort
332 gfc_match_array_spec (gfc_array_spec
** asp
)
334 array_type current_type
;
338 if (gfc_match_char ('(') != MATCH_YES
)
344 as
= gfc_get_array_spec ();
346 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
356 current_type
= match_array_element_spec (as
);
360 if (current_type
== AS_UNKNOWN
)
362 as
->type
= current_type
;
366 { /* See how current spec meshes with the existing */
371 if (current_type
== AS_ASSUMED_SIZE
)
373 as
->type
= AS_ASSUMED_SIZE
;
377 if (current_type
== AS_EXPLICIT
)
381 ("Bad array specification for an explicitly shaped array"
386 case AS_ASSUMED_SHAPE
:
387 if ((current_type
== AS_ASSUMED_SHAPE
)
388 || (current_type
== AS_DEFERRED
))
392 ("Bad array specification for assumed shape array at %C");
396 if (current_type
== AS_DEFERRED
)
399 if (current_type
== AS_ASSUMED_SHAPE
)
401 as
->type
= AS_ASSUMED_SHAPE
;
405 gfc_error ("Bad specification for deferred shape array at %C");
408 case AS_ASSUMED_SIZE
:
409 gfc_error ("Bad specification for assumed size array at %C");
413 if (gfc_match_char (')') == MATCH_YES
)
416 if (gfc_match_char (',') != MATCH_YES
)
418 gfc_error ("Expected another dimension in array declaration at %C");
422 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
424 gfc_error ("Array specification at %C has more than "
425 stringize (GFC_MAX_DIMENSIONS
) " dimensions");
432 /* If a lower bounds of an assumed shape array is blank, put in one. */
433 if (as
->type
== AS_ASSUMED_SHAPE
)
435 for (i
= 0; i
< as
->rank
; i
++)
437 if (as
->lower
[i
] == NULL
)
438 as
->lower
[i
] = gfc_int_expr (1);
445 /* Something went wrong. */
446 gfc_free_array_spec (as
);
451 /* Given a symbol and an array specification, modify the symbol to
452 have that array specification. The error locus is needed in case
453 something goes wrong. On failure, the caller must free the spec. */
456 gfc_set_array_spec (gfc_symbol
* sym
, gfc_array_spec
* as
, locus
* error_loc
)
462 if (gfc_add_dimension (&sym
->attr
, error_loc
) == FAILURE
)
471 /* Copy an array specification. */
474 gfc_copy_array_spec (gfc_array_spec
* src
)
476 gfc_array_spec
*dest
;
482 dest
= gfc_get_array_spec ();
486 for (i
= 0; i
< dest
->rank
; i
++)
488 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
489 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
495 /* Returns nonzero if the two expressions are equal. Only handles integer
499 compare_bounds (gfc_expr
* bound1
, gfc_expr
* bound2
)
501 if (bound1
== NULL
|| bound2
== NULL
502 || bound1
->expr_type
!= EXPR_CONSTANT
503 || bound2
->expr_type
!= EXPR_CONSTANT
504 || bound1
->ts
.type
!= BT_INTEGER
505 || bound2
->ts
.type
!= BT_INTEGER
)
506 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
508 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
514 /* Compares two array specifications. They must be constant or deferred
518 gfc_compare_array_spec (gfc_array_spec
* as1
, gfc_array_spec
* as2
)
522 if (as1
== NULL
&& as2
== NULL
)
525 if (as1
== NULL
|| as2
== NULL
)
528 if (as1
->rank
!= as2
->rank
)
534 if (as1
->type
!= as2
->type
)
537 if (as1
->type
== AS_EXPLICIT
)
538 for (i
= 0; i
< as1
->rank
; i
++)
540 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
543 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
551 /****************** Array constructor functions ******************/
553 /* Start an array constructor. The constructor starts with zero
554 elements and should be appended to by gfc_append_constructor(). */
557 gfc_start_constructor (bt type
, int kind
, locus
* where
)
561 result
= gfc_get_expr ();
563 result
->expr_type
= EXPR_ARRAY
;
566 result
->ts
.type
= type
;
567 result
->ts
.kind
= kind
;
568 result
->where
= *where
;
573 /* Given an array constructor expression, append the new expression
574 node onto the constructor. */
577 gfc_append_constructor (gfc_expr
* base
, gfc_expr
* new)
581 if (base
->value
.constructor
== NULL
)
582 base
->value
.constructor
= c
= gfc_get_constructor ();
585 c
= base
->value
.constructor
;
589 c
->next
= gfc_get_constructor ();
595 if (new->ts
.type
!= base
->ts
.type
|| new->ts
.kind
!= base
->ts
.kind
)
596 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
600 /* Given an array constructor expression, insert the new expression's
601 constructor onto the base's one according to the offset. */
604 gfc_insert_constructor (gfc_expr
* base
, gfc_constructor
* c1
)
606 gfc_constructor
*c
, *pre
;
610 type
= base
->expr_type
;
612 if (base
->value
.constructor
== NULL
)
613 base
->value
.constructor
= c1
;
616 c
= pre
= base
->value
.constructor
;
619 if (type
== EXPR_ARRAY
)
621 t
= mpz_cmp (c
->n
.offset
, c1
->n
.offset
);
629 gfc_error ("duplicated initializer");
650 base
->value
.constructor
= c1
;
656 /* Get a new constructor. */
659 gfc_get_constructor (void)
663 c
= gfc_getmem (sizeof(gfc_constructor
));
667 mpz_init_set_si (c
->n
.offset
, 0);
668 mpz_init_set_si (c
->repeat
, 0);
673 /* Free chains of gfc_constructor structures. */
676 gfc_free_constructor (gfc_constructor
* p
)
678 gfc_constructor
*next
;
688 gfc_free_expr (p
->expr
);
689 if (p
->iterator
!= NULL
)
690 gfc_free_iterator (p
->iterator
, 1);
691 mpz_clear (p
->n
.offset
);
692 mpz_clear (p
->repeat
);
698 /* Given an expression node that might be an array constructor and a
699 symbol, make sure that no iterators in this or child constructors
700 use the symbol as an implied-DO iterator. Returns nonzero if a
701 duplicate was found. */
704 check_duplicate_iterator (gfc_constructor
* c
, gfc_symbol
* master
)
708 for (; c
; c
= c
->next
)
712 if (e
->expr_type
== EXPR_ARRAY
713 && check_duplicate_iterator (e
->value
.constructor
, master
))
716 if (c
->iterator
== NULL
)
719 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
722 ("DO-iterator '%s' at %L is inside iterator of the same name",
723 master
->name
, &c
->where
);
733 /* Forward declaration because these functions are mutually recursive. */
734 static match
match_array_cons_element (gfc_constructor
**);
736 /* Match a list of array elements. */
739 match_array_list (gfc_constructor
** result
)
741 gfc_constructor
*p
, *head
, *tail
, *new;
748 old_loc
= gfc_current_locus
;
750 if (gfc_match_char ('(') == MATCH_NO
)
753 memset (&iter
, '\0', sizeof (gfc_iterator
));
756 m
= match_array_cons_element (&head
);
762 if (gfc_match_char (',') != MATCH_YES
)
770 m
= gfc_match_iterator (&iter
, 0);
773 if (m
== MATCH_ERROR
)
776 m
= match_array_cons_element (&new);
777 if (m
== MATCH_ERROR
)
784 goto cleanup
; /* Could be a complex constant */
790 if (gfc_match_char (',') != MATCH_YES
)
799 if (gfc_match_char (')') != MATCH_YES
)
802 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
809 e
->expr_type
= EXPR_ARRAY
;
811 e
->value
.constructor
= head
;
813 p
= gfc_get_constructor ();
814 p
->where
= gfc_current_locus
;
815 p
->iterator
= gfc_get_iterator ();
824 gfc_error ("Syntax error in array constructor at %C");
828 gfc_free_constructor (head
);
829 gfc_free_iterator (&iter
, 0);
830 gfc_current_locus
= old_loc
;
835 /* Match a single element of an array constructor, which can be a
836 single expression or a list of elements. */
839 match_array_cons_element (gfc_constructor
** result
)
845 m
= match_array_list (result
);
849 m
= gfc_match_expr (&expr
);
853 p
= gfc_get_constructor ();
854 p
->where
= gfc_current_locus
;
862 /* Match an array constructor. */
865 gfc_match_array_constructor (gfc_expr
** result
)
867 gfc_constructor
*head
, *tail
, *new;
872 if (gfc_match (" (/") == MATCH_NO
)
875 where
= gfc_current_locus
;
878 if (gfc_match (" /)") == MATCH_YES
)
879 goto empty
; /* Special case */
883 m
= match_array_cons_element (&new);
884 if (m
== MATCH_ERROR
)
896 if (gfc_match_char (',') == MATCH_NO
)
900 if (gfc_match (" /)") == MATCH_NO
)
904 expr
= gfc_get_expr ();
906 expr
->expr_type
= EXPR_ARRAY
;
908 expr
->value
.constructor
= head
;
909 /* Size must be calculated at resolution time. */
918 gfc_error ("Syntax error in array constructor at %C");
921 gfc_free_constructor (head
);
927 /************** Check array constructors for correctness **************/
929 /* Given an expression, compare it's type with the type of the current
930 constructor. Returns nonzero if an error was issued. The
931 cons_state variable keeps track of whether the type of the
932 constructor being read or resolved is known to be good, bad or just
935 static gfc_typespec constructor_ts
;
937 { CONS_START
, CONS_GOOD
, CONS_BAD
}
941 check_element_type (gfc_expr
* expr
)
944 if (cons_state
== CONS_BAD
)
945 return 0; /* Supress further errors */
947 if (cons_state
== CONS_START
)
949 if (expr
->ts
.type
== BT_UNKNOWN
)
950 cons_state
= CONS_BAD
;
953 cons_state
= CONS_GOOD
;
954 constructor_ts
= expr
->ts
;
960 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
963 gfc_error ("Element in %s array constructor at %L is %s",
964 gfc_typename (&constructor_ts
), &expr
->where
,
965 gfc_typename (&expr
->ts
));
967 cons_state
= CONS_BAD
;
972 /* Recursive work function for gfc_check_constructor_type(). */
975 check_constructor_type (gfc_constructor
* c
)
979 for (; c
; c
= c
->next
)
983 if (e
->expr_type
== EXPR_ARRAY
)
985 if (check_constructor_type (e
->value
.constructor
) == FAILURE
)
991 if (check_element_type (e
))
999 /* Check that all elements of an array constructor are the same type.
1000 On FAILURE, an error has been generated. */
1003 gfc_check_constructor_type (gfc_expr
* e
)
1007 cons_state
= CONS_START
;
1008 gfc_clear_ts (&constructor_ts
);
1010 t
= check_constructor_type (e
->value
.constructor
);
1011 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1012 e
->ts
= constructor_ts
;
1019 typedef struct cons_stack
1021 gfc_iterator
*iterator
;
1022 struct cons_stack
*previous
;
1026 static cons_stack
*base
;
1028 static try check_constructor (gfc_constructor
*, try (*)(gfc_expr
*));
1030 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1031 that that variable is an iteration variables. */
1034 gfc_check_iter_variable (gfc_expr
* expr
)
1040 sym
= expr
->symtree
->n
.sym
;
1042 for (c
= base
; c
; c
= c
->previous
)
1043 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1050 /* Recursive work function for gfc_check_constructor(). This amounts
1051 to calling the check function for each expression in the
1052 constructor, giving variables with the names of iterators a pass. */
1055 check_constructor (gfc_constructor
* c
, try (*check_function
) (gfc_expr
*))
1061 for (; c
; c
= c
->next
)
1065 if (e
->expr_type
!= EXPR_ARRAY
)
1067 if ((*check_function
) (e
) == FAILURE
)
1072 element
.previous
= base
;
1073 element
.iterator
= c
->iterator
;
1076 t
= check_constructor (e
->value
.constructor
, check_function
);
1077 base
= element
.previous
;
1083 /* Nothing went wrong, so all OK. */
1088 /* Checks a constructor to see if it is a particular kind of
1089 expression -- specification, restricted, or initialization as
1090 determined by the check_function. */
1093 gfc_check_constructor (gfc_expr
* expr
, try (*check_function
) (gfc_expr
*))
1095 cons_stack
*base_save
;
1101 t
= check_constructor (expr
->value
.constructor
, check_function
);
1109 /**************** Simplification of array constructors ****************/
1111 iterator_stack
*iter_stack
;
1115 gfc_constructor
*new_head
, *new_tail
;
1116 int extract_count
, extract_n
;
1117 gfc_expr
*extracted
;
1121 gfc_component
*component
;
1124 try (*expand_work_function
) (gfc_expr
*);
1128 static expand_info current_expand
;
1130 static try expand_constructor (gfc_constructor
*);
1133 /* Work function that counts the number of elements present in a
1137 count_elements (gfc_expr
* e
)
1142 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1145 if (gfc_array_size (e
, &result
) == FAILURE
)
1151 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1160 /* Work function that extracts a particular element from an array
1161 constructor, freeing the rest. */
1164 extract_element (gfc_expr
* e
)
1168 { /* Something unextractable */
1173 if (current_expand
.extract_count
== current_expand
.extract_n
)
1174 current_expand
.extracted
= e
;
1178 current_expand
.extract_count
++;
1183 /* Work function that constructs a new constructor out of the old one,
1184 stringing new elements together. */
1187 expand (gfc_expr
* e
)
1190 if (current_expand
.new_head
== NULL
)
1191 current_expand
.new_head
= current_expand
.new_tail
=
1192 gfc_get_constructor ();
1195 current_expand
.new_tail
->next
= gfc_get_constructor ();
1196 current_expand
.new_tail
= current_expand
.new_tail
->next
;
1199 current_expand
.new_tail
->where
= e
->where
;
1200 current_expand
.new_tail
->expr
= e
;
1202 mpz_set (current_expand
.new_tail
->n
.offset
, *current_expand
.offset
);
1203 current_expand
.new_tail
->n
.component
= current_expand
.component
;
1204 mpz_set (current_expand
.new_tail
->repeat
, *current_expand
.repeat
);
1209 /* Given an initialization expression that is a variable reference,
1210 substitute the current value of the iteration variable. */
1213 gfc_simplify_iterator_var (gfc_expr
* e
)
1217 for (p
= iter_stack
; p
; p
= p
->prev
)
1218 if (e
->symtree
== p
->variable
)
1222 return; /* Variable not found */
1224 gfc_replace_expr (e
, gfc_int_expr (0));
1226 mpz_set (e
->value
.integer
, p
->value
);
1232 /* Expand an expression with that is inside of a constructor,
1233 recursing into other constructors if present. */
1236 expand_expr (gfc_expr
* e
)
1239 if (e
->expr_type
== EXPR_ARRAY
)
1240 return expand_constructor (e
->value
.constructor
);
1242 e
= gfc_copy_expr (e
);
1244 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1250 return current_expand
.expand_work_function (e
);
1255 expand_iterator (gfc_constructor
* c
)
1257 gfc_expr
*start
, *end
, *step
;
1258 iterator_stack frame
;
1267 mpz_init (frame
.value
);
1269 start
= gfc_copy_expr (c
->iterator
->start
);
1270 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1273 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1276 end
= gfc_copy_expr (c
->iterator
->end
);
1277 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1280 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1283 step
= gfc_copy_expr (c
->iterator
->step
);
1284 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1287 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1290 if (mpz_sgn (step
->value
.integer
) == 0)
1292 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1296 /* Calculate the trip count of the loop. */
1297 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1298 mpz_add (trip
, trip
, step
->value
.integer
);
1299 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1301 mpz_set (frame
.value
, start
->value
.integer
);
1303 frame
.prev
= iter_stack
;
1304 frame
.variable
= c
->iterator
->var
->symtree
;
1305 iter_stack
= &frame
;
1307 while (mpz_sgn (trip
) > 0)
1309 if (expand_expr (c
->expr
) == FAILURE
)
1312 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1313 mpz_sub_ui (trip
, trip
, 1);
1319 gfc_free_expr (start
);
1320 gfc_free_expr (end
);
1321 gfc_free_expr (step
);
1324 mpz_clear (frame
.value
);
1326 iter_stack
= frame
.prev
;
1332 /* Expand a constructor into constant constructors without any
1333 iterators, calling the work function for each of the expanded
1334 expressions. The work function needs to either save or free the
1335 passed expression. */
1338 expand_constructor (gfc_constructor
* c
)
1342 for (; c
; c
= c
->next
)
1344 if (c
->iterator
!= NULL
)
1346 if (expand_iterator (c
) == FAILURE
)
1353 if (e
->expr_type
== EXPR_ARRAY
)
1355 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1361 e
= gfc_copy_expr (e
);
1362 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1367 current_expand
.offset
= &c
->n
.offset
;
1368 current_expand
.component
= c
->n
.component
;
1369 current_expand
.repeat
= &c
->repeat
;
1370 if (current_expand
.expand_work_function (e
) == FAILURE
)
1377 /* Top level subroutine for expanding constructors. We only expand
1378 constructor if they are small enough. */
1381 gfc_expand_constructor (gfc_expr
* e
)
1383 expand_info expand_save
;
1387 f
= gfc_get_array_element (e
, GFC_MAX_AC_EXPAND
);
1394 expand_save
= current_expand
;
1395 current_expand
.new_head
= current_expand
.new_tail
= NULL
;
1399 current_expand
.expand_work_function
= expand
;
1401 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1403 gfc_free_constructor (current_expand
.new_head
);
1408 gfc_free_constructor (e
->value
.constructor
);
1409 e
->value
.constructor
= current_expand
.new_head
;
1414 current_expand
= expand_save
;
1420 /* Work function for checking that an element of a constructor is a
1421 constant, after removal of any iteration variables. We return
1422 FAILURE if not so. */
1425 constant_element (gfc_expr
* e
)
1429 rv
= gfc_is_constant_expr (e
);
1432 return rv
? SUCCESS
: FAILURE
;
1436 /* Given an array constructor, determine if the constructor is
1437 constant or not by expanding it and making sure that all elements
1438 are constants. This is a bit of a hack since something like (/ (i,
1439 i=1,100000000) /) will take a while as* opposed to a more clever
1440 function that traverses the expression tree. FIXME. */
1443 gfc_constant_ac (gfc_expr
* e
)
1445 expand_info expand_save
;
1449 expand_save
= current_expand
;
1450 current_expand
.expand_work_function
= constant_element
;
1452 rc
= expand_constructor (e
->value
.constructor
);
1454 current_expand
= expand_save
;
1462 /* Returns nonzero if an array constructor has been completely
1463 expanded (no iterators) and zero if iterators are present. */
1466 gfc_expanded_ac (gfc_expr
* e
)
1470 if (e
->expr_type
== EXPR_ARRAY
)
1471 for (p
= e
->value
.constructor
; p
; p
= p
->next
)
1472 if (p
->iterator
!= NULL
|| !gfc_expanded_ac (p
->expr
))
1479 /*************** Type resolution of array constructors ***************/
1481 /* Recursive array list resolution function. All of the elements must
1482 be of the same type. */
1485 resolve_array_list (gfc_constructor
* p
)
1491 for (; p
; p
= p
->next
)
1493 if (p
->iterator
!= NULL
1494 && gfc_resolve_iterator (p
->iterator
) == FAILURE
)
1497 if (gfc_resolve_expr (p
->expr
) == FAILURE
)
1505 /* Resolve all of the expressions in an array list.
1506 TODO: String lengths. */
1509 gfc_resolve_array_constructor (gfc_expr
* expr
)
1513 t
= resolve_array_list (expr
->value
.constructor
);
1515 t
= gfc_check_constructor_type (expr
);
1521 /* Copy an iterator structure. */
1523 static gfc_iterator
*
1524 copy_iterator (gfc_iterator
* src
)
1531 dest
= gfc_get_iterator ();
1533 dest
->var
= gfc_copy_expr (src
->var
);
1534 dest
->start
= gfc_copy_expr (src
->start
);
1535 dest
->end
= gfc_copy_expr (src
->end
);
1536 dest
->step
= gfc_copy_expr (src
->step
);
1542 /* Copy a constructor structure. */
1545 gfc_copy_constructor (gfc_constructor
* src
)
1547 gfc_constructor
*dest
;
1548 gfc_constructor
*tail
;
1557 dest
= tail
= gfc_get_constructor ();
1560 tail
->next
= gfc_get_constructor ();
1563 tail
->where
= src
->where
;
1564 tail
->expr
= gfc_copy_expr (src
->expr
);
1565 tail
->iterator
= copy_iterator (src
->iterator
);
1566 mpz_set (tail
->n
.offset
, src
->n
.offset
);
1567 tail
->n
.component
= src
->n
.component
;
1568 mpz_set (tail
->repeat
, src
->repeat
);
1576 /* Given an array expression and an element number (starting at zero),
1577 return a pointer to the array element. NULL is returned if the
1578 size of the array has been exceeded. The expression node returned
1579 remains a part of the array and should not be freed. Access is not
1580 efficient at all, but this is another place where things do not
1581 have to be particularly fast. */
1584 gfc_get_array_element (gfc_expr
* array
, int element
)
1586 expand_info expand_save
;
1590 expand_save
= current_expand
;
1591 current_expand
.extract_n
= element
;
1592 current_expand
.expand_work_function
= extract_element
;
1593 current_expand
.extracted
= NULL
;
1594 current_expand
.extract_count
= 0;
1598 rc
= expand_constructor (array
->value
.constructor
);
1599 e
= current_expand
.extracted
;
1600 current_expand
= expand_save
;
1609 /********* Subroutines for determining the size of an array *********/
1611 /* These are needed just to accomodate RESHAPE(). There are no
1612 diagnostics here, we just return a negative number if something
1616 /* Get the size of single dimension of an array specification. The
1617 array is guaranteed to be one dimensional. */
1620 spec_dimen_size (gfc_array_spec
* as
, int dimen
, mpz_t
* result
)
1626 if (dimen
< 0 || dimen
> as
->rank
- 1)
1627 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1629 if (as
->type
!= AS_EXPLICIT
1630 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
1631 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1636 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
1637 as
->lower
[dimen
]->value
.integer
);
1639 mpz_add_ui (*result
, *result
, 1);
1646 spec_size (gfc_array_spec
* as
, mpz_t
* result
)
1651 mpz_init_set_ui (*result
, 1);
1653 for (d
= 0; d
< as
->rank
; d
++)
1655 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
1657 mpz_clear (*result
);
1661 mpz_mul (*result
, *result
, size
);
1669 /* Get the number of elements in an array section. */
1672 ref_dimen_size (gfc_array_ref
* ar
, int dimen
, mpz_t
* result
)
1674 mpz_t upper
, lower
, stride
;
1677 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
1678 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1680 switch (ar
->dimen_type
[dimen
])
1684 mpz_set_ui (*result
, 1);
1689 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
1698 if (ar
->start
[dimen
] == NULL
)
1700 if (ar
->as
->lower
[dimen
] == NULL
1701 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1703 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
1707 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1709 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
1712 if (ar
->end
[dimen
] == NULL
)
1714 if (ar
->as
->upper
[dimen
] == NULL
1715 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1717 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
1721 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1723 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
1726 if (ar
->stride
[dimen
] == NULL
)
1727 mpz_set_ui (stride
, 1);
1730 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1732 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
1736 mpz_sub (*result
, upper
, lower
);
1737 mpz_add (*result
, *result
, stride
);
1738 mpz_div (*result
, *result
, stride
);
1740 /* Zero stride caught earlier. */
1741 if (mpz_cmp_ui (*result
, 0) < 0)
1742 mpz_set_ui (*result
, 0);
1752 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1760 ref_size (gfc_array_ref
* ar
, mpz_t
* result
)
1765 mpz_init_set_ui (*result
, 1);
1767 for (d
= 0; d
< ar
->dimen
; d
++)
1769 if (ref_dimen_size (ar
, d
, &size
) == FAILURE
)
1771 mpz_clear (*result
);
1775 mpz_mul (*result
, *result
, size
);
1783 /* Given an array expression and a dimension, figure out how many
1784 elements it has along that dimension. Returns SUCCESS if we were
1785 able to return a result in the 'result' variable, FAILURE
1789 gfc_array_dimen_size (gfc_expr
* array
, int dimen
, mpz_t
* result
)
1794 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
1795 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1797 switch (array
->expr_type
)
1801 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1803 if (ref
->type
!= REF_ARRAY
)
1806 if (ref
->u
.ar
.type
== AR_FULL
)
1807 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
1809 if (ref
->u
.ar
.type
== AR_SECTION
)
1811 for (i
= 0; dimen
>= 0; i
++)
1812 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1815 return ref_dimen_size (&ref
->u
.ar
, i
- 1, result
);
1819 if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
) == FAILURE
)
1825 if (array
->shape
== NULL
) {
1826 /* Expressions with rank > 1 should have "shape" properly set */
1827 if ( array
->rank
!= 1 )
1828 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1829 return gfc_array_size(array
, result
);
1834 if (array
->shape
== NULL
)
1837 mpz_init_set (*result
, array
->shape
[dimen
]);
1846 /* Given an array expression, figure out how many elements are in the
1847 array. Returns SUCCESS if this is possible, and sets the 'result'
1848 variable. Otherwise returns FAILURE. */
1851 gfc_array_size (gfc_expr
* array
, mpz_t
* result
)
1853 expand_info expand_save
;
1858 switch (array
->expr_type
)
1861 flag
= gfc_suppress_error
;
1862 gfc_suppress_error
= 1;
1864 expand_save
= current_expand
;
1866 current_expand
.count
= result
;
1867 mpz_init_set_ui (*result
, 0);
1869 current_expand
.expand_work_function
= count_elements
;
1872 t
= expand_constructor (array
->value
.constructor
);
1873 gfc_suppress_error
= flag
;
1876 mpz_clear (*result
);
1877 current_expand
= expand_save
;
1881 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1883 if (ref
->type
!= REF_ARRAY
)
1886 if (ref
->u
.ar
.type
== AR_FULL
)
1887 return spec_size (ref
->u
.ar
.as
, result
);
1889 if (ref
->u
.ar
.type
== AR_SECTION
)
1890 return ref_size (&ref
->u
.ar
, result
);
1893 return spec_size (array
->symtree
->n
.sym
->as
, result
);
1897 if (array
->rank
== 0 || array
->shape
== NULL
)
1900 mpz_init_set_ui (*result
, 1);
1902 for (i
= 0; i
< array
->rank
; i
++)
1903 mpz_mul (*result
, *result
, array
->shape
[i
]);
1912 /* Given an array reference, return the shape of the reference in an
1913 array of mpz_t integers. */
1916 gfc_array_ref_shape (gfc_array_ref
* ar
, mpz_t
* shape
)
1926 for (; d
< ar
->as
->rank
; d
++)
1927 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
1933 for (i
= 0; i
< ar
->dimen
; i
++)
1935 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
1937 if (ref_dimen_size (ar
, i
, &shape
[d
]) == FAILURE
)
1950 for (d
--; d
>= 0; d
--)
1951 mpz_clear (shape
[d
]);
1957 /* Given an array expression, find the array reference structure that
1958 characterizes the reference. */
1961 gfc_find_array_ref (gfc_expr
* e
)
1965 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1966 if (ref
->type
== REF_ARRAY
1967 && (ref
->u
.ar
.type
== AR_FULL
1968 || ref
->u
.ar
.type
== AR_SECTION
))
1972 gfc_internal_error ("gfc_find_array_ref(): No ref found");