2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
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
)
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
;
322 /* If the size is negative in this dimension, set it to zero. */
323 if ((*lower
)->expr_type
== EXPR_CONSTANT
324 && (*upper
)->expr_type
== EXPR_CONSTANT
325 && mpz_cmp ((*upper
)->value
.integer
, (*lower
)->value
.integer
) < 0)
327 gfc_free_expr (*upper
);
328 *upper
= gfc_copy_expr (*lower
);
329 mpz_sub_ui ((*upper
)->value
.integer
, (*upper
)->value
.integer
, 1);
335 /* Matches an array specification, incidentally figuring out what sort
339 gfc_match_array_spec (gfc_array_spec
**asp
)
341 array_type current_type
;
345 if (gfc_match_char ('(') != MATCH_YES
)
351 as
= gfc_get_array_spec ();
353 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
363 current_type
= match_array_element_spec (as
);
367 if (current_type
== AS_UNKNOWN
)
369 as
->type
= current_type
;
373 { /* See how current spec meshes with the existing. */
378 if (current_type
== AS_ASSUMED_SIZE
)
380 as
->type
= AS_ASSUMED_SIZE
;
384 if (current_type
== AS_EXPLICIT
)
387 gfc_error ("Bad array specification for an explicitly shaped "
392 case AS_ASSUMED_SHAPE
:
393 if ((current_type
== AS_ASSUMED_SHAPE
)
394 || (current_type
== AS_DEFERRED
))
397 gfc_error ("Bad array specification for assumed shape "
402 if (current_type
== AS_DEFERRED
)
405 if (current_type
== AS_ASSUMED_SHAPE
)
407 as
->type
= AS_ASSUMED_SHAPE
;
411 gfc_error ("Bad specification for deferred shape array at %C");
414 case AS_ASSUMED_SIZE
:
415 gfc_error ("Bad specification for assumed size array at %C");
419 if (gfc_match_char (')') == MATCH_YES
)
422 if (gfc_match_char (',') != MATCH_YES
)
424 gfc_error ("Expected another dimension in array declaration at %C");
428 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
430 gfc_error ("Array specification at %C has more than %d dimensions",
438 /* If a lower bounds of an assumed shape array is blank, put in one. */
439 if (as
->type
== AS_ASSUMED_SHAPE
)
441 for (i
= 0; i
< as
->rank
; i
++)
443 if (as
->lower
[i
] == NULL
)
444 as
->lower
[i
] = gfc_int_expr (1);
451 /* Something went wrong. */
452 gfc_free_array_spec (as
);
457 /* Given a symbol and an array specification, modify the symbol to
458 have that array specification. The error locus is needed in case
459 something goes wrong. On failure, the caller must free the spec. */
462 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
467 if (gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
476 /* Copy an array specification. */
479 gfc_copy_array_spec (gfc_array_spec
*src
)
481 gfc_array_spec
*dest
;
487 dest
= gfc_get_array_spec ();
491 for (i
= 0; i
< dest
->rank
; i
++)
493 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
494 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
501 /* Returns nonzero if the two expressions are equal. Only handles integer
505 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
507 if (bound1
== NULL
|| bound2
== NULL
508 || bound1
->expr_type
!= EXPR_CONSTANT
509 || bound2
->expr_type
!= EXPR_CONSTANT
510 || bound1
->ts
.type
!= BT_INTEGER
511 || bound2
->ts
.type
!= BT_INTEGER
)
512 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
514 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
521 /* Compares two array specifications. They must be constant or deferred
525 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
529 if (as1
== NULL
&& as2
== NULL
)
532 if (as1
== NULL
|| as2
== NULL
)
535 if (as1
->rank
!= as2
->rank
)
541 if (as1
->type
!= as2
->type
)
544 if (as1
->type
== AS_EXPLICIT
)
545 for (i
= 0; i
< as1
->rank
; i
++)
547 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
550 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
558 /****************** Array constructor functions ******************/
560 /* Start an array constructor. The constructor starts with zero
561 elements and should be appended to by gfc_append_constructor(). */
564 gfc_start_constructor (bt type
, int kind
, locus
*where
)
568 result
= gfc_get_expr ();
570 result
->expr_type
= EXPR_ARRAY
;
573 result
->ts
.type
= type
;
574 result
->ts
.kind
= kind
;
575 result
->where
= *where
;
580 /* Given an array constructor expression, append the new expression
581 node onto the constructor. */
584 gfc_append_constructor (gfc_expr
*base
, gfc_expr
*new)
588 if (base
->value
.constructor
== NULL
)
589 base
->value
.constructor
= c
= gfc_get_constructor ();
592 c
= base
->value
.constructor
;
596 c
->next
= gfc_get_constructor ();
602 if (new->ts
.type
!= base
->ts
.type
|| new->ts
.kind
!= base
->ts
.kind
)
603 gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
607 /* Given an array constructor expression, insert the new expression's
608 constructor onto the base's one according to the offset. */
611 gfc_insert_constructor (gfc_expr
*base
, gfc_constructor
*c1
)
613 gfc_constructor
*c
, *pre
;
617 type
= base
->expr_type
;
619 if (base
->value
.constructor
== NULL
)
620 base
->value
.constructor
= c1
;
623 c
= pre
= base
->value
.constructor
;
626 if (type
== EXPR_ARRAY
)
628 t
= mpz_cmp (c
->n
.offset
, c1
->n
.offset
);
636 gfc_error ("duplicated initializer");
657 base
->value
.constructor
= c1
;
663 /* Get a new constructor. */
666 gfc_get_constructor (void)
670 c
= gfc_getmem (sizeof(gfc_constructor
));
674 mpz_init_set_si (c
->n
.offset
, 0);
675 mpz_init_set_si (c
->repeat
, 0);
680 /* Free chains of gfc_constructor structures. */
683 gfc_free_constructor (gfc_constructor
*p
)
685 gfc_constructor
*next
;
695 gfc_free_expr (p
->expr
);
696 if (p
->iterator
!= NULL
)
697 gfc_free_iterator (p
->iterator
, 1);
698 mpz_clear (p
->n
.offset
);
699 mpz_clear (p
->repeat
);
705 /* Given an expression node that might be an array constructor and a
706 symbol, make sure that no iterators in this or child constructors
707 use the symbol as an implied-DO iterator. Returns nonzero if a
708 duplicate was found. */
711 check_duplicate_iterator (gfc_constructor
*c
, gfc_symbol
*master
)
715 for (; c
; c
= c
->next
)
719 if (e
->expr_type
== EXPR_ARRAY
720 && check_duplicate_iterator (e
->value
.constructor
, master
))
723 if (c
->iterator
== NULL
)
726 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
728 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
729 "same name", master
->name
, &c
->where
);
739 /* Forward declaration because these functions are mutually recursive. */
740 static match
match_array_cons_element (gfc_constructor
**);
742 /* Match a list of array elements. */
745 match_array_list (gfc_constructor
**result
)
747 gfc_constructor
*p
, *head
, *tail
, *new;
754 old_loc
= gfc_current_locus
;
756 if (gfc_match_char ('(') == MATCH_NO
)
759 memset (&iter
, '\0', sizeof (gfc_iterator
));
762 m
= match_array_cons_element (&head
);
768 if (gfc_match_char (',') != MATCH_YES
)
776 m
= gfc_match_iterator (&iter
, 0);
779 if (m
== MATCH_ERROR
)
782 m
= match_array_cons_element (&new);
783 if (m
== MATCH_ERROR
)
790 goto cleanup
; /* Could be a complex constant */
796 if (gfc_match_char (',') != MATCH_YES
)
805 if (gfc_match_char (')') != MATCH_YES
)
808 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
815 e
->expr_type
= EXPR_ARRAY
;
817 e
->value
.constructor
= head
;
819 p
= gfc_get_constructor ();
820 p
->where
= gfc_current_locus
;
821 p
->iterator
= gfc_get_iterator ();
830 gfc_error ("Syntax error in array constructor at %C");
834 gfc_free_constructor (head
);
835 gfc_free_iterator (&iter
, 0);
836 gfc_current_locus
= old_loc
;
841 /* Match a single element of an array constructor, which can be a
842 single expression or a list of elements. */
845 match_array_cons_element (gfc_constructor
**result
)
851 m
= match_array_list (result
);
855 m
= gfc_match_expr (&expr
);
859 p
= gfc_get_constructor ();
860 p
->where
= gfc_current_locus
;
868 /* Match an array constructor. */
871 gfc_match_array_constructor (gfc_expr
**result
)
873 gfc_constructor
*head
, *tail
, *new;
877 const char *end_delim
;
879 if (gfc_match (" (/") == MATCH_NO
)
881 if (gfc_match (" [") == MATCH_NO
)
885 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: [...] "
886 "style array constructors at %C") == FAILURE
)
894 where
= gfc_current_locus
;
897 if (gfc_match (end_delim
) == MATCH_YES
)
899 gfc_error ("Empty array constructor at %C is not allowed");
905 m
= match_array_cons_element (&new);
906 if (m
== MATCH_ERROR
)
918 if (gfc_match_char (',') == MATCH_NO
)
922 if (gfc_match (end_delim
) == MATCH_NO
)
925 expr
= gfc_get_expr ();
927 expr
->expr_type
= EXPR_ARRAY
;
929 expr
->value
.constructor
= head
;
930 /* Size must be calculated at resolution time. */
939 gfc_error ("Syntax error in array constructor at %C");
942 gfc_free_constructor (head
);
948 /************** Check array constructors for correctness **************/
950 /* Given an expression, compare it's type with the type of the current
951 constructor. Returns nonzero if an error was issued. The
952 cons_state variable keeps track of whether the type of the
953 constructor being read or resolved is known to be good, bad or just
956 static gfc_typespec constructor_ts
;
958 { CONS_START
, CONS_GOOD
, CONS_BAD
}
962 check_element_type (gfc_expr
*expr
)
964 if (cons_state
== CONS_BAD
)
965 return 0; /* Suppress further errors */
967 if (cons_state
== CONS_START
)
969 if (expr
->ts
.type
== BT_UNKNOWN
)
970 cons_state
= CONS_BAD
;
973 cons_state
= CONS_GOOD
;
974 constructor_ts
= expr
->ts
;
980 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
983 gfc_error ("Element in %s array constructor at %L is %s",
984 gfc_typename (&constructor_ts
), &expr
->where
,
985 gfc_typename (&expr
->ts
));
987 cons_state
= CONS_BAD
;
992 /* Recursive work function for gfc_check_constructor_type(). */
995 check_constructor_type (gfc_constructor
*c
)
999 for (; c
; c
= c
->next
)
1003 if (e
->expr_type
== EXPR_ARRAY
)
1005 if (check_constructor_type (e
->value
.constructor
) == FAILURE
)
1011 if (check_element_type (e
))
1019 /* Check that all elements of an array constructor are the same type.
1020 On FAILURE, an error has been generated. */
1023 gfc_check_constructor_type (gfc_expr
*e
)
1027 cons_state
= CONS_START
;
1028 gfc_clear_ts (&constructor_ts
);
1030 t
= check_constructor_type (e
->value
.constructor
);
1031 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1032 e
->ts
= constructor_ts
;
1039 typedef struct cons_stack
1041 gfc_iterator
*iterator
;
1042 struct cons_stack
*previous
;
1046 static cons_stack
*base
;
1048 static try check_constructor (gfc_constructor
*, try (*) (gfc_expr
*));
1050 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1051 that that variable is an iteration variables. */
1054 gfc_check_iter_variable (gfc_expr
*expr
)
1059 sym
= expr
->symtree
->n
.sym
;
1061 for (c
= base
; c
; c
= c
->previous
)
1062 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1069 /* Recursive work function for gfc_check_constructor(). This amounts
1070 to calling the check function for each expression in the
1071 constructor, giving variables with the names of iterators a pass. */
1074 check_constructor (gfc_constructor
*c
, try (*check_function
) (gfc_expr
*))
1080 for (; c
; c
= c
->next
)
1084 if (e
->expr_type
!= EXPR_ARRAY
)
1086 if ((*check_function
) (e
) == FAILURE
)
1091 element
.previous
= base
;
1092 element
.iterator
= c
->iterator
;
1095 t
= check_constructor (e
->value
.constructor
, check_function
);
1096 base
= element
.previous
;
1102 /* Nothing went wrong, so all OK. */
1107 /* Checks a constructor to see if it is a particular kind of
1108 expression -- specification, restricted, or initialization as
1109 determined by the check_function. */
1112 gfc_check_constructor (gfc_expr
*expr
, try (*check_function
) (gfc_expr
*))
1114 cons_stack
*base_save
;
1120 t
= check_constructor (expr
->value
.constructor
, check_function
);
1128 /**************** Simplification of array constructors ****************/
1130 iterator_stack
*iter_stack
;
1134 gfc_constructor
*new_head
, *new_tail
;
1135 int extract_count
, extract_n
;
1136 gfc_expr
*extracted
;
1140 gfc_component
*component
;
1143 try (*expand_work_function
) (gfc_expr
*);
1147 static expand_info current_expand
;
1149 static try expand_constructor (gfc_constructor
*);
1152 /* Work function that counts the number of elements present in a
1156 count_elements (gfc_expr
*e
)
1161 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1164 if (gfc_array_size (e
, &result
) == FAILURE
)
1170 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1179 /* Work function that extracts a particular element from an array
1180 constructor, freeing the rest. */
1183 extract_element (gfc_expr
*e
)
1187 { /* Something unextractable */
1192 if (current_expand
.extract_count
== current_expand
.extract_n
)
1193 current_expand
.extracted
= e
;
1197 current_expand
.extract_count
++;
1202 /* Work function that constructs a new constructor out of the old one,
1203 stringing new elements together. */
1206 expand (gfc_expr
*e
)
1208 if (current_expand
.new_head
== NULL
)
1209 current_expand
.new_head
= current_expand
.new_tail
=
1210 gfc_get_constructor ();
1213 current_expand
.new_tail
->next
= gfc_get_constructor ();
1214 current_expand
.new_tail
= current_expand
.new_tail
->next
;
1217 current_expand
.new_tail
->where
= e
->where
;
1218 current_expand
.new_tail
->expr
= e
;
1220 mpz_set (current_expand
.new_tail
->n
.offset
, *current_expand
.offset
);
1221 current_expand
.new_tail
->n
.component
= current_expand
.component
;
1222 mpz_set (current_expand
.new_tail
->repeat
, *current_expand
.repeat
);
1227 /* Given an initialization expression that is a variable reference,
1228 substitute the current value of the iteration variable. */
1231 gfc_simplify_iterator_var (gfc_expr
*e
)
1235 for (p
= iter_stack
; p
; p
= p
->prev
)
1236 if (e
->symtree
== p
->variable
)
1240 return; /* Variable not found */
1242 gfc_replace_expr (e
, gfc_int_expr (0));
1244 mpz_set (e
->value
.integer
, p
->value
);
1250 /* Expand an expression with that is inside of a constructor,
1251 recursing into other constructors if present. */
1254 expand_expr (gfc_expr
*e
)
1256 if (e
->expr_type
== EXPR_ARRAY
)
1257 return expand_constructor (e
->value
.constructor
);
1259 e
= gfc_copy_expr (e
);
1261 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1267 return current_expand
.expand_work_function (e
);
1272 expand_iterator (gfc_constructor
*c
)
1274 gfc_expr
*start
, *end
, *step
;
1275 iterator_stack frame
;
1284 mpz_init (frame
.value
);
1286 start
= gfc_copy_expr (c
->iterator
->start
);
1287 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1290 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1293 end
= gfc_copy_expr (c
->iterator
->end
);
1294 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1297 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1300 step
= gfc_copy_expr (c
->iterator
->step
);
1301 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1304 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1307 if (mpz_sgn (step
->value
.integer
) == 0)
1309 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1313 /* Calculate the trip count of the loop. */
1314 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1315 mpz_add (trip
, trip
, step
->value
.integer
);
1316 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1318 mpz_set (frame
.value
, start
->value
.integer
);
1320 frame
.prev
= iter_stack
;
1321 frame
.variable
= c
->iterator
->var
->symtree
;
1322 iter_stack
= &frame
;
1324 while (mpz_sgn (trip
) > 0)
1326 if (expand_expr (c
->expr
) == FAILURE
)
1329 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1330 mpz_sub_ui (trip
, trip
, 1);
1336 gfc_free_expr (start
);
1337 gfc_free_expr (end
);
1338 gfc_free_expr (step
);
1341 mpz_clear (frame
.value
);
1343 iter_stack
= frame
.prev
;
1349 /* Expand a constructor into constant constructors without any
1350 iterators, calling the work function for each of the expanded
1351 expressions. The work function needs to either save or free the
1352 passed expression. */
1355 expand_constructor (gfc_constructor
*c
)
1359 for (; c
; c
= c
->next
)
1361 if (c
->iterator
!= NULL
)
1363 if (expand_iterator (c
) == FAILURE
)
1370 if (e
->expr_type
== EXPR_ARRAY
)
1372 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1378 e
= gfc_copy_expr (e
);
1379 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1384 current_expand
.offset
= &c
->n
.offset
;
1385 current_expand
.component
= c
->n
.component
;
1386 current_expand
.repeat
= &c
->repeat
;
1387 if (current_expand
.expand_work_function (e
) == FAILURE
)
1394 /* Top level subroutine for expanding constructors. We only expand
1395 constructor if they are small enough. */
1398 gfc_expand_constructor (gfc_expr
*e
)
1400 expand_info expand_save
;
1404 f
= gfc_get_array_element (e
, GFC_MAX_AC_EXPAND
);
1411 expand_save
= current_expand
;
1412 current_expand
.new_head
= current_expand
.new_tail
= NULL
;
1416 current_expand
.expand_work_function
= expand
;
1418 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1420 gfc_free_constructor (current_expand
.new_head
);
1425 gfc_free_constructor (e
->value
.constructor
);
1426 e
->value
.constructor
= current_expand
.new_head
;
1431 current_expand
= expand_save
;
1437 /* Work function for checking that an element of a constructor is a
1438 constant, after removal of any iteration variables. We return
1439 FAILURE if not so. */
1442 constant_element (gfc_expr
*e
)
1446 rv
= gfc_is_constant_expr (e
);
1449 return rv
? SUCCESS
: FAILURE
;
1453 /* Given an array constructor, determine if the constructor is
1454 constant or not by expanding it and making sure that all elements
1455 are constants. This is a bit of a hack since something like (/ (i,
1456 i=1,100000000) /) will take a while as* opposed to a more clever
1457 function that traverses the expression tree. FIXME. */
1460 gfc_constant_ac (gfc_expr
*e
)
1462 expand_info expand_save
;
1466 expand_save
= current_expand
;
1467 current_expand
.expand_work_function
= constant_element
;
1469 rc
= expand_constructor (e
->value
.constructor
);
1471 current_expand
= expand_save
;
1479 /* Returns nonzero if an array constructor has been completely
1480 expanded (no iterators) and zero if iterators are present. */
1483 gfc_expanded_ac (gfc_expr
*e
)
1487 if (e
->expr_type
== EXPR_ARRAY
)
1488 for (p
= e
->value
.constructor
; p
; p
= p
->next
)
1489 if (p
->iterator
!= NULL
|| !gfc_expanded_ac (p
->expr
))
1496 /*************** Type resolution of array constructors ***************/
1498 /* Recursive array list resolution function. All of the elements must
1499 be of the same type. */
1502 resolve_array_list (gfc_constructor
*p
)
1508 for (; p
; p
= p
->next
)
1510 if (p
->iterator
!= NULL
1511 && gfc_resolve_iterator (p
->iterator
, false) == FAILURE
)
1514 if (gfc_resolve_expr (p
->expr
) == FAILURE
)
1521 /* Resolve character array constructor. If it is a constant character array and
1522 not specified character length, update character length to the maximum of
1523 its element constructors' length. */
1526 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1531 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1532 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1536 if (expr
->ts
.cl
== NULL
)
1538 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1539 if (p
->expr
->ts
.cl
!= NULL
)
1541 /* Ensure that if there is a char_len around that it is
1542 used; otherwise the middle-end confuses them! */
1543 expr
->ts
.cl
= p
->expr
->ts
.cl
;
1547 expr
->ts
.cl
= gfc_get_charlen ();
1548 expr
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1549 gfc_current_ns
->cl_list
= expr
->ts
.cl
;
1554 if (expr
->ts
.cl
->length
== NULL
)
1556 /* Find the maximum length of the elements. Do nothing for variable
1557 array constructor, unless the character length is constant or
1558 there is a constant substring reference. */
1560 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1563 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1564 if (ref
->type
== REF_SUBSTRING
1565 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1566 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1569 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1570 max_length
= MAX (p
->expr
->value
.character
.length
, max_length
);
1574 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1575 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1576 max_length
= MAX ((int) j
, max_length
);
1578 else if (p
->expr
->ts
.cl
&& p
->expr
->ts
.cl
->length
1579 && p
->expr
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1582 j
= mpz_get_si (p
->expr
->ts
.cl
->length
->value
.integer
);
1583 max_length
= MAX ((int) j
, max_length
);
1589 if (max_length
!= -1)
1591 /* Update the character length of the array constructor. */
1592 expr
->ts
.cl
->length
= gfc_int_expr (max_length
);
1593 /* Update the element constructors. */
1594 for (p
= expr
->value
.constructor
; p
; p
= p
->next
)
1595 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1596 gfc_set_constant_character_len (max_length
, p
->expr
, true);
1602 /* Resolve all of the expressions in an array list. */
1605 gfc_resolve_array_constructor (gfc_expr
*expr
)
1609 t
= resolve_array_list (expr
->value
.constructor
);
1611 t
= gfc_check_constructor_type (expr
);
1612 if (t
== SUCCESS
&& expr
->ts
.type
== BT_CHARACTER
)
1613 gfc_resolve_character_array_constructor (expr
);
1619 /* Copy an iterator structure. */
1621 static gfc_iterator
*
1622 copy_iterator (gfc_iterator
*src
)
1629 dest
= gfc_get_iterator ();
1631 dest
->var
= gfc_copy_expr (src
->var
);
1632 dest
->start
= gfc_copy_expr (src
->start
);
1633 dest
->end
= gfc_copy_expr (src
->end
);
1634 dest
->step
= gfc_copy_expr (src
->step
);
1640 /* Copy a constructor structure. */
1643 gfc_copy_constructor (gfc_constructor
*src
)
1645 gfc_constructor
*dest
;
1646 gfc_constructor
*tail
;
1655 dest
= tail
= gfc_get_constructor ();
1658 tail
->next
= gfc_get_constructor ();
1661 tail
->where
= src
->where
;
1662 tail
->expr
= gfc_copy_expr (src
->expr
);
1663 tail
->iterator
= copy_iterator (src
->iterator
);
1664 mpz_set (tail
->n
.offset
, src
->n
.offset
);
1665 tail
->n
.component
= src
->n
.component
;
1666 mpz_set (tail
->repeat
, src
->repeat
);
1674 /* Given an array expression and an element number (starting at zero),
1675 return a pointer to the array element. NULL is returned if the
1676 size of the array has been exceeded. The expression node returned
1677 remains a part of the array and should not be freed. Access is not
1678 efficient at all, but this is another place where things do not
1679 have to be particularly fast. */
1682 gfc_get_array_element (gfc_expr
*array
, int element
)
1684 expand_info expand_save
;
1688 expand_save
= current_expand
;
1689 current_expand
.extract_n
= element
;
1690 current_expand
.expand_work_function
= extract_element
;
1691 current_expand
.extracted
= NULL
;
1692 current_expand
.extract_count
= 0;
1696 rc
= expand_constructor (array
->value
.constructor
);
1697 e
= current_expand
.extracted
;
1698 current_expand
= expand_save
;
1707 /********* Subroutines for determining the size of an array *********/
1709 /* These are needed just to accommodate RESHAPE(). There are no
1710 diagnostics here, we just return a negative number if something
1714 /* Get the size of single dimension of an array specification. The
1715 array is guaranteed to be one dimensional. */
1718 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
1723 if (dimen
< 0 || dimen
> as
->rank
- 1)
1724 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1726 if (as
->type
!= AS_EXPLICIT
1727 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
1728 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1733 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
1734 as
->lower
[dimen
]->value
.integer
);
1736 mpz_add_ui (*result
, *result
, 1);
1743 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
1748 mpz_init_set_ui (*result
, 1);
1750 for (d
= 0; d
< as
->rank
; d
++)
1752 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
1754 mpz_clear (*result
);
1758 mpz_mul (*result
, *result
, size
);
1766 /* Get the number of elements in an array section. */
1769 ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
)
1771 mpz_t upper
, lower
, stride
;
1774 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
1775 gfc_internal_error ("ref_dimen_size(): Bad dimension");
1777 switch (ar
->dimen_type
[dimen
])
1781 mpz_set_ui (*result
, 1);
1786 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
1795 if (ar
->start
[dimen
] == NULL
)
1797 if (ar
->as
->lower
[dimen
] == NULL
1798 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1800 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
1804 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1806 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
1809 if (ar
->end
[dimen
] == NULL
)
1811 if (ar
->as
->upper
[dimen
] == NULL
1812 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1814 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
1818 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1820 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
1823 if (ar
->stride
[dimen
] == NULL
)
1824 mpz_set_ui (stride
, 1);
1827 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1829 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
1833 mpz_sub (*result
, upper
, lower
);
1834 mpz_add (*result
, *result
, stride
);
1835 mpz_div (*result
, *result
, stride
);
1837 /* Zero stride caught earlier. */
1838 if (mpz_cmp_ui (*result
, 0) < 0)
1839 mpz_set_ui (*result
, 0);
1849 gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1857 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
1862 mpz_init_set_ui (*result
, 1);
1864 for (d
= 0; d
< ar
->dimen
; d
++)
1866 if (ref_dimen_size (ar
, d
, &size
) == FAILURE
)
1868 mpz_clear (*result
);
1872 mpz_mul (*result
, *result
, size
);
1880 /* Given an array expression and a dimension, figure out how many
1881 elements it has along that dimension. Returns SUCCESS if we were
1882 able to return a result in the 'result' variable, FAILURE
1886 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
1891 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
1892 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1894 switch (array
->expr_type
)
1898 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1900 if (ref
->type
!= REF_ARRAY
)
1903 if (ref
->u
.ar
.type
== AR_FULL
)
1904 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
1906 if (ref
->u
.ar
.type
== AR_SECTION
)
1908 for (i
= 0; dimen
>= 0; i
++)
1909 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1912 return ref_dimen_size (&ref
->u
.ar
, i
- 1, result
);
1916 if (array
->shape
&& array
->shape
[dimen
])
1918 mpz_init_set (*result
, array
->shape
[dimen
]);
1922 if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
) == FAILURE
)
1928 if (array
->shape
== NULL
) {
1929 /* Expressions with rank > 1 should have "shape" properly set */
1930 if ( array
->rank
!= 1 )
1931 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1932 return gfc_array_size(array
, result
);
1937 if (array
->shape
== NULL
)
1940 mpz_init_set (*result
, array
->shape
[dimen
]);
1949 /* Given an array expression, figure out how many elements are in the
1950 array. Returns SUCCESS if this is possible, and sets the 'result'
1951 variable. Otherwise returns FAILURE. */
1954 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
1956 expand_info expand_save
;
1961 switch (array
->expr_type
)
1964 flag
= gfc_suppress_error
;
1965 gfc_suppress_error
= 1;
1967 expand_save
= current_expand
;
1969 current_expand
.count
= result
;
1970 mpz_init_set_ui (*result
, 0);
1972 current_expand
.expand_work_function
= count_elements
;
1975 t
= expand_constructor (array
->value
.constructor
);
1976 gfc_suppress_error
= flag
;
1979 mpz_clear (*result
);
1980 current_expand
= expand_save
;
1984 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
1986 if (ref
->type
!= REF_ARRAY
)
1989 if (ref
->u
.ar
.type
== AR_FULL
)
1990 return spec_size (ref
->u
.ar
.as
, result
);
1992 if (ref
->u
.ar
.type
== AR_SECTION
)
1993 return ref_size (&ref
->u
.ar
, result
);
1996 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2000 if (array
->rank
== 0 || array
->shape
== NULL
)
2003 mpz_init_set_ui (*result
, 1);
2005 for (i
= 0; i
< array
->rank
; i
++)
2006 mpz_mul (*result
, *result
, array
->shape
[i
]);
2015 /* Given an array reference, return the shape of the reference in an
2016 array of mpz_t integers. */
2019 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2029 for (; d
< ar
->as
->rank
; d
++)
2030 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
2036 for (i
= 0; i
< ar
->dimen
; i
++)
2038 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2040 if (ref_dimen_size (ar
, i
, &shape
[d
]) == FAILURE
)
2053 for (d
--; d
>= 0; d
--)
2054 mpz_clear (shape
[d
]);
2060 /* Given an array expression, find the array reference structure that
2061 characterizes the reference. */
2064 gfc_find_array_ref (gfc_expr
*e
)
2068 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2069 if (ref
->type
== REF_ARRAY
2070 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2074 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2080 /* Find out if an array shape is known at compile time. */
2083 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2087 if (as
->type
!= AS_EXPLICIT
)
2090 for (i
= 0; i
< as
->rank
; i
++)
2091 if (!gfc_is_constant_expr (as
->lower
[i
])
2092 || !gfc_is_constant_expr (as
->upper
[i
]))