2 Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
27 /* This parameter is the size of the largest array constructor that we
28 will expand to an array constructor without iterators.
29 Constructors larger than this will remain in the iterator form. */
31 #define GFC_MAX_AC_EXPAND 65535
34 /**************** Array reference matching subroutines *****************/
36 /* Copy an array reference structure. */
39 gfc_copy_array_ref (gfc_array_ref
* src
)
47 dest
= gfc_get_array_ref ();
51 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
53 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
54 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
55 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
58 dest
->offset
= gfc_copy_expr (src
->offset
);
64 /* Match a single dimension of an array reference. This can be a
65 single element or an array section. Any modifications we've made
66 to the ar structure are cleaned up by the caller. If the init
67 is set, we require the subscript to be a valid initialization
71 match_subscript (gfc_array_ref
* ar
, int init
)
78 ar
->c_where
[i
] = gfc_current_locus
;
79 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
81 /* We can't be sure of the difference between DIMEN_ELEMENT and
82 DIMEN_VECTOR until we know the type of the element itself at
85 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
87 if (gfc_match_char (':') == MATCH_YES
)
90 /* Get start element. */
92 m
= gfc_match_init_expr (&ar
->start
[i
]);
94 m
= gfc_match_expr (&ar
->start
[i
]);
97 gfc_error ("Expected array subscript at %C");
101 if (gfc_match_char (':') == MATCH_NO
)
104 /* Get an optional end element. Because we've seen the colon, we
105 definitely have a range along this dimension. */
107 ar
->dimen_type
[i
] = DIMEN_RANGE
;
110 m
= gfc_match_init_expr (&ar
->end
[i
]);
112 m
= gfc_match_expr (&ar
->end
[i
]);
114 if (m
== MATCH_ERROR
)
117 /* See if we have an optional stride. */
118 if (gfc_match_char (':') == MATCH_YES
)
120 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
121 : gfc_match_expr (&ar
->stride
[i
]);
124 gfc_error ("Expected array subscript stride at %C");
133 /* Match an array reference, whether it is the whole array or a
134 particular elements or a section. If init is set, the reference has
135 to consist of init expressions. */
138 gfc_match_array_ref (gfc_array_ref
* ar
, gfc_array_spec
* as
, int init
)
142 memset (ar
, '\0', sizeof (ar
));
144 ar
->where
= gfc_current_locus
;
147 if (gfc_match_char ('(') != MATCH_YES
)
154 ar
->type
= AR_UNKNOWN
;
156 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
158 m
= match_subscript (ar
, init
);
159 if (m
== MATCH_ERROR
)
162 if (gfc_match_char (')') == MATCH_YES
)
165 if (gfc_match_char (',') != MATCH_YES
)
167 gfc_error ("Invalid form of array reference at %C");
172 gfc_error ("Array reference at %C cannot have more than %d dimensions",
185 /************** Array specification matching subroutines ***************/
187 /* Free all of the expressions associated with array bounds
191 gfc_free_array_spec (gfc_array_spec
* as
)
198 for (i
= 0; i
< as
->rank
; i
++)
200 gfc_free_expr (as
->lower
[i
]);
201 gfc_free_expr (as
->upper
[i
]);
208 /* Take an array bound, resolves the expression, that make up the
209 shape and check associated constraints. */
212 resolve_array_bound (gfc_expr
* e
, int check_constant
)
218 if (gfc_resolve_expr (e
) == FAILURE
219 || gfc_specification_expr (e
) == FAILURE
)
222 if (check_constant
&& gfc_is_constant_expr (e
) == 0)
224 gfc_error ("Variable '%s' at %L in this context must be constant",
225 e
->symtree
->n
.sym
->name
, &e
->where
);
233 /* Takes an array specification, resolves the expressions that make up
234 the shape and make sure everything is integral. */
237 gfc_resolve_array_spec (gfc_array_spec
* as
, int check_constant
)
245 for (i
= 0; i
< as
->rank
; i
++)
248 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
252 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
260 /* Match a single array element specification. The return values as
261 well as the upper and lower bounds of the array spec are filled
262 in according to what we see on the input. The caller makes sure
263 individual specifications make sense as a whole.
266 Parsed Lower Upper Returned
267 ------------------------------------
268 : NULL NULL AS_DEFERRED (*)
270 x: x NULL AS_ASSUMED_SHAPE
272 x:* x NULL AS_ASSUMED_SIZE
273 * 1 NULL AS_ASSUMED_SIZE
275 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
276 is fixed during the resolution of formal interfaces.
278 Anything else AS_UNKNOWN. */
281 match_array_element_spec (gfc_array_spec
* as
)
283 gfc_expr
**upper
, **lower
;
286 lower
= &as
->lower
[as
->rank
- 1];
287 upper
= &as
->upper
[as
->rank
- 1];
289 if (gfc_match_char ('*') == MATCH_YES
)
291 *lower
= gfc_int_expr (1);
292 return AS_ASSUMED_SIZE
;
295 if (gfc_match_char (':') == MATCH_YES
)
298 m
= gfc_match_expr (upper
);
300 gfc_error ("Expected expression in array specification at %C");
304 if (gfc_match_char (':') == MATCH_NO
)
306 *lower
= gfc_int_expr (1);
313 if (gfc_match_char ('*') == MATCH_YES
)
314 return AS_ASSUMED_SIZE
;
316 m
= gfc_match_expr (upper
);
317 if (m
== MATCH_ERROR
)
320 return AS_ASSUMED_SHAPE
;
326 /* Matches an array specification, incidentally figuring out what sort
330 gfc_match_array_spec (gfc_array_spec
** asp
)
332 array_type current_type
;
336 if (gfc_match_char ('(') != MATCH_YES
)
342 as
= gfc_get_array_spec ();
344 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
354 current_type
= match_array_element_spec (as
);
358 if (current_type
== AS_UNKNOWN
)
360 as
->type
= current_type
;
364 { /* See how current spec meshes with the existing */
369 if (current_type
== AS_ASSUMED_SIZE
)
371 as
->type
= AS_ASSUMED_SIZE
;
375 if (current_type
== AS_EXPLICIT
)
379 ("Bad array specification for an explicitly shaped array"
384 case AS_ASSUMED_SHAPE
:
385 if ((current_type
== AS_ASSUMED_SHAPE
)
386 || (current_type
== AS_DEFERRED
))
390 ("Bad array specification for assumed shape array at %C");
394 if (current_type
== AS_DEFERRED
)
397 if (current_type
== AS_ASSUMED_SHAPE
)
399 as
->type
= AS_ASSUMED_SHAPE
;
403 gfc_error ("Bad specification for deferred shape array at %C");
406 case AS_ASSUMED_SIZE
:
407 gfc_error ("Bad specification for assumed size array at %C");
411 if (gfc_match_char (')') == MATCH_YES
)
414 if (gfc_match_char (',') != MATCH_YES
)
416 gfc_error ("Expected another dimension in array declaration at %C");
420 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
422 gfc_error ("Array specification at %C has more than %d dimensions",
430 /* If a lower bounds of an assumed shape array is blank, put in one. */
431 if (as
->type
== AS_ASSUMED_SHAPE
)
433 for (i
= 0; i
< as
->rank
; i
++)
435 if (as
->lower
[i
] == NULL
)
436 as
->lower
[i
] = gfc_int_expr (1);
443 /* Something went wrong. */
444 gfc_free_array_spec (as
);
449 /* Given a symbol and an array specification, modify the symbol to
450 have that array specification. The error locus is needed in case
451 something goes wrong. On failure, the caller must free the spec. */
454 gfc_set_array_spec (gfc_symbol
* sym
, gfc_array_spec
* as
, locus
* error_loc
)
460 if (gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
469 /* Copy an array specification. */
472 gfc_copy_array_spec (gfc_array_spec
* src
)
474 gfc_array_spec
*dest
;
480 dest
= gfc_get_array_spec ();
484 for (i
= 0; i
< dest
->rank
; i
++)
486 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
487 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
493 /* Returns nonzero if the two expressions are equal. Only handles integer
497 compare_bounds (gfc_expr
* bound1
, gfc_expr
* bound2
)
499 if (bound1
== NULL
|| bound2
== NULL
500 || bound1
->expr_type
!= EXPR_CONSTANT
501 || bound2
->expr_type
!= EXPR_CONSTANT
502 || bound1
->ts
.type
!= BT_INTEGER
503 || bound2
->ts
.type
!= BT_INTEGER
)
504 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
506 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
512 /* Compares two array specifications. They must be constant or deferred
516 gfc_compare_array_spec (gfc_array_spec
* as1
, gfc_array_spec
* as2
)
520 if (as1
== NULL
&& as2
== NULL
)
523 if (as1
== NULL
|| as2
== NULL
)
526 if (as1
->rank
!= as2
->rank
)
532 if (as1
->type
!= as2
->type
)
535 if (as1
->type
== AS_EXPLICIT
)
536 for (i
= 0; i
< as1
->rank
; i
++)
538 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
541 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
549 /****************** Array constructor functions ******************/
551 /* Start an array constructor. The constructor starts with zero
552 elements and should be appended to by gfc_append_constructor(). */
555 gfc_start_constructor (bt type
, int kind
, locus
* where
)
559 result
= gfc_get_expr ();
561 result
->expr_type
= EXPR_ARRAY
;
564 result
->ts
.type
= type
;
565 result
->ts
.kind
= kind
;
566 result
->where
= *where
;
571 /* Given an array constructor expression, append the new expression
572 node onto the constructor. */
575 gfc_append_constructor (gfc_expr
* base
, gfc_expr
* new)
579 if (base
->value
.constructor
== NULL
)
580 base
->value
.constructor
= c
= gfc_get_constructor ();
583 c
= base
->value
.constructor
;
587 c
->next
= gfc_get_constructor ();
593 if (new->ts
.type
!= base
->ts
.type
|| new->ts
.kind
!= base
->ts
.kind
)
594 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
598 /* Given an array constructor expression, insert the new expression's
599 constructor onto the base's one according to the offset. */
602 gfc_insert_constructor (gfc_expr
* base
, gfc_constructor
* c1
)
604 gfc_constructor
*c
, *pre
;
608 type
= base
->expr_type
;
610 if (base
->value
.constructor
== NULL
)
611 base
->value
.constructor
= c1
;
614 c
= pre
= base
->value
.constructor
;
617 if (type
== EXPR_ARRAY
)
619 t
= mpz_cmp (c
->n
.offset
, c1
->n
.offset
);
627 gfc_error ("duplicated initializer");
648 base
->value
.constructor
= c1
;
654 /* Get a new constructor. */
657 gfc_get_constructor (void)
661 c
= gfc_getmem (sizeof(gfc_constructor
));
665 mpz_init_set_si (c
->n
.offset
, 0);
666 mpz_init_set_si (c
->repeat
, 0);
671 /* Free chains of gfc_constructor structures. */
674 gfc_free_constructor (gfc_constructor
* p
)
676 gfc_constructor
*next
;
686 gfc_free_expr (p
->expr
);
687 if (p
->iterator
!= NULL
)
688 gfc_free_iterator (p
->iterator
, 1);
689 mpz_clear (p
->n
.offset
);
690 mpz_clear (p
->repeat
);
696 /* Given an expression node that might be an array constructor and a
697 symbol, make sure that no iterators in this or child constructors
698 use the symbol as an implied-DO iterator. Returns nonzero if a
699 duplicate was found. */
702 check_duplicate_iterator (gfc_constructor
* c
, gfc_symbol
* master
)
706 for (; c
; c
= c
->next
)
710 if (e
->expr_type
== EXPR_ARRAY
711 && check_duplicate_iterator (e
->value
.constructor
, master
))
714 if (c
->iterator
== NULL
)
717 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
720 ("DO-iterator '%s' at %L is inside iterator of the same name",
721 master
->name
, &c
->where
);
731 /* Forward declaration because these functions are mutually recursive. */
732 static match
match_array_cons_element (gfc_constructor
**);
734 /* Match a list of array elements. */
737 match_array_list (gfc_constructor
** result
)
739 gfc_constructor
*p
, *head
, *tail
, *new;
746 old_loc
= gfc_current_locus
;
748 if (gfc_match_char ('(') == MATCH_NO
)
751 memset (&iter
, '\0', sizeof (gfc_iterator
));
754 m
= match_array_cons_element (&head
);
760 if (gfc_match_char (',') != MATCH_YES
)
768 m
= gfc_match_iterator (&iter
, 0);
771 if (m
== MATCH_ERROR
)
774 m
= match_array_cons_element (&new);
775 if (m
== MATCH_ERROR
)
782 goto cleanup
; /* Could be a complex constant */
788 if (gfc_match_char (',') != MATCH_YES
)
797 if (gfc_match_char (')') != MATCH_YES
)
800 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
807 e
->expr_type
= EXPR_ARRAY
;
809 e
->value
.constructor
= head
;
811 p
= gfc_get_constructor ();
812 p
->where
= gfc_current_locus
;
813 p
->iterator
= gfc_get_iterator ();
822 gfc_error ("Syntax error in array constructor at %C");
826 gfc_free_constructor (head
);
827 gfc_free_iterator (&iter
, 0);
828 gfc_current_locus
= old_loc
;
833 /* Match a single element of an array constructor, which can be a
834 single expression or a list of elements. */
837 match_array_cons_element (gfc_constructor
** result
)
843 m
= match_array_list (result
);
847 m
= gfc_match_expr (&expr
);
851 p
= gfc_get_constructor ();
852 p
->where
= gfc_current_locus
;
860 /* Match an array constructor. */
863 gfc_match_array_constructor (gfc_expr
** result
)
865 gfc_constructor
*head
, *tail
, *new;
869 const char *end_delim
;
871 if (gfc_match (" (/") == MATCH_NO
)
873 if (gfc_match (" [") == MATCH_NO
)
877 if (gfc_notify_std (GFC_STD_F2003
, "New in Fortran 2003: [...] "
878 "style array constructors at %C") == FAILURE
)
886 where
= gfc_current_locus
;
889 if (gfc_match (end_delim
) == MATCH_YES
)
891 gfc_error ("Empty array constructor at %C is not allowed");
897 m
= match_array_cons_element (&new);
898 if (m
== MATCH_ERROR
)
910 if (gfc_match_char (',') == MATCH_NO
)
914 if (gfc_match (end_delim
) == MATCH_NO
)
917 expr
= gfc_get_expr ();
919 expr
->expr_type
= EXPR_ARRAY
;
921 expr
->value
.constructor
= head
;
922 /* Size must be calculated at resolution time. */
931 gfc_error ("Syntax error in array constructor at %C");
934 gfc_free_constructor (head
);
940 /************** Check array constructors for correctness **************/
942 /* Given an expression, compare it's type with the type of the current
943 constructor. Returns nonzero if an error was issued. The
944 cons_state variable keeps track of whether the type of the
945 constructor being read or resolved is known to be good, bad or just
948 static gfc_typespec constructor_ts
;
950 { CONS_START
, CONS_GOOD
, CONS_BAD
}
954 check_element_type (gfc_expr
* expr
)
957 if (cons_state
== CONS_BAD
)
958 return 0; /* Suppress further errors */
960 if (cons_state
== CONS_START
)
962 if (expr
->ts
.type
== BT_UNKNOWN
)
963 cons_state
= CONS_BAD
;
966 cons_state
= CONS_GOOD
;
967 constructor_ts
= expr
->ts
;
973 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
976 gfc_error ("Element in %s array constructor at %L is %s",
977 gfc_typename (&constructor_ts
), &expr
->where
,
978 gfc_typename (&expr
->ts
));
980 cons_state
= CONS_BAD
;
985 /* Recursive work function for gfc_check_constructor_type(). */
988 check_constructor_type (gfc_constructor
* c
)
992 for (; c
; c
= c
->next
)
996 if (e
->expr_type
== EXPR_ARRAY
)
998 if (check_constructor_type (e
->value
.constructor
) == FAILURE
)
1004 if (check_element_type (e
))
1012 /* Check that all elements of an array constructor are the same type.
1013 On FAILURE, an error has been generated. */
1016 gfc_check_constructor_type (gfc_expr
* e
)
1020 cons_state
= CONS_START
;
1021 gfc_clear_ts (&constructor_ts
);
1023 t
= check_constructor_type (e
->value
.constructor
);
1024 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1025 e
->ts
= constructor_ts
;
1032 typedef struct cons_stack
1034 gfc_iterator
*iterator
;
1035 struct cons_stack
*previous
;
1039 static cons_stack
*base
;
1041 static try check_constructor (gfc_constructor
*, try (*)(gfc_expr
*));
1043 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1044 that that variable is an iteration variables. */
1047 gfc_check_iter_variable (gfc_expr
* expr
)
1053 sym
= expr
->symtree
->n
.sym
;
1055 for (c
= base
; c
; c
= c
->previous
)
1056 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1063 /* Recursive work function for gfc_check_constructor(). This amounts
1064 to calling the check function for each expression in the
1065 constructor, giving variables with the names of iterators a pass. */
1068 check_constructor (gfc_constructor
* c
, try (*check_function
) (gfc_expr
*))
1074 for (; c
; c
= c
->next
)
1078 if (e
->expr_type
!= EXPR_ARRAY
)
1080 if ((*check_function
) (e
) == FAILURE
)
1085 element
.previous
= base
;
1086 element
.iterator
= c
->iterator
;
1089 t
= check_constructor (e
->value
.constructor
, check_function
);
1090 base
= element
.previous
;
1096 /* Nothing went wrong, so all OK. */
1101 /* Checks a constructor to see if it is a particular kind of
1102 expression -- specification, restricted, or initialization as
1103 determined by the check_function. */
1106 gfc_check_constructor (gfc_expr
* expr
, try (*check_function
) (gfc_expr
*))
1108 cons_stack
*base_save
;
1114 t
= check_constructor (expr
->value
.constructor
, check_function
);
1122 /**************** Simplification of array constructors ****************/
1124 iterator_stack
*iter_stack
;
1128 gfc_constructor
*new_head
, *new_tail
;
1129 int extract_count
, extract_n
;
1130 gfc_expr
*extracted
;
1134 gfc_component
*component
;
1137 try (*expand_work_function
) (gfc_expr
*);
1141 static expand_info current_expand
;
1143 static try expand_constructor (gfc_constructor
*);
1146 /* Work function that counts the number of elements present in a
1150 count_elements (gfc_expr
* e
)
1155 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1158 if (gfc_array_size (e
, &result
) == FAILURE
)
1164 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1173 /* Work function that extracts a particular element from an array
1174 constructor, freeing the rest. */
1177 extract_element (gfc_expr
* e
)
1181 { /* Something unextractable */
1186 if (current_expand
.extract_count
== current_expand
.extract_n
)
1187 current_expand
.extracted
= e
;
1191 current_expand
.extract_count
++;
1196 /* Work function that constructs a new constructor out of the old one,
1197 stringing new elements together. */
1200 expand (gfc_expr
* e
)
1203 if (current_expand
.new_head
== NULL
)
1204 current_expand
.new_head
= current_expand
.new_tail
=
1205 gfc_get_constructor ();
1208 current_expand
.new_tail
->next
= gfc_get_constructor ();
1209 current_expand
.new_tail
= current_expand
.new_tail
->next
;
1212 current_expand
.new_tail
->where
= e
->where
;
1213 current_expand
.new_tail
->expr
= e
;
1215 mpz_set (current_expand
.new_tail
->n
.offset
, *current_expand
.offset
);
1216 current_expand
.new_tail
->n
.component
= current_expand
.component
;
1217 mpz_set (current_expand
.new_tail
->repeat
, *current_expand
.repeat
);
1222 /* Given an initialization expression that is a variable reference,
1223 substitute the current value of the iteration variable. */
1226 gfc_simplify_iterator_var (gfc_expr
* e
)
1230 for (p
= iter_stack
; p
; p
= p
->prev
)
1231 if (e
->symtree
== p
->variable
)
1235 return; /* Variable not found */
1237 gfc_replace_expr (e
, gfc_int_expr (0));
1239 mpz_set (e
->value
.integer
, p
->value
);
1245 /* Expand an expression with that is inside of a constructor,
1246 recursing into other constructors if present. */
1249 expand_expr (gfc_expr
* e
)
1252 if (e
->expr_type
== EXPR_ARRAY
)
1253 return expand_constructor (e
->value
.constructor
);
1255 e
= gfc_copy_expr (e
);
1257 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1263 return current_expand
.expand_work_function (e
);
1268 expand_iterator (gfc_constructor
* c
)
1270 gfc_expr
*start
, *end
, *step
;
1271 iterator_stack frame
;
1280 mpz_init (frame
.value
);
1282 start
= gfc_copy_expr (c
->iterator
->start
);
1283 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1286 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1289 end
= gfc_copy_expr (c
->iterator
->end
);
1290 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1293 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1296 step
= gfc_copy_expr (c
->iterator
->step
);
1297 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1300 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1303 if (mpz_sgn (step
->value
.integer
) == 0)
1305 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1309 /* Calculate the trip count of the loop. */
1310 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1311 mpz_add (trip
, trip
, step
->value
.integer
);
1312 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1314 mpz_set (frame
.value
, start
->value
.integer
);
1316 frame
.prev
= iter_stack
;
1317 frame
.variable
= c
->iterator
->var
->symtree
;
1318 iter_stack
= &frame
;
1320 while (mpz_sgn (trip
) > 0)
1322 if (expand_expr (c
->expr
) == FAILURE
)
1325 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1326 mpz_sub_ui (trip
, trip
, 1);
1332 gfc_free_expr (start
);
1333 gfc_free_expr (end
);
1334 gfc_free_expr (step
);
1337 mpz_clear (frame
.value
);
1339 iter_stack
= frame
.prev
;
1345 /* Expand a constructor into constant constructors without any
1346 iterators, calling the work function for each of the expanded
1347 expressions. The work function needs to either save or free the
1348 passed expression. */
1351 expand_constructor (gfc_constructor
* c
)
1355 for (; c
; c
= c
->next
)
1357 if (c
->iterator
!= NULL
)
1359 if (expand_iterator (c
) == FAILURE
)
1366 if (e
->expr_type
== EXPR_ARRAY
)
1368 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1374 e
= gfc_copy_expr (e
);
1375 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1380 current_expand
.offset
= &c
->n
.offset
;
1381 current_expand
.component
= c
->n
.component
;
1382 current_expand
.repeat
= &c
->repeat
;
1383 if (current_expand
.expand_work_function (e
) == FAILURE
)
1390 /* Top level subroutine for expanding constructors. We only expand
1391 constructor if they are small enough. */
1394 gfc_expand_constructor (gfc_expr
* e
)
1396 expand_info expand_save
;
1400 f
= gfc_get_array_element (e
, GFC_MAX_AC_EXPAND
);
1407 expand_save
= current_expand
;
1408 current_expand
.new_head
= current_expand
.new_tail
= NULL
;
1412 current_expand
.expand_work_function
= expand
;
1414 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1416 gfc_free_constructor (current_expand
.new_head
);
1421 gfc_free_constructor (e
->value
.constructor
);
1422 e
->value
.constructor
= current_expand
.new_head
;
1427 current_expand
= expand_save
;
1433 /* Work function for checking that an element of a constructor is a
1434 constant, after removal of any iteration variables. We return
1435 FAILURE if not so. */
1438 constant_element (gfc_expr
* e
)
1442 rv
= gfc_is_constant_expr (e
);
1445 return rv
? SUCCESS
: FAILURE
;
1449 /* Given an array constructor, determine if the constructor is
1450 constant or not by expanding it and making sure that all elements
1451 are constants. This is a bit of a hack since something like (/ (i,
1452 i=1,100000000) /) will take a while as* opposed to a more clever
1453 function that traverses the expression tree. FIXME. */
1456 gfc_constant_ac (gfc_expr
* e
)
1458 expand_info expand_save
;
1462 expand_save
= current_expand
;
1463 current_expand
.expand_work_function
= constant_element
;
1465 rc
= expand_constructor (e
->value
.constructor
);
1467 current_expand
= expand_save
;
1475 /* Returns nonzero if an array constructor has been completely
1476 expanded (no iterators) and zero if iterators are present. */
1479 gfc_expanded_ac (gfc_expr
* e
)
1483 if (e
->expr_type
== EXPR_ARRAY
)
1484 for (p
= e
->value
.constructor
; p
; p
= p
->next
)
1485 if (p
->iterator
!= NULL
|| !gfc_expanded_ac (p
->expr
))
1492 /*************** Type resolution of array constructors ***************/
1494 /* Recursive array list resolution function. All of the elements must
1495 be of the same type. */
1498 resolve_array_list (gfc_constructor
* p
)
1504 for (; p
; p
= p
->next
)
1506 if (p
->iterator
!= NULL
1507 && gfc_resolve_iterator (p
->iterator
, false) == FAILURE
)
1510 if (gfc_resolve_expr (p
->expr
) == FAILURE
)
1517 /* Resolve character array constructor. If it is a constant character array and
1518 not specified character length, update character length to the maximum of
1519 its element constructors' length. */
1522 resolve_character_array_constructor (gfc_expr
* expr
)
1524 gfc_constructor
* p
;
1527 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1528 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1532 if (expr
->ts
.cl
== NULL
)
1534 expr
->ts
.cl
= gfc_get_charlen ();
1535 expr
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1536 gfc_current_ns
->cl_list
= expr
->ts
.cl
;
1539 if (expr
->ts
.cl
->length
== NULL
)
1541 /* Find the maximum length of the elements. Do nothing for variable array
1543 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1544 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1545 max_length
= MAX (p
->expr
->value
.character
.length
, max_length
);
1549 if (max_length
!= -1)
1551 /* Update the character length of the array constructor. */
1552 expr
->ts
.cl
->length
= gfc_int_expr (max_length
);
1553 /* Update the element constructors. */
1554 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1555 gfc_set_constant_character_len (max_length
, p
->expr
);
1560 /* Resolve all of the expressions in an array list. */
1563 gfc_resolve_array_constructor (gfc_expr
* expr
)
1567 t
= resolve_array_list (expr
->value
.constructor
);
1569 t
= gfc_check_constructor_type (expr
);
1570 if (t
== SUCCESS
&& expr
->ts
.type
== BT_CHARACTER
)
1571 resolve_character_array_constructor (expr
);
1577 /* Copy an iterator structure. */
1579 static gfc_iterator
*
1580 copy_iterator (gfc_iterator
* src
)
1587 dest
= gfc_get_iterator ();
1589 dest
->var
= gfc_copy_expr (src
->var
);
1590 dest
->start
= gfc_copy_expr (src
->start
);
1591 dest
->end
= gfc_copy_expr (src
->end
);
1592 dest
->step
= gfc_copy_expr (src
->step
);
1598 /* Copy a constructor structure. */
1601 gfc_copy_constructor (gfc_constructor
* src
)
1603 gfc_constructor
*dest
;
1604 gfc_constructor
*tail
;
1613 dest
= tail
= gfc_get_constructor ();
1616 tail
->next
= gfc_get_constructor ();
1619 tail
->where
= src
->where
;
1620 tail
->expr
= gfc_copy_expr (src
->expr
);
1621 tail
->iterator
= copy_iterator (src
->iterator
);
1622 mpz_set (tail
->n
.offset
, src
->n
.offset
);
1623 tail
->n
.component
= src
->n
.component
;
1624 mpz_set (tail
->repeat
, src
->repeat
);
1632 /* Given an array expression and an element number (starting at zero),
1633 return a pointer to the array element. NULL is returned if the
1634 size of the array has been exceeded. The expression node returned
1635 remains a part of the array and should not be freed. Access is not
1636 efficient at all, but this is another place where things do not
1637 have to be particularly fast. */
1640 gfc_get_array_element (gfc_expr
* array
, int element
)
1642 expand_info expand_save
;
1646 expand_save
= current_expand
;
1647 current_expand
.extract_n
= element
;
1648 current_expand
.expand_work_function
= extract_element
;
1649 current_expand
.extracted
= NULL
;
1650 current_expand
.extract_count
= 0;
1654 rc
= expand_constructor (array
->value
.constructor
);
1655 e
= current_expand
.extracted
;
1656 current_expand
= expand_save
;
1665 /********* Subroutines for determining the size of an array *********/
1667 /* These are needed just to accommodate RESHAPE(). There are no
1668 diagnostics here, we just return a negative number if something
1672 /* Get the size of single dimension of an array specification. The
1673 array is guaranteed to be one dimensional. */
1676 spec_dimen_size (gfc_array_spec
* as
, int dimen
, mpz_t
* result
)
1682 if (dimen
< 0 || dimen
> as
->rank
- 1)
1683 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1685 if (as
->type
!= AS_EXPLICIT
1686 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
1687 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1692 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
1693 as
->lower
[dimen
]->value
.integer
);
1695 mpz_add_ui (*result
, *result
, 1);
1702 spec_size (gfc_array_spec
* as
, mpz_t
* result
)
1707 mpz_init_set_ui (*result
, 1);
1709 for (d
= 0; d
< as
->rank
; d
++)
1711 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
1713 mpz_clear (*result
);
1717 mpz_mul (*result
, *result
, size
);
1725 /* Get the number of elements in an array section. */
1728 ref_dimen_size (gfc_array_ref
* ar
, int dimen
, mpz_t
* result
)
1730 mpz_t upper
, lower
, stride
;
1733 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
1734 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1736 switch (ar
->dimen_type
[dimen
])
1740 mpz_set_ui (*result
, 1);
1745 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
1754 if (ar
->start
[dimen
] == NULL
)
1756 if (ar
->as
->lower
[dimen
] == NULL
1757 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1759 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
1763 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1765 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
1768 if (ar
->end
[dimen
] == NULL
)
1770 if (ar
->as
->upper
[dimen
] == NULL
1771 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1773 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
1777 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1779 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
1782 if (ar
->stride
[dimen
] == NULL
)
1783 mpz_set_ui (stride
, 1);
1786 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1788 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
1792 mpz_sub (*result
, upper
, lower
);
1793 mpz_add (*result
, *result
, stride
);
1794 mpz_div (*result
, *result
, stride
);
1796 /* Zero stride caught earlier. */
1797 if (mpz_cmp_ui (*result
, 0) < 0)
1798 mpz_set_ui (*result
, 0);
1808 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1816 ref_size (gfc_array_ref
* ar
, mpz_t
* result
)
1821 mpz_init_set_ui (*result
, 1);
1823 for (d
= 0; d
< ar
->dimen
; d
++)
1825 if (ref_dimen_size (ar
, d
, &size
) == FAILURE
)
1827 mpz_clear (*result
);
1831 mpz_mul (*result
, *result
, size
);
1839 /* Given an array expression and a dimension, figure out how many
1840 elements it has along that dimension. Returns SUCCESS if we were
1841 able to return a result in the 'result' variable, FAILURE
1845 gfc_array_dimen_size (gfc_expr
* array
, int dimen
, mpz_t
* result
)
1850 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
1851 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1853 switch (array
->expr_type
)
1857 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1859 if (ref
->type
!= REF_ARRAY
)
1862 if (ref
->u
.ar
.type
== AR_FULL
)
1863 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
1865 if (ref
->u
.ar
.type
== AR_SECTION
)
1867 for (i
= 0; dimen
>= 0; i
++)
1868 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1871 return ref_dimen_size (&ref
->u
.ar
, i
- 1, result
);
1875 if (array
->shape
&& array
->shape
[dimen
])
1877 mpz_init_set (*result
, array
->shape
[dimen
]);
1881 if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
) == FAILURE
)
1887 if (array
->shape
== NULL
) {
1888 /* Expressions with rank > 1 should have "shape" properly set */
1889 if ( array
->rank
!= 1 )
1890 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1891 return gfc_array_size(array
, result
);
1896 if (array
->shape
== NULL
)
1899 mpz_init_set (*result
, array
->shape
[dimen
]);
1908 /* Given an array expression, figure out how many elements are in the
1909 array. Returns SUCCESS if this is possible, and sets the 'result'
1910 variable. Otherwise returns FAILURE. */
1913 gfc_array_size (gfc_expr
* array
, mpz_t
* result
)
1915 expand_info expand_save
;
1920 switch (array
->expr_type
)
1923 flag
= gfc_suppress_error
;
1924 gfc_suppress_error
= 1;
1926 expand_save
= current_expand
;
1928 current_expand
.count
= result
;
1929 mpz_init_set_ui (*result
, 0);
1931 current_expand
.expand_work_function
= count_elements
;
1934 t
= expand_constructor (array
->value
.constructor
);
1935 gfc_suppress_error
= flag
;
1938 mpz_clear (*result
);
1939 current_expand
= expand_save
;
1943 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1945 if (ref
->type
!= REF_ARRAY
)
1948 if (ref
->u
.ar
.type
== AR_FULL
)
1949 return spec_size (ref
->u
.ar
.as
, result
);
1951 if (ref
->u
.ar
.type
== AR_SECTION
)
1952 return ref_size (&ref
->u
.ar
, result
);
1955 return spec_size (array
->symtree
->n
.sym
->as
, result
);
1959 if (array
->rank
== 0 || array
->shape
== NULL
)
1962 mpz_init_set_ui (*result
, 1);
1964 for (i
= 0; i
< array
->rank
; i
++)
1965 mpz_mul (*result
, *result
, array
->shape
[i
]);
1974 /* Given an array reference, return the shape of the reference in an
1975 array of mpz_t integers. */
1978 gfc_array_ref_shape (gfc_array_ref
* ar
, mpz_t
* shape
)
1988 for (; d
< ar
->as
->rank
; d
++)
1989 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
1995 for (i
= 0; i
< ar
->dimen
; i
++)
1997 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
1999 if (ref_dimen_size (ar
, i
, &shape
[d
]) == FAILURE
)
2012 for (d
--; d
>= 0; d
--)
2013 mpz_clear (shape
[d
]);
2019 /* Given an array expression, find the array reference structure that
2020 characterizes the reference. */
2023 gfc_find_array_ref (gfc_expr
* e
)
2027 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2028 if (ref
->type
== REF_ARRAY
2029 && (ref
->u
.ar
.type
== AR_FULL
2030 || ref
->u
.ar
.type
== AR_SECTION
))
2034 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2040 /* Find out if an array shape is known at compile time. */
2043 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2047 if (as
->type
!= AS_EXPLICIT
)
2050 for (i
= 0; i
< as
->rank
; i
++)
2051 if (!gfc_is_constant_expr (as
->lower
[i
])
2052 || !gfc_is_constant_expr (as
->upper
[i
]))