2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
26 #include "constructor.h"
28 /**************** Array reference matching subroutines *****************/
30 /* Copy an array reference structure. */
33 gfc_copy_array_ref (gfc_array_ref
*src
)
41 dest
= gfc_get_array_ref ();
45 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
47 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
48 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
49 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
52 dest
->offset
= gfc_copy_expr (src
->offset
);
58 /* Match a single dimension of an array reference. This can be a
59 single element or an array section. Any modifications we've made
60 to the ar structure are cleaned up by the caller. If the init
61 is set, we require the subscript to be a valid initialization
65 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
67 match m
= MATCH_ERROR
;
71 i
= ar
->dimen
+ ar
->codimen
;
73 ar
->c_where
[i
] = gfc_current_locus
;
74 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
76 /* We can't be sure of the difference between DIMEN_ELEMENT and
77 DIMEN_VECTOR until we know the type of the element itself at
80 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
82 if (gfc_match_char (':') == MATCH_YES
)
85 /* Get start element. */
86 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
90 m
= gfc_match_init_expr (&ar
->start
[i
]);
92 m
= gfc_match_expr (&ar
->start
[i
]);
94 if (m
== MATCH_NO
&& gfc_match_char ('*') == MATCH_YES
)
96 else if (m
== MATCH_NO
)
97 gfc_error ("Expected array subscript at %C");
101 if (gfc_match_char (':') == MATCH_NO
)
106 gfc_error ("Unexpected '*' in coarray subscript at %C");
110 /* Get an optional end element. Because we've seen the colon, we
111 definitely have a range along this dimension. */
113 ar
->dimen_type
[i
] = DIMEN_RANGE
;
115 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
118 m
= gfc_match_init_expr (&ar
->end
[i
]);
120 m
= gfc_match_expr (&ar
->end
[i
]);
122 if (m
== MATCH_ERROR
)
125 /* See if we have an optional stride. */
126 if (gfc_match_char (':') == MATCH_YES
)
130 gfc_error ("Strides not allowed in coarray subscript at %C");
134 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
135 : gfc_match_expr (&ar
->stride
[i
]);
138 gfc_error ("Expected array subscript stride at %C");
145 ar
->dimen_type
[i
] = DIMEN_STAR
;
151 /* Match an array reference, whether it is the whole array or a
152 particular elements or a section. If init is set, the reference has
153 to consist of init expressions. */
156 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
160 bool matched_bracket
= false;
162 memset (ar
, '\0', sizeof (ar
));
164 ar
->where
= gfc_current_locus
;
166 ar
->type
= AR_UNKNOWN
;
168 if (gfc_match_char ('[') == MATCH_YES
)
170 matched_bracket
= true;
174 if (gfc_match_char ('(') != MATCH_YES
)
181 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
183 m
= match_subscript (ar
, init
, false);
184 if (m
== MATCH_ERROR
)
187 if (gfc_match_char (')') == MATCH_YES
)
193 if (gfc_match_char (',') != MATCH_YES
)
195 gfc_error ("Invalid form of array reference at %C");
200 gfc_error ("Array reference at %C cannot have more than %d dimensions",
205 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
213 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
215 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
221 gfc_error ("Unexpected coarray designator at %C");
225 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
227 m
= match_subscript (ar
, init
, ar
->codimen
== (corank
- 1));
228 if (m
== MATCH_ERROR
)
231 if (gfc_match_char (']') == MATCH_YES
)
234 if (ar
->codimen
< corank
)
236 gfc_error ("Too few codimensions at %C, expected %d not %d",
237 corank
, ar
->codimen
);
243 if (gfc_match_char (',') != MATCH_YES
)
245 if (gfc_match_char ('*') == MATCH_YES
)
246 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
247 ar
->codimen
+ 1, corank
);
249 gfc_error ("Invalid form of coarray reference at %C");
252 if (ar
->codimen
>= corank
)
254 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
255 ar
->codimen
+ 1, corank
);
260 gfc_error ("Array reference at %C cannot have more than %d dimensions",
267 /************** Array specification matching subroutines ***************/
269 /* Free all of the expressions associated with array bounds
273 gfc_free_array_spec (gfc_array_spec
*as
)
280 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
282 gfc_free_expr (as
->lower
[i
]);
283 gfc_free_expr (as
->upper
[i
]);
290 /* Take an array bound, resolves the expression, that make up the
291 shape and check associated constraints. */
294 resolve_array_bound (gfc_expr
*e
, int check_constant
)
299 if (gfc_resolve_expr (e
) == FAILURE
300 || gfc_specification_expr (e
) == FAILURE
)
303 if (check_constant
&& gfc_is_constant_expr (e
) == 0)
305 gfc_error ("Variable '%s' at %L in this context must be constant",
306 e
->symtree
->n
.sym
->name
, &e
->where
);
314 /* Takes an array specification, resolves the expressions that make up
315 the shape and make sure everything is integral. */
318 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
326 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
329 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
333 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
336 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
339 /* If the size is negative in this dimension, set it to zero. */
340 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
341 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
342 && mpz_cmp (as
->upper
[i
]->value
.integer
,
343 as
->lower
[i
]->value
.integer
) < 0)
345 gfc_free_expr (as
->upper
[i
]);
346 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
347 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
348 as
->upper
[i
]->value
.integer
, 1);
356 /* Match a single array element specification. The return values as
357 well as the upper and lower bounds of the array spec are filled
358 in according to what we see on the input. The caller makes sure
359 individual specifications make sense as a whole.
362 Parsed Lower Upper Returned
363 ------------------------------------
364 : NULL NULL AS_DEFERRED (*)
366 x: x NULL AS_ASSUMED_SHAPE
368 x:* x NULL AS_ASSUMED_SIZE
369 * 1 NULL AS_ASSUMED_SIZE
371 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
372 is fixed during the resolution of formal interfaces.
374 Anything else AS_UNKNOWN. */
377 match_array_element_spec (gfc_array_spec
*as
)
379 gfc_expr
**upper
, **lower
;
382 lower
= &as
->lower
[as
->rank
+ as
->corank
- 1];
383 upper
= &as
->upper
[as
->rank
+ as
->corank
- 1];
385 if (gfc_match_char ('*') == MATCH_YES
)
387 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
388 return AS_ASSUMED_SIZE
;
391 if (gfc_match_char (':') == MATCH_YES
)
394 m
= gfc_match_expr (upper
);
396 gfc_error ("Expected expression in array specification at %C");
399 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
402 if (gfc_match_char (':') == MATCH_NO
)
404 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
411 if (gfc_match_char ('*') == MATCH_YES
)
412 return AS_ASSUMED_SIZE
;
414 m
= gfc_match_expr (upper
);
415 if (m
== MATCH_ERROR
)
418 return AS_ASSUMED_SHAPE
;
419 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
426 /* Matches an array specification, incidentally figuring out what sort
427 it is. Match either a normal array specification, or a coarray spec
428 or both. Optionally allow [:] for coarrays. */
431 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
433 array_type current_type
;
437 as
= gfc_get_array_spec ();
441 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
450 if (gfc_match_char ('(') != MATCH_YES
)
460 current_type
= match_array_element_spec (as
);
464 if (current_type
== AS_UNKNOWN
)
466 as
->type
= current_type
;
470 { /* See how current spec meshes with the existing. */
475 if (current_type
== AS_ASSUMED_SIZE
)
477 as
->type
= AS_ASSUMED_SIZE
;
481 if (current_type
== AS_EXPLICIT
)
484 gfc_error ("Bad array specification for an explicitly shaped "
489 case AS_ASSUMED_SHAPE
:
490 if ((current_type
== AS_ASSUMED_SHAPE
)
491 || (current_type
== AS_DEFERRED
))
494 gfc_error ("Bad array specification for assumed shape "
499 if (current_type
== AS_DEFERRED
)
502 if (current_type
== AS_ASSUMED_SHAPE
)
504 as
->type
= AS_ASSUMED_SHAPE
;
508 gfc_error ("Bad specification for deferred shape array at %C");
511 case AS_ASSUMED_SIZE
:
512 gfc_error ("Bad specification for assumed size array at %C");
516 if (gfc_match_char (')') == MATCH_YES
)
519 if (gfc_match_char (',') != MATCH_YES
)
521 gfc_error ("Expected another dimension in array declaration at %C");
525 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
527 gfc_error ("Array specification at %C has more than %d dimensions",
532 if (as
->corank
+ as
->rank
>= 7
533 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Array "
534 "specification at %C with more than 7 dimensions")
543 if (gfc_match_char ('[') != MATCH_YES
)
546 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Coarray declaration at %C")
550 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
552 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
559 current_type
= match_array_element_spec (as
);
561 if (current_type
== AS_UNKNOWN
)
565 as
->cotype
= current_type
;
568 { /* See how current spec meshes with the existing. */
573 if (current_type
== AS_ASSUMED_SIZE
)
575 as
->cotype
= AS_ASSUMED_SIZE
;
579 if (current_type
== AS_EXPLICIT
)
582 gfc_error ("Bad array specification for an explicitly "
583 "shaped array at %C");
587 case AS_ASSUMED_SHAPE
:
588 if ((current_type
== AS_ASSUMED_SHAPE
)
589 || (current_type
== AS_DEFERRED
))
592 gfc_error ("Bad array specification for assumed shape "
597 if (current_type
== AS_DEFERRED
)
600 if (current_type
== AS_ASSUMED_SHAPE
)
602 as
->cotype
= AS_ASSUMED_SHAPE
;
606 gfc_error ("Bad specification for deferred shape array at %C");
609 case AS_ASSUMED_SIZE
:
610 gfc_error ("Bad specification for assumed size array at %C");
614 if (gfc_match_char (']') == MATCH_YES
)
617 if (gfc_match_char (',') != MATCH_YES
)
619 gfc_error ("Expected another dimension in array declaration at %C");
623 if (as
->corank
>= GFC_MAX_DIMENSIONS
)
625 gfc_error ("Array specification at %C has more than %d "
626 "dimensions", GFC_MAX_DIMENSIONS
);
631 if (current_type
== AS_EXPLICIT
)
633 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
637 if (as
->cotype
== AS_ASSUMED_SIZE
)
638 as
->cotype
= AS_EXPLICIT
;
641 as
->type
= as
->cotype
;
644 if (as
->rank
== 0 && as
->corank
== 0)
647 gfc_free_array_spec (as
);
651 /* If a lower bounds of an assumed shape array is blank, put in one. */
652 if (as
->type
== AS_ASSUMED_SHAPE
)
654 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
656 if (as
->lower
[i
] == NULL
)
657 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
666 /* Something went wrong. */
667 gfc_free_array_spec (as
);
672 /* Given a symbol and an array specification, modify the symbol to
673 have that array specification. The error locus is needed in case
674 something goes wrong. On failure, the caller must free the spec. */
677 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
685 && gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
689 && gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
700 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
701 the codimension is simply added. */
702 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
704 sym
->as
->cotype
= as
->cotype
;
705 sym
->as
->corank
= as
->corank
;
706 for (i
= 0; i
< as
->corank
; i
++)
708 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
709 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
714 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
715 the dimension is added - but first the codimensions (if existing
716 need to be shifted to make space for the dimension. */
717 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
719 sym
->as
->rank
= as
->rank
;
720 sym
->as
->type
= as
->type
;
721 sym
->as
->cray_pointee
= as
->cray_pointee
;
722 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
724 for (i
= 0; i
< sym
->as
->corank
; i
++)
726 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
727 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
729 for (i
= 0; i
< as
->rank
; i
++)
731 sym
->as
->lower
[i
] = as
->lower
[i
];
732 sym
->as
->upper
[i
] = as
->upper
[i
];
741 /* Copy an array specification. */
744 gfc_copy_array_spec (gfc_array_spec
*src
)
746 gfc_array_spec
*dest
;
752 dest
= gfc_get_array_spec ();
756 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
758 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
759 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
766 /* Returns nonzero if the two expressions are equal. Only handles integer
770 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
772 if (bound1
== NULL
|| bound2
== NULL
773 || bound1
->expr_type
!= EXPR_CONSTANT
774 || bound2
->expr_type
!= EXPR_CONSTANT
775 || bound1
->ts
.type
!= BT_INTEGER
776 || bound2
->ts
.type
!= BT_INTEGER
)
777 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
779 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
786 /* Compares two array specifications. They must be constant or deferred
790 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
794 if (as1
== NULL
&& as2
== NULL
)
797 if (as1
== NULL
|| as2
== NULL
)
800 if (as1
->rank
!= as2
->rank
)
803 if (as1
->corank
!= as2
->corank
)
809 if (as1
->type
!= as2
->type
)
812 if (as1
->type
== AS_EXPLICIT
)
813 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
815 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
818 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
826 /****************** Array constructor functions ******************/
829 /* Given an expression node that might be an array constructor and a
830 symbol, make sure that no iterators in this or child constructors
831 use the symbol as an implied-DO iterator. Returns nonzero if a
832 duplicate was found. */
835 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
840 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
844 if (e
->expr_type
== EXPR_ARRAY
845 && check_duplicate_iterator (e
->value
.constructor
, master
))
848 if (c
->iterator
== NULL
)
851 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
853 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
854 "same name", master
->name
, &c
->where
);
864 /* Forward declaration because these functions are mutually recursive. */
865 static match
match_array_cons_element (gfc_constructor_base
*);
867 /* Match a list of array elements. */
870 match_array_list (gfc_constructor_base
*result
)
872 gfc_constructor_base head
;
880 old_loc
= gfc_current_locus
;
882 if (gfc_match_char ('(') == MATCH_NO
)
885 memset (&iter
, '\0', sizeof (gfc_iterator
));
888 m
= match_array_cons_element (&head
);
892 if (gfc_match_char (',') != MATCH_YES
)
900 m
= gfc_match_iterator (&iter
, 0);
903 if (m
== MATCH_ERROR
)
906 m
= match_array_cons_element (&head
);
907 if (m
== MATCH_ERROR
)
914 goto cleanup
; /* Could be a complex constant */
917 if (gfc_match_char (',') != MATCH_YES
)
926 if (gfc_match_char (')') != MATCH_YES
)
929 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
935 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
936 e
->value
.constructor
= head
;
938 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
939 p
->iterator
= gfc_get_iterator ();
945 gfc_error ("Syntax error in array constructor at %C");
949 gfc_constructor_free (head
);
950 gfc_free_iterator (&iter
, 0);
951 gfc_current_locus
= old_loc
;
956 /* Match a single element of an array constructor, which can be a
957 single expression or a list of elements. */
960 match_array_cons_element (gfc_constructor_base
*result
)
965 m
= match_array_list (result
);
969 m
= gfc_match_expr (&expr
);
973 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
978 /* Match an array constructor. */
981 gfc_match_array_constructor (gfc_expr
**result
)
983 gfc_constructor_base head
, new_cons
;
988 const char *end_delim
;
991 if (gfc_match (" (/") == MATCH_NO
)
993 if (gfc_match (" [") == MATCH_NO
)
997 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: [...] "
998 "style array constructors at %C") == FAILURE
)
1006 where
= gfc_current_locus
;
1007 head
= new_cons
= NULL
;
1010 /* Try to match an optional "type-spec ::" */
1011 if (gfc_match_decl_type_spec (&ts
, 0) == MATCH_YES
)
1013 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1017 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Array constructor "
1018 "including type specification at %C") == FAILURE
)
1024 gfc_current_locus
= where
;
1026 if (gfc_match (end_delim
) == MATCH_YES
)
1032 gfc_error ("Empty array constructor at %C is not allowed");
1039 m
= match_array_cons_element (&head
);
1040 if (m
== MATCH_ERROR
)
1045 if (gfc_match_char (',') == MATCH_NO
)
1049 if (gfc_match (end_delim
) == MATCH_NO
)
1053 /* Size must be calculated at resolution time. */
1056 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1060 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1062 expr
->value
.constructor
= head
;
1064 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1070 gfc_error ("Syntax error in array constructor at %C");
1073 gfc_constructor_free (head
);
1079 /************** Check array constructors for correctness **************/
1081 /* Given an expression, compare it's type with the type of the current
1082 constructor. Returns nonzero if an error was issued. The
1083 cons_state variable keeps track of whether the type of the
1084 constructor being read or resolved is known to be good, bad or just
1087 static gfc_typespec constructor_ts
;
1089 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1093 check_element_type (gfc_expr
*expr
, bool convert
)
1095 if (cons_state
== CONS_BAD
)
1096 return 0; /* Suppress further errors */
1098 if (cons_state
== CONS_START
)
1100 if (expr
->ts
.type
== BT_UNKNOWN
)
1101 cons_state
= CONS_BAD
;
1104 cons_state
= CONS_GOOD
;
1105 constructor_ts
= expr
->ts
;
1111 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1115 return gfc_convert_type (expr
, &constructor_ts
, 1) == SUCCESS
? 0 : 1;
1117 gfc_error ("Element in %s array constructor at %L is %s",
1118 gfc_typename (&constructor_ts
), &expr
->where
,
1119 gfc_typename (&expr
->ts
));
1121 cons_state
= CONS_BAD
;
1126 /* Recursive work function for gfc_check_constructor_type(). */
1129 check_constructor_type (gfc_constructor_base base
, bool convert
)
1134 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1138 if (e
->expr_type
== EXPR_ARRAY
)
1140 if (check_constructor_type (e
->value
.constructor
, convert
) == FAILURE
)
1146 if (check_element_type (e
, convert
))
1154 /* Check that all elements of an array constructor are the same type.
1155 On FAILURE, an error has been generated. */
1158 gfc_check_constructor_type (gfc_expr
*e
)
1162 if (e
->ts
.type
!= BT_UNKNOWN
)
1164 cons_state
= CONS_GOOD
;
1165 constructor_ts
= e
->ts
;
1169 cons_state
= CONS_START
;
1170 gfc_clear_ts (&constructor_ts
);
1173 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1174 typespec, and we will now convert the values on the fly. */
1175 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1176 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1177 e
->ts
= constructor_ts
;
1184 typedef struct cons_stack
1186 gfc_iterator
*iterator
;
1187 struct cons_stack
*previous
;
1191 static cons_stack
*base
;
1193 static gfc_try
check_constructor (gfc_constructor_base
, gfc_try (*) (gfc_expr
*));
1195 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1196 that that variable is an iteration variables. */
1199 gfc_check_iter_variable (gfc_expr
*expr
)
1204 sym
= expr
->symtree
->n
.sym
;
1206 for (c
= base
; c
; c
= c
->previous
)
1207 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1214 /* Recursive work function for gfc_check_constructor(). This amounts
1215 to calling the check function for each expression in the
1216 constructor, giving variables with the names of iterators a pass. */
1219 check_constructor (gfc_constructor_base ctor
, gfc_try (*check_function
) (gfc_expr
*))
1226 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1230 if (e
->expr_type
!= EXPR_ARRAY
)
1232 if ((*check_function
) (e
) == FAILURE
)
1237 element
.previous
= base
;
1238 element
.iterator
= c
->iterator
;
1241 t
= check_constructor (e
->value
.constructor
, check_function
);
1242 base
= element
.previous
;
1248 /* Nothing went wrong, so all OK. */
1253 /* Checks a constructor to see if it is a particular kind of
1254 expression -- specification, restricted, or initialization as
1255 determined by the check_function. */
1258 gfc_check_constructor (gfc_expr
*expr
, gfc_try (*check_function
) (gfc_expr
*))
1260 cons_stack
*base_save
;
1266 t
= check_constructor (expr
->value
.constructor
, check_function
);
1274 /**************** Simplification of array constructors ****************/
1276 iterator_stack
*iter_stack
;
1280 gfc_constructor_base base
;
1281 int extract_count
, extract_n
;
1282 gfc_expr
*extracted
;
1286 gfc_component
*component
;
1288 gfc_try (*expand_work_function
) (gfc_expr
*);
1292 static expand_info current_expand
;
1294 static gfc_try
expand_constructor (gfc_constructor_base
);
1297 /* Work function that counts the number of elements present in a
1301 count_elements (gfc_expr
*e
)
1306 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1309 if (gfc_array_size (e
, &result
) == FAILURE
)
1315 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1324 /* Work function that extracts a particular element from an array
1325 constructor, freeing the rest. */
1328 extract_element (gfc_expr
*e
)
1331 { /* Something unextractable */
1336 if (current_expand
.extract_count
== current_expand
.extract_n
)
1337 current_expand
.extracted
= e
;
1341 current_expand
.extract_count
++;
1347 /* Work function that constructs a new constructor out of the old one,
1348 stringing new elements together. */
1351 expand (gfc_expr
*e
)
1353 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1356 c
->n
.component
= current_expand
.component
;
1361 /* Given an initialization expression that is a variable reference,
1362 substitute the current value of the iteration variable. */
1365 gfc_simplify_iterator_var (gfc_expr
*e
)
1369 for (p
= iter_stack
; p
; p
= p
->prev
)
1370 if (e
->symtree
== p
->variable
)
1374 return; /* Variable not found */
1376 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1378 mpz_set (e
->value
.integer
, p
->value
);
1384 /* Expand an expression with that is inside of a constructor,
1385 recursing into other constructors if present. */
1388 expand_expr (gfc_expr
*e
)
1390 if (e
->expr_type
== EXPR_ARRAY
)
1391 return expand_constructor (e
->value
.constructor
);
1393 e
= gfc_copy_expr (e
);
1395 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1401 return current_expand
.expand_work_function (e
);
1406 expand_iterator (gfc_constructor
*c
)
1408 gfc_expr
*start
, *end
, *step
;
1409 iterator_stack frame
;
1418 mpz_init (frame
.value
);
1421 start
= gfc_copy_expr (c
->iterator
->start
);
1422 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1425 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1428 end
= gfc_copy_expr (c
->iterator
->end
);
1429 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1432 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1435 step
= gfc_copy_expr (c
->iterator
->step
);
1436 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1439 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1442 if (mpz_sgn (step
->value
.integer
) == 0)
1444 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1448 /* Calculate the trip count of the loop. */
1449 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1450 mpz_add (trip
, trip
, step
->value
.integer
);
1451 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1453 mpz_set (frame
.value
, start
->value
.integer
);
1455 frame
.prev
= iter_stack
;
1456 frame
.variable
= c
->iterator
->var
->symtree
;
1457 iter_stack
= &frame
;
1459 while (mpz_sgn (trip
) > 0)
1461 if (expand_expr (c
->expr
) == FAILURE
)
1464 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1465 mpz_sub_ui (trip
, trip
, 1);
1471 gfc_free_expr (start
);
1472 gfc_free_expr (end
);
1473 gfc_free_expr (step
);
1476 mpz_clear (frame
.value
);
1478 iter_stack
= frame
.prev
;
1484 /* Expand a constructor into constant constructors without any
1485 iterators, calling the work function for each of the expanded
1486 expressions. The work function needs to either save or free the
1487 passed expression. */
1490 expand_constructor (gfc_constructor_base base
)
1495 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1497 if (c
->iterator
!= NULL
)
1499 if (expand_iterator (c
) == FAILURE
)
1506 if (e
->expr_type
== EXPR_ARRAY
)
1508 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1514 e
= gfc_copy_expr (e
);
1515 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1520 current_expand
.offset
= &c
->offset
;
1521 current_expand
.component
= c
->n
.component
;
1522 if (current_expand
.expand_work_function (e
) == FAILURE
)
1529 /* Given an array expression and an element number (starting at zero),
1530 return a pointer to the array element. NULL is returned if the
1531 size of the array has been exceeded. The expression node returned
1532 remains a part of the array and should not be freed. Access is not
1533 efficient at all, but this is another place where things do not
1534 have to be particularly fast. */
1537 gfc_get_array_element (gfc_expr
*array
, int element
)
1539 expand_info expand_save
;
1543 expand_save
= current_expand
;
1544 current_expand
.extract_n
= element
;
1545 current_expand
.expand_work_function
= extract_element
;
1546 current_expand
.extracted
= NULL
;
1547 current_expand
.extract_count
= 0;
1551 rc
= expand_constructor (array
->value
.constructor
);
1552 e
= current_expand
.extracted
;
1553 current_expand
= expand_save
;
1562 /* Top level subroutine for expanding constructors. We only expand
1563 constructor if they are small enough. */
1566 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1568 expand_info expand_save
;
1572 /* If we can successfully get an array element at the max array size then
1573 the array is too big to expand, so we just return. */
1574 f
= gfc_get_array_element (e
, gfc_option
.flag_max_array_constructor
);
1580 gfc_error ("The number of elements in the array constructor "
1581 "at %L requires an increase of the allowed %d "
1582 "upper limit. See -fmax-array-constructor "
1583 "option", &e
->where
,
1584 gfc_option
.flag_max_array_constructor
);
1590 /* We now know the array is not too big so go ahead and try to expand it. */
1591 expand_save
= current_expand
;
1592 current_expand
.base
= NULL
;
1596 current_expand
.expand_work_function
= expand
;
1598 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1600 gfc_constructor_free (current_expand
.base
);
1605 gfc_constructor_free (e
->value
.constructor
);
1606 e
->value
.constructor
= current_expand
.base
;
1611 current_expand
= expand_save
;
1617 /* Work function for checking that an element of a constructor is a
1618 constant, after removal of any iteration variables. We return
1619 FAILURE if not so. */
1622 is_constant_element (gfc_expr
*e
)
1626 rv
= gfc_is_constant_expr (e
);
1629 return rv
? SUCCESS
: FAILURE
;
1633 /* Given an array constructor, determine if the constructor is
1634 constant or not by expanding it and making sure that all elements
1635 are constants. This is a bit of a hack since something like (/ (i,
1636 i=1,100000000) /) will take a while as* opposed to a more clever
1637 function that traverses the expression tree. FIXME. */
1640 gfc_constant_ac (gfc_expr
*e
)
1642 expand_info expand_save
;
1646 expand_save
= current_expand
;
1647 current_expand
.expand_work_function
= is_constant_element
;
1649 rc
= expand_constructor (e
->value
.constructor
);
1651 current_expand
= expand_save
;
1659 /* Returns nonzero if an array constructor has been completely
1660 expanded (no iterators) and zero if iterators are present. */
1663 gfc_expanded_ac (gfc_expr
*e
)
1667 if (e
->expr_type
== EXPR_ARRAY
)
1668 for (c
= gfc_constructor_first (e
->value
.constructor
);
1669 c
; c
= gfc_constructor_next (c
))
1670 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1677 /*************** Type resolution of array constructors ***************/
1679 /* Recursive array list resolution function. All of the elements must
1680 be of the same type. */
1683 resolve_array_list (gfc_constructor_base base
)
1690 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1692 if (c
->iterator
!= NULL
1693 && gfc_resolve_iterator (c
->iterator
, false) == FAILURE
)
1696 if (gfc_resolve_expr (c
->expr
) == FAILURE
)
1703 /* Resolve character array constructor. If it has a specified constant character
1704 length, pad/truncate the elements here; if the length is not specified and
1705 all elements are of compile-time known length, emit an error as this is
1709 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1714 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1715 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1717 if (expr
->ts
.u
.cl
== NULL
)
1719 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1720 p
; p
= gfc_constructor_next (p
))
1721 if (p
->expr
->ts
.u
.cl
!= NULL
)
1723 /* Ensure that if there is a char_len around that it is
1724 used; otherwise the middle-end confuses them! */
1725 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1729 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1736 if (expr
->ts
.u
.cl
->length
== NULL
)
1738 /* Check that all constant string elements have the same length until
1739 we reach the end or find a variable-length one. */
1741 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1742 p
; p
= gfc_constructor_next (p
))
1744 int current_length
= -1;
1746 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1747 if (ref
->type
== REF_SUBSTRING
1748 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1749 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1752 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1753 current_length
= p
->expr
->value
.character
.length
;
1757 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1758 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1759 current_length
= (int) j
;
1761 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1762 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1765 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1766 current_length
= (int) j
;
1771 gcc_assert (current_length
!= -1);
1773 if (found_length
== -1)
1774 found_length
= current_length
;
1775 else if (found_length
!= current_length
)
1777 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1778 " constructor at %L", found_length
, current_length
,
1783 gcc_assert (found_length
== current_length
);
1786 gcc_assert (found_length
!= -1);
1788 /* Update the character length of the array constructor. */
1789 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1790 NULL
, found_length
);
1794 /* We've got a character length specified. It should be an integer,
1795 otherwise an error is signalled elsewhere. */
1796 gcc_assert (expr
->ts
.u
.cl
->length
);
1798 /* If we've got a constant character length, pad according to this.
1799 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1800 max_length only if they pass. */
1801 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1803 /* Now pad/truncate the elements accordingly to the specified character
1804 length. This is ok inside this conditional, as in the case above
1805 (without typespec) all elements are verified to have the same length
1807 if (found_length
!= -1)
1808 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1809 p
; p
= gfc_constructor_next (p
))
1810 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1812 gfc_expr
*cl
= NULL
;
1813 int current_length
= -1;
1816 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1818 cl
= p
->expr
->ts
.u
.cl
->length
;
1819 gfc_extract_int (cl
, ¤t_length
);
1822 /* If gfc_extract_int above set current_length, we implicitly
1823 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1825 has_ts
= (expr
->ts
.u
.cl
&& expr
->ts
.u
.cl
->length_from_typespec
);
1828 || (current_length
!= -1 && current_length
< found_length
))
1829 gfc_set_constant_character_len (found_length
, p
->expr
,
1830 has_ts
? -1 : found_length
);
1838 /* Resolve all of the expressions in an array list. */
1841 gfc_resolve_array_constructor (gfc_expr
*expr
)
1845 t
= resolve_array_list (expr
->value
.constructor
);
1847 t
= gfc_check_constructor_type (expr
);
1849 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1850 the call to this function, so we don't need to call it here; if it was
1851 called twice, an error message there would be duplicated. */
1857 /* Copy an iterator structure. */
1860 gfc_copy_iterator (gfc_iterator
*src
)
1867 dest
= gfc_get_iterator ();
1869 dest
->var
= gfc_copy_expr (src
->var
);
1870 dest
->start
= gfc_copy_expr (src
->start
);
1871 dest
->end
= gfc_copy_expr (src
->end
);
1872 dest
->step
= gfc_copy_expr (src
->step
);
1878 /********* Subroutines for determining the size of an array *********/
1880 /* These are needed just to accommodate RESHAPE(). There are no
1881 diagnostics here, we just return a negative number if something
1885 /* Get the size of single dimension of an array specification. The
1886 array is guaranteed to be one dimensional. */
1889 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
1894 if (dimen
< 0 || dimen
> as
->rank
- 1)
1895 gfc_internal_error ("spec_dimen_size(): Bad dimension");
1897 if (as
->type
!= AS_EXPLICIT
1898 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
1899 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
1900 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
1901 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
1906 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
1907 as
->lower
[dimen
]->value
.integer
);
1909 mpz_add_ui (*result
, *result
, 1);
1916 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
1921 mpz_init_set_ui (*result
, 1);
1923 for (d
= 0; d
< as
->rank
; d
++)
1925 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
1927 mpz_clear (*result
);
1931 mpz_mul (*result
, *result
, size
);
1939 /* Get the number of elements in an array section. */
1942 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
)
1944 mpz_t upper
, lower
, stride
;
1947 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
1948 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1950 switch (ar
->dimen_type
[dimen
])
1954 mpz_set_ui (*result
, 1);
1959 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
1968 if (ar
->start
[dimen
] == NULL
)
1970 if (ar
->as
->lower
[dimen
] == NULL
1971 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1973 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
1977 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1979 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
1982 if (ar
->end
[dimen
] == NULL
)
1984 if (ar
->as
->upper
[dimen
] == NULL
1985 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1987 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
1991 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
1993 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
1996 if (ar
->stride
[dimen
] == NULL
)
1997 mpz_set_ui (stride
, 1);
2000 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2002 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2006 mpz_sub (*result
, upper
, lower
);
2007 mpz_add (*result
, *result
, stride
);
2008 mpz_div (*result
, *result
, stride
);
2010 /* Zero stride caught earlier. */
2011 if (mpz_cmp_ui (*result
, 0) < 0)
2012 mpz_set_ui (*result
, 0);
2022 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2030 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2035 mpz_init_set_ui (*result
, 1);
2037 for (d
= 0; d
< ar
->dimen
; d
++)
2039 if (gfc_ref_dimen_size (ar
, d
, &size
) == FAILURE
)
2041 mpz_clear (*result
);
2045 mpz_mul (*result
, *result
, size
);
2053 /* Given an array expression and a dimension, figure out how many
2054 elements it has along that dimension. Returns SUCCESS if we were
2055 able to return a result in the 'result' variable, FAILURE
2059 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2064 if (dimen
< 0 || array
== NULL
|| dimen
> array
->rank
- 1)
2065 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2067 switch (array
->expr_type
)
2071 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2073 if (ref
->type
!= REF_ARRAY
)
2076 if (ref
->u
.ar
.type
== AR_FULL
)
2077 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2079 if (ref
->u
.ar
.type
== AR_SECTION
)
2081 for (i
= 0; dimen
>= 0; i
++)
2082 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2085 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
);
2089 if (array
->shape
&& array
->shape
[dimen
])
2091 mpz_init_set (*result
, array
->shape
[dimen
]);
2095 if (array
->symtree
->n
.sym
->attr
.generic
2096 && array
->value
.function
.esym
!= NULL
)
2098 if (spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
)
2102 else if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
)
2109 if (array
->shape
== NULL
) {
2110 /* Expressions with rank > 1 should have "shape" properly set */
2111 if ( array
->rank
!= 1 )
2112 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2113 return gfc_array_size(array
, result
);
2118 if (array
->shape
== NULL
)
2121 mpz_init_set (*result
, array
->shape
[dimen
]);
2130 /* Given an array expression, figure out how many elements are in the
2131 array. Returns SUCCESS if this is possible, and sets the 'result'
2132 variable. Otherwise returns FAILURE. */
2135 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2137 expand_info expand_save
;
2142 switch (array
->expr_type
)
2145 gfc_push_suppress_errors ();
2147 expand_save
= current_expand
;
2149 current_expand
.count
= result
;
2150 mpz_init_set_ui (*result
, 0);
2152 current_expand
.expand_work_function
= count_elements
;
2155 t
= expand_constructor (array
->value
.constructor
);
2157 gfc_pop_suppress_errors ();
2160 mpz_clear (*result
);
2161 current_expand
= expand_save
;
2165 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2167 if (ref
->type
!= REF_ARRAY
)
2170 if (ref
->u
.ar
.type
== AR_FULL
)
2171 return spec_size (ref
->u
.ar
.as
, result
);
2173 if (ref
->u
.ar
.type
== AR_SECTION
)
2174 return ref_size (&ref
->u
.ar
, result
);
2177 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2181 if (array
->rank
== 0 || array
->shape
== NULL
)
2184 mpz_init_set_ui (*result
, 1);
2186 for (i
= 0; i
< array
->rank
; i
++)
2187 mpz_mul (*result
, *result
, array
->shape
[i
]);
2196 /* Given an array reference, return the shape of the reference in an
2197 array of mpz_t integers. */
2200 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2210 for (; d
< ar
->as
->rank
; d
++)
2211 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
2217 for (i
= 0; i
< ar
->dimen
; i
++)
2219 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2221 if (gfc_ref_dimen_size (ar
, i
, &shape
[d
]) == FAILURE
)
2234 for (d
--; d
>= 0; d
--)
2235 mpz_clear (shape
[d
]);
2241 /* Given an array expression, find the array reference structure that
2242 characterizes the reference. */
2245 gfc_find_array_ref (gfc_expr
*e
)
2249 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2250 if (ref
->type
== REF_ARRAY
2251 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
2252 || (ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.dimen
== 0)))
2256 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2262 /* Find out if an array shape is known at compile time. */
2265 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2269 if (as
->type
!= AS_EXPLICIT
)
2272 for (i
= 0; i
< as
->rank
; i
++)
2273 if (!gfc_is_constant_expr (as
->lower
[i
])
2274 || !gfc_is_constant_expr (as
->upper
[i
]))