2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, 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 65535
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 %d 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 %d 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
, sym
->name
, 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;
870 const char *end_delim
;
872 if (gfc_match (" (/") == MATCH_NO
)
874 if (gfc_match (" [") == MATCH_NO
)
878 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: [...] "
879 "style array constructors at %C") == FAILURE
)
887 where
= gfc_current_locus
;
890 if (gfc_match (end_delim
) == MATCH_YES
)
892 gfc_error ("Empty array constructor at %C is not allowed");
898 m
= match_array_cons_element (&new);
899 if (m
== MATCH_ERROR
)
911 if (gfc_match_char (',') == MATCH_NO
)
915 if (gfc_match (end_delim
) == MATCH_NO
)
918 expr
= gfc_get_expr ();
920 expr
->expr_type
= EXPR_ARRAY
;
922 expr
->value
.constructor
= head
;
923 /* Size must be calculated at resolution time. */
932 gfc_error ("Syntax error in array constructor at %C");
935 gfc_free_constructor (head
);
941 /************** Check array constructors for correctness **************/
943 /* Given an expression, compare it's type with the type of the current
944 constructor. Returns nonzero if an error was issued. The
945 cons_state variable keeps track of whether the type of the
946 constructor being read or resolved is known to be good, bad or just
949 static gfc_typespec constructor_ts
;
951 { CONS_START
, CONS_GOOD
, CONS_BAD
}
955 check_element_type (gfc_expr
* expr
)
958 if (cons_state
== CONS_BAD
)
959 return 0; /* Suppress further errors */
961 if (cons_state
== CONS_START
)
963 if (expr
->ts
.type
== BT_UNKNOWN
)
964 cons_state
= CONS_BAD
;
967 cons_state
= CONS_GOOD
;
968 constructor_ts
= expr
->ts
;
974 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
977 gfc_error ("Element in %s array constructor at %L is %s",
978 gfc_typename (&constructor_ts
), &expr
->where
,
979 gfc_typename (&expr
->ts
));
981 cons_state
= CONS_BAD
;
986 /* Recursive work function for gfc_check_constructor_type(). */
989 check_constructor_type (gfc_constructor
* c
)
993 for (; c
; c
= c
->next
)
997 if (e
->expr_type
== EXPR_ARRAY
)
999 if (check_constructor_type (e
->value
.constructor
) == FAILURE
)
1005 if (check_element_type (e
))
1013 /* Check that all elements of an array constructor are the same type.
1014 On FAILURE, an error has been generated. */
1017 gfc_check_constructor_type (gfc_expr
* e
)
1021 cons_state
= CONS_START
;
1022 gfc_clear_ts (&constructor_ts
);
1024 t
= check_constructor_type (e
->value
.constructor
);
1025 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1026 e
->ts
= constructor_ts
;
1033 typedef struct cons_stack
1035 gfc_iterator
*iterator
;
1036 struct cons_stack
*previous
;
1040 static cons_stack
*base
;
1042 static try check_constructor (gfc_constructor
*, try (*)(gfc_expr
*));
1044 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1045 that that variable is an iteration variables. */
1048 gfc_check_iter_variable (gfc_expr
* expr
)
1054 sym
= expr
->symtree
->n
.sym
;
1056 for (c
= base
; c
; c
= c
->previous
)
1057 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1064 /* Recursive work function for gfc_check_constructor(). This amounts
1065 to calling the check function for each expression in the
1066 constructor, giving variables with the names of iterators a pass. */
1069 check_constructor (gfc_constructor
* c
, try (*check_function
) (gfc_expr
*))
1075 for (; c
; c
= c
->next
)
1079 if (e
->expr_type
!= EXPR_ARRAY
)
1081 if ((*check_function
) (e
) == FAILURE
)
1086 element
.previous
= base
;
1087 element
.iterator
= c
->iterator
;
1090 t
= check_constructor (e
->value
.constructor
, check_function
);
1091 base
= element
.previous
;
1097 /* Nothing went wrong, so all OK. */
1102 /* Checks a constructor to see if it is a particular kind of
1103 expression -- specification, restricted, or initialization as
1104 determined by the check_function. */
1107 gfc_check_constructor (gfc_expr
* expr
, try (*check_function
) (gfc_expr
*))
1109 cons_stack
*base_save
;
1115 t
= check_constructor (expr
->value
.constructor
, check_function
);
1123 /**************** Simplification of array constructors ****************/
1125 iterator_stack
*iter_stack
;
1129 gfc_constructor
*new_head
, *new_tail
;
1130 int extract_count
, extract_n
;
1131 gfc_expr
*extracted
;
1135 gfc_component
*component
;
1138 try (*expand_work_function
) (gfc_expr
*);
1142 static expand_info current_expand
;
1144 static try expand_constructor (gfc_constructor
*);
1147 /* Work function that counts the number of elements present in a
1151 count_elements (gfc_expr
* e
)
1156 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1159 if (gfc_array_size (e
, &result
) == FAILURE
)
1165 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1174 /* Work function that extracts a particular element from an array
1175 constructor, freeing the rest. */
1178 extract_element (gfc_expr
* e
)
1182 { /* Something unextractable */
1187 if (current_expand
.extract_count
== current_expand
.extract_n
)
1188 current_expand
.extracted
= e
;
1192 current_expand
.extract_count
++;
1197 /* Work function that constructs a new constructor out of the old one,
1198 stringing new elements together. */
1201 expand (gfc_expr
* e
)
1204 if (current_expand
.new_head
== NULL
)
1205 current_expand
.new_head
= current_expand
.new_tail
=
1206 gfc_get_constructor ();
1209 current_expand
.new_tail
->next
= gfc_get_constructor ();
1210 current_expand
.new_tail
= current_expand
.new_tail
->next
;
1213 current_expand
.new_tail
->where
= e
->where
;
1214 current_expand
.new_tail
->expr
= e
;
1216 mpz_set (current_expand
.new_tail
->n
.offset
, *current_expand
.offset
);
1217 current_expand
.new_tail
->n
.component
= current_expand
.component
;
1218 mpz_set (current_expand
.new_tail
->repeat
, *current_expand
.repeat
);
1223 /* Given an initialization expression that is a variable reference,
1224 substitute the current value of the iteration variable. */
1227 gfc_simplify_iterator_var (gfc_expr
* e
)
1231 for (p
= iter_stack
; p
; p
= p
->prev
)
1232 if (e
->symtree
== p
->variable
)
1236 return; /* Variable not found */
1238 gfc_replace_expr (e
, gfc_int_expr (0));
1240 mpz_set (e
->value
.integer
, p
->value
);
1246 /* Expand an expression with that is inside of a constructor,
1247 recursing into other constructors if present. */
1250 expand_expr (gfc_expr
* e
)
1253 if (e
->expr_type
== EXPR_ARRAY
)
1254 return expand_constructor (e
->value
.constructor
);
1256 e
= gfc_copy_expr (e
);
1258 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1264 return current_expand
.expand_work_function (e
);
1269 expand_iterator (gfc_constructor
* c
)
1271 gfc_expr
*start
, *end
, *step
;
1272 iterator_stack frame
;
1281 mpz_init (frame
.value
);
1283 start
= gfc_copy_expr (c
->iterator
->start
);
1284 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1287 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1290 end
= gfc_copy_expr (c
->iterator
->end
);
1291 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1294 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1297 step
= gfc_copy_expr (c
->iterator
->step
);
1298 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1301 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1304 if (mpz_sgn (step
->value
.integer
) == 0)
1306 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1310 /* Calculate the trip count of the loop. */
1311 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1312 mpz_add (trip
, trip
, step
->value
.integer
);
1313 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1315 mpz_set (frame
.value
, start
->value
.integer
);
1317 frame
.prev
= iter_stack
;
1318 frame
.variable
= c
->iterator
->var
->symtree
;
1319 iter_stack
= &frame
;
1321 while (mpz_sgn (trip
) > 0)
1323 if (expand_expr (c
->expr
) == FAILURE
)
1326 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1327 mpz_sub_ui (trip
, trip
, 1);
1333 gfc_free_expr (start
);
1334 gfc_free_expr (end
);
1335 gfc_free_expr (step
);
1338 mpz_clear (frame
.value
);
1340 iter_stack
= frame
.prev
;
1346 /* Expand a constructor into constant constructors without any
1347 iterators, calling the work function for each of the expanded
1348 expressions. The work function needs to either save or free the
1349 passed expression. */
1352 expand_constructor (gfc_constructor
* c
)
1356 for (; c
; c
= c
->next
)
1358 if (c
->iterator
!= NULL
)
1360 if (expand_iterator (c
) == FAILURE
)
1367 if (e
->expr_type
== EXPR_ARRAY
)
1369 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1375 e
= gfc_copy_expr (e
);
1376 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1381 current_expand
.offset
= &c
->n
.offset
;
1382 current_expand
.component
= c
->n
.component
;
1383 current_expand
.repeat
= &c
->repeat
;
1384 if (current_expand
.expand_work_function (e
) == FAILURE
)
1391 /* Top level subroutine for expanding constructors. We only expand
1392 constructor if they are small enough. */
1395 gfc_expand_constructor (gfc_expr
* e
)
1397 expand_info expand_save
;
1401 f
= gfc_get_array_element (e
, GFC_MAX_AC_EXPAND
);
1408 expand_save
= current_expand
;
1409 current_expand
.new_head
= current_expand
.new_tail
= NULL
;
1413 current_expand
.expand_work_function
= expand
;
1415 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1417 gfc_free_constructor (current_expand
.new_head
);
1422 gfc_free_constructor (e
->value
.constructor
);
1423 e
->value
.constructor
= current_expand
.new_head
;
1428 current_expand
= expand_save
;
1434 /* Work function for checking that an element of a constructor is a
1435 constant, after removal of any iteration variables. We return
1436 FAILURE if not so. */
1439 constant_element (gfc_expr
* e
)
1443 rv
= gfc_is_constant_expr (e
);
1446 return rv
? SUCCESS
: FAILURE
;
1450 /* Given an array constructor, determine if the constructor is
1451 constant or not by expanding it and making sure that all elements
1452 are constants. This is a bit of a hack since something like (/ (i,
1453 i=1,100000000) /) will take a while as* opposed to a more clever
1454 function that traverses the expression tree. FIXME. */
1457 gfc_constant_ac (gfc_expr
* e
)
1459 expand_info expand_save
;
1463 expand_save
= current_expand
;
1464 current_expand
.expand_work_function
= constant_element
;
1466 rc
= expand_constructor (e
->value
.constructor
);
1468 current_expand
= expand_save
;
1476 /* Returns nonzero if an array constructor has been completely
1477 expanded (no iterators) and zero if iterators are present. */
1480 gfc_expanded_ac (gfc_expr
* e
)
1484 if (e
->expr_type
== EXPR_ARRAY
)
1485 for (p
= e
->value
.constructor
; p
; p
= p
->next
)
1486 if (p
->iterator
!= NULL
|| !gfc_expanded_ac (p
->expr
))
1493 /*************** Type resolution of array constructors ***************/
1495 /* Recursive array list resolution function. All of the elements must
1496 be of the same type. */
1499 resolve_array_list (gfc_constructor
* p
)
1505 for (; p
; p
= p
->next
)
1507 if (p
->iterator
!= NULL
1508 && gfc_resolve_iterator (p
->iterator
, false) == FAILURE
)
1511 if (gfc_resolve_expr (p
->expr
) == FAILURE
)
1518 /* Resolve character array constructor. If it is a constant character array and
1519 not specified character length, update character length to the maximum of
1520 its element constructors' length. */
1523 gfc_resolve_character_array_constructor (gfc_expr
* expr
)
1525 gfc_constructor
* p
;
1528 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1529 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1533 if (expr
->ts
.cl
== NULL
)
1535 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1536 if (p
->expr
->ts
.cl
!= NULL
)
1538 /* Ensure that if there is a char_len around that it is
1539 used; otherwise the middle-end confuses them! */
1540 expr
->ts
.cl
= p
->expr
->ts
.cl
;
1544 expr
->ts
.cl
= gfc_get_charlen ();
1545 expr
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1546 gfc_current_ns
->cl_list
= expr
->ts
.cl
;
1551 if (expr
->ts
.cl
->length
== NULL
)
1553 /* Find the maximum length of the elements. Do nothing for variable array
1554 constructor, unless the character length is constant or there is a
1555 constant substring reference. */
1557 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1560 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1561 if (ref
->type
== REF_SUBSTRING
1562 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1563 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1566 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1567 max_length
= MAX (p
->expr
->value
.character
.length
, max_length
);
1570 max_length
= MAX ((int)(mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1571 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
))
1574 else if (p
->expr
->ts
.cl
&& p
->expr
->ts
.cl
->length
1575 && p
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1576 max_length
= MAX ((int)mpz_get_si (p
->expr
->ts
.cl
->length
->value
.integer
),
1583 if (max_length
!= -1)
1585 /* Update the character length of the array constructor. */
1586 expr
->ts
.cl
->length
= gfc_int_expr (max_length
);
1587 /* Update the element constructors. */
1588 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1589 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1590 gfc_set_constant_character_len (max_length
, p
->expr
);
1595 /* Resolve all of the expressions in an array list. */
1598 gfc_resolve_array_constructor (gfc_expr
* expr
)
1602 t
= resolve_array_list (expr
->value
.constructor
);
1604 t
= gfc_check_constructor_type (expr
);
1605 if (t
== SUCCESS
&& expr
->ts
.type
== BT_CHARACTER
)
1606 gfc_resolve_character_array_constructor (expr
);
1612 /* Copy an iterator structure. */
1614 static gfc_iterator
*
1615 copy_iterator (gfc_iterator
* src
)
1622 dest
= gfc_get_iterator ();
1624 dest
->var
= gfc_copy_expr (src
->var
);
1625 dest
->start
= gfc_copy_expr (src
->start
);
1626 dest
->end
= gfc_copy_expr (src
->end
);
1627 dest
->step
= gfc_copy_expr (src
->step
);
1633 /* Copy a constructor structure. */
1636 gfc_copy_constructor (gfc_constructor
* src
)
1638 gfc_constructor
*dest
;
1639 gfc_constructor
*tail
;
1648 dest
= tail
= gfc_get_constructor ();
1651 tail
->next
= gfc_get_constructor ();
1654 tail
->where
= src
->where
;
1655 tail
->expr
= gfc_copy_expr (src
->expr
);
1656 tail
->iterator
= copy_iterator (src
->iterator
);
1657 mpz_set (tail
->n
.offset
, src
->n
.offset
);
1658 tail
->n
.component
= src
->n
.component
;
1659 mpz_set (tail
->repeat
, src
->repeat
);
1667 /* Given an array expression and an element number (starting at zero),
1668 return a pointer to the array element. NULL is returned if the
1669 size of the array has been exceeded. The expression node returned
1670 remains a part of the array and should not be freed. Access is not
1671 efficient at all, but this is another place where things do not
1672 have to be particularly fast. */
1675 gfc_get_array_element (gfc_expr
* array
, int element
)
1677 expand_info expand_save
;
1681 expand_save
= current_expand
;
1682 current_expand
.extract_n
= element
;
1683 current_expand
.expand_work_function
= extract_element
;
1684 current_expand
.extracted
= NULL
;
1685 current_expand
.extract_count
= 0;
1689 rc
= expand_constructor (array
->value
.constructor
);
1690 e
= current_expand
.extracted
;
1691 current_expand
= expand_save
;
1700 /********* Subroutines for determining the size of an array *********/
1702 /* These are needed just to accommodate RESHAPE(). There are no
1703 diagnostics here, we just return a negative number if something
1707 /* Get the size of single dimension of an array specification. The
1708 array is guaranteed to be one dimensional. */
1711 spec_dimen_size (gfc_array_spec
* as
, int dimen
, mpz_t
* result
)
1717 if (dimen
< 0 || dimen
> as
->rank
- 1)
1718 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1720 if (as
->type
!= AS_EXPLICIT
1721 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
1722 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1727 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
1728 as
->lower
[dimen
]->value
.integer
);
1730 mpz_add_ui (*result
, *result
, 1);
1737 spec_size (gfc_array_spec
* as
, mpz_t
* result
)
1742 mpz_init_set_ui (*result
, 1);
1744 for (d
= 0; d
< as
->rank
; d
++)
1746 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
1748 mpz_clear (*result
);
1752 mpz_mul (*result
, *result
, size
);
1760 /* Get the number of elements in an array section. */
1763 ref_dimen_size (gfc_array_ref
* ar
, int dimen
, mpz_t
* result
)
1765 mpz_t upper
, lower
, stride
;
1768 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
1769 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1771 switch (ar
->dimen_type
[dimen
])
1775 mpz_set_ui (*result
, 1);
1780 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
1789 if (ar
->start
[dimen
] == NULL
)
1791 if (ar
->as
->lower
[dimen
] == NULL
1792 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1794 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
1798 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1800 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
1803 if (ar
->end
[dimen
] == NULL
)
1805 if (ar
->as
->upper
[dimen
] == NULL
1806 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1808 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
1812 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1814 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
1817 if (ar
->stride
[dimen
] == NULL
)
1818 mpz_set_ui (stride
, 1);
1821 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1823 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
1827 mpz_sub (*result
, upper
, lower
);
1828 mpz_add (*result
, *result
, stride
);
1829 mpz_div (*result
, *result
, stride
);
1831 /* Zero stride caught earlier. */
1832 if (mpz_cmp_ui (*result
, 0) < 0)
1833 mpz_set_ui (*result
, 0);
1843 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1851 ref_size (gfc_array_ref
* ar
, mpz_t
* result
)
1856 mpz_init_set_ui (*result
, 1);
1858 for (d
= 0; d
< ar
->dimen
; d
++)
1860 if (ref_dimen_size (ar
, d
, &size
) == FAILURE
)
1862 mpz_clear (*result
);
1866 mpz_mul (*result
, *result
, size
);
1874 /* Given an array expression and a dimension, figure out how many
1875 elements it has along that dimension. Returns SUCCESS if we were
1876 able to return a result in the 'result' variable, FAILURE
1880 gfc_array_dimen_size (gfc_expr
* array
, int dimen
, mpz_t
* result
)
1885 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
1886 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1888 switch (array
->expr_type
)
1892 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1894 if (ref
->type
!= REF_ARRAY
)
1897 if (ref
->u
.ar
.type
== AR_FULL
)
1898 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
1900 if (ref
->u
.ar
.type
== AR_SECTION
)
1902 for (i
= 0; dimen
>= 0; i
++)
1903 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1906 return ref_dimen_size (&ref
->u
.ar
, i
- 1, result
);
1910 if (array
->shape
&& array
->shape
[dimen
])
1912 mpz_init_set (*result
, array
->shape
[dimen
]);
1916 if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
) == FAILURE
)
1922 if (array
->shape
== NULL
) {
1923 /* Expressions with rank > 1 should have "shape" properly set */
1924 if ( array
->rank
!= 1 )
1925 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1926 return gfc_array_size(array
, result
);
1931 if (array
->shape
== NULL
)
1934 mpz_init_set (*result
, array
->shape
[dimen
]);
1943 /* Given an array expression, figure out how many elements are in the
1944 array. Returns SUCCESS if this is possible, and sets the 'result'
1945 variable. Otherwise returns FAILURE. */
1948 gfc_array_size (gfc_expr
* array
, mpz_t
* result
)
1950 expand_info expand_save
;
1955 switch (array
->expr_type
)
1958 flag
= gfc_suppress_error
;
1959 gfc_suppress_error
= 1;
1961 expand_save
= current_expand
;
1963 current_expand
.count
= result
;
1964 mpz_init_set_ui (*result
, 0);
1966 current_expand
.expand_work_function
= count_elements
;
1969 t
= expand_constructor (array
->value
.constructor
);
1970 gfc_suppress_error
= flag
;
1973 mpz_clear (*result
);
1974 current_expand
= expand_save
;
1978 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1980 if (ref
->type
!= REF_ARRAY
)
1983 if (ref
->u
.ar
.type
== AR_FULL
)
1984 return spec_size (ref
->u
.ar
.as
, result
);
1986 if (ref
->u
.ar
.type
== AR_SECTION
)
1987 return ref_size (&ref
->u
.ar
, result
);
1990 return spec_size (array
->symtree
->n
.sym
->as
, result
);
1994 if (array
->rank
== 0 || array
->shape
== NULL
)
1997 mpz_init_set_ui (*result
, 1);
1999 for (i
= 0; i
< array
->rank
; i
++)
2000 mpz_mul (*result
, *result
, array
->shape
[i
]);
2009 /* Given an array reference, return the shape of the reference in an
2010 array of mpz_t integers. */
2013 gfc_array_ref_shape (gfc_array_ref
* ar
, mpz_t
* shape
)
2023 for (; d
< ar
->as
->rank
; d
++)
2024 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
2030 for (i
= 0; i
< ar
->dimen
; i
++)
2032 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2034 if (ref_dimen_size (ar
, i
, &shape
[d
]) == FAILURE
)
2047 for (d
--; d
>= 0; d
--)
2048 mpz_clear (shape
[d
]);
2054 /* Given an array expression, find the array reference structure that
2055 characterizes the reference. */
2058 gfc_find_array_ref (gfc_expr
* e
)
2062 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2063 if (ref
->type
== REF_ARRAY
2064 && (ref
->u
.ar
.type
== AR_FULL
2065 || ref
->u
.ar
.type
== AR_SECTION
))
2069 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2075 /* Find out if an array shape is known at compile time. */
2078 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2082 if (as
->type
!= AS_EXPLICIT
)
2085 for (i
= 0; i
< as
->rank
; i
++)
2086 if (!gfc_is_constant_expr (as
->lower
[i
])
2087 || !gfc_is_constant_expr (as
->upper
[i
]))