2 Copyright (C) 2000-2015 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 3, 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 COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "constructor.h"
30 /**************** Array reference matching subroutines *****************/
32 /* Copy an array reference structure. */
35 gfc_copy_array_ref (gfc_array_ref
*src
)
43 dest
= gfc_get_array_ref ();
47 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
49 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
50 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
51 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
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 gfc_gobble_whitespace ();
74 ar
->c_where
[i
] = gfc_current_locus
;
75 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
77 /* We can't be sure of the difference between DIMEN_ELEMENT and
78 DIMEN_VECTOR until we know the type of the element itself at
81 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
83 if (gfc_match_char (':') == MATCH_YES
)
86 /* Get start element. */
87 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
91 m
= gfc_match_init_expr (&ar
->start
[i
]);
93 m
= gfc_match_expr (&ar
->start
[i
]);
96 gfc_error ("Expected array subscript at %C");
100 if (gfc_match_char (':') == MATCH_NO
)
105 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
109 /* Get an optional end element. Because we've seen the colon, we
110 definitely have a range along this dimension. */
112 ar
->dimen_type
[i
] = DIMEN_RANGE
;
114 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
117 m
= gfc_match_init_expr (&ar
->end
[i
]);
119 m
= gfc_match_expr (&ar
->end
[i
]);
121 if (m
== MATCH_ERROR
)
124 /* See if we have an optional stride. */
125 if (gfc_match_char (':') == MATCH_YES
)
129 gfc_error ("Strides not allowed in coarray subscript at %C");
133 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
134 : gfc_match_expr (&ar
->stride
[i
]);
137 gfc_error ("Expected array subscript stride at %C");
144 ar
->dimen_type
[i
] = DIMEN_STAR
;
150 /* Match an array reference, whether it is the whole array or a
151 particular elements or a section. If init is set, the reference has
152 to consist of init expressions. */
155 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
159 bool matched_bracket
= false;
161 memset (ar
, '\0', sizeof (*ar
));
163 ar
->where
= gfc_current_locus
;
165 ar
->type
= AR_UNKNOWN
;
167 if (gfc_match_char ('[') == MATCH_YES
)
169 matched_bracket
= true;
173 if (gfc_match_char ('(') != MATCH_YES
)
180 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
182 m
= match_subscript (ar
, init
, false);
183 if (m
== MATCH_ERROR
)
186 if (gfc_match_char (')') == MATCH_YES
)
192 if (gfc_match_char (',') != MATCH_YES
)
194 gfc_error ("Invalid form of array reference at %C");
199 gfc_error ("Array reference at %C cannot have more than %d dimensions",
204 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
212 if (flag_coarray
== GFC_FCOARRAY_NONE
)
214 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
220 gfc_error ("Unexpected coarray designator at %C");
224 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
226 m
= match_subscript (ar
, init
, true);
227 if (m
== MATCH_ERROR
)
230 if (gfc_match_char (']') == MATCH_YES
)
233 if (ar
->codimen
< corank
)
235 gfc_error ("Too few codimensions at %C, expected %d not %d",
236 corank
, ar
->codimen
);
239 if (ar
->codimen
> corank
)
241 gfc_error ("Too many codimensions at %C, expected %d not %d",
242 corank
, ar
->codimen
);
248 if (gfc_match_char (',') != MATCH_YES
)
250 if (gfc_match_char ('*') == MATCH_YES
)
251 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
252 ar
->codimen
+ 1, corank
);
254 gfc_error ("Invalid form of coarray reference at %C");
257 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
259 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
260 ar
->codimen
+ 1, corank
);
264 if (ar
->codimen
>= corank
)
266 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
267 ar
->codimen
+ 1, corank
);
272 gfc_error ("Array reference at %C cannot have more than %d dimensions",
279 /************** Array specification matching subroutines ***************/
281 /* Free all of the expressions associated with array bounds
285 gfc_free_array_spec (gfc_array_spec
*as
)
292 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
294 gfc_free_expr (as
->lower
[i
]);
295 gfc_free_expr (as
->upper
[i
]);
302 /* Take an array bound, resolves the expression, that make up the
303 shape and check associated constraints. */
306 resolve_array_bound (gfc_expr
*e
, int check_constant
)
311 if (!gfc_resolve_expr (e
)
312 || !gfc_specification_expr (e
))
315 if (check_constant
&& !gfc_is_constant_expr (e
))
317 if (e
->expr_type
== EXPR_VARIABLE
)
318 gfc_error ("Variable %qs at %L in this context must be constant",
319 e
->symtree
->n
.sym
->name
, &e
->where
);
321 gfc_error ("Expression at %L in this context must be constant",
330 /* Takes an array specification, resolves the expressions that make up
331 the shape and make sure everything is integral. */
334 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
345 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
348 if (!resolve_array_bound (e
, check_constant
))
352 if (!resolve_array_bound (e
, check_constant
))
355 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
358 /* If the size is negative in this dimension, set it to zero. */
359 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
360 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
361 && mpz_cmp (as
->upper
[i
]->value
.integer
,
362 as
->lower
[i
]->value
.integer
) < 0)
364 gfc_free_expr (as
->upper
[i
]);
365 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
366 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
367 as
->upper
[i
]->value
.integer
, 1);
377 /* Match a single array element specification. The return values as
378 well as the upper and lower bounds of the array spec are filled
379 in according to what we see on the input. The caller makes sure
380 individual specifications make sense as a whole.
383 Parsed Lower Upper Returned
384 ------------------------------------
385 : NULL NULL AS_DEFERRED (*)
387 x: x NULL AS_ASSUMED_SHAPE
389 x:* x NULL AS_ASSUMED_SIZE
390 * 1 NULL AS_ASSUMED_SIZE
392 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
393 is fixed during the resolution of formal interfaces.
395 Anything else AS_UNKNOWN. */
398 match_array_element_spec (gfc_array_spec
*as
)
400 gfc_expr
**upper
, **lower
;
404 rank
= as
->rank
== -1 ? 0 : as
->rank
;
405 lower
= &as
->lower
[rank
+ as
->corank
- 1];
406 upper
= &as
->upper
[rank
+ as
->corank
- 1];
408 if (gfc_match_char ('*') == MATCH_YES
)
410 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
411 return AS_ASSUMED_SIZE
;
414 if (gfc_match_char (':') == MATCH_YES
)
417 m
= gfc_match_expr (upper
);
419 gfc_error ("Expected expression in array specification at %C");
422 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
425 if (gfc_match_char (':') == MATCH_NO
)
427 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
434 if (gfc_match_char ('*') == MATCH_YES
)
435 return AS_ASSUMED_SIZE
;
437 m
= gfc_match_expr (upper
);
438 if (m
== MATCH_ERROR
)
441 return AS_ASSUMED_SHAPE
;
442 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
449 /* Matches an array specification, incidentally figuring out what sort
450 it is. Match either a normal array specification, or a coarray spec
451 or both. Optionally allow [:] for coarrays. */
454 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
456 array_type current_type
;
460 as
= gfc_get_array_spec ();
465 if (gfc_match_char ('(') != MATCH_YES
)
472 if (gfc_match (" .. )") == MATCH_YES
)
474 as
->type
= AS_ASSUMED_RANK
;
477 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C"))
488 current_type
= match_array_element_spec (as
);
490 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
491 and implied-shape specifications. If the rank is at least 2, we can
492 distinguish between them. But for rank 1, we currently return
493 ASSUMED_SIZE; this gets adjusted later when we know for sure
494 whether the symbol parsed is a PARAMETER or not. */
498 if (current_type
== AS_UNKNOWN
)
500 as
->type
= current_type
;
504 { /* See how current spec meshes with the existing. */
508 case AS_IMPLIED_SHAPE
:
509 if (current_type
!= AS_ASSUMED_SHAPE
)
511 gfc_error ("Bad array specification for implied-shape"
518 if (current_type
== AS_ASSUMED_SIZE
)
520 as
->type
= AS_ASSUMED_SIZE
;
524 if (current_type
== AS_EXPLICIT
)
527 gfc_error ("Bad array specification for an explicitly shaped "
532 case AS_ASSUMED_SHAPE
:
533 if ((current_type
== AS_ASSUMED_SHAPE
)
534 || (current_type
== AS_DEFERRED
))
537 gfc_error ("Bad array specification for assumed shape "
542 if (current_type
== AS_DEFERRED
)
545 if (current_type
== AS_ASSUMED_SHAPE
)
547 as
->type
= AS_ASSUMED_SHAPE
;
551 gfc_error ("Bad specification for deferred shape array at %C");
554 case AS_ASSUMED_SIZE
:
555 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
557 as
->type
= AS_IMPLIED_SHAPE
;
561 gfc_error ("Bad specification for assumed size array at %C");
564 case AS_ASSUMED_RANK
:
568 if (gfc_match_char (')') == MATCH_YES
)
571 if (gfc_match_char (',') != MATCH_YES
)
573 gfc_error ("Expected another dimension in array declaration at %C");
577 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
579 gfc_error ("Array specification at %C has more than %d dimensions",
584 if (as
->corank
+ as
->rank
>= 7
585 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
586 "with more than 7 dimensions"))
594 if (gfc_match_char ('[') != MATCH_YES
)
597 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
600 if (flag_coarray
== GFC_FCOARRAY_NONE
)
602 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
606 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
608 gfc_error ("Array specification at %C has more than %d "
609 "dimensions", GFC_MAX_DIMENSIONS
);
616 current_type
= match_array_element_spec (as
);
618 if (current_type
== AS_UNKNOWN
)
622 as
->cotype
= current_type
;
625 { /* See how current spec meshes with the existing. */
626 case AS_IMPLIED_SHAPE
:
631 if (current_type
== AS_ASSUMED_SIZE
)
633 as
->cotype
= AS_ASSUMED_SIZE
;
637 if (current_type
== AS_EXPLICIT
)
640 gfc_error ("Bad array specification for an explicitly "
641 "shaped array at %C");
645 case AS_ASSUMED_SHAPE
:
646 if ((current_type
== AS_ASSUMED_SHAPE
)
647 || (current_type
== AS_DEFERRED
))
650 gfc_error ("Bad array specification for assumed shape "
655 if (current_type
== AS_DEFERRED
)
658 if (current_type
== AS_ASSUMED_SHAPE
)
660 as
->cotype
= AS_ASSUMED_SHAPE
;
664 gfc_error ("Bad specification for deferred shape array at %C");
667 case AS_ASSUMED_SIZE
:
668 gfc_error ("Bad specification for assumed size array at %C");
671 case AS_ASSUMED_RANK
:
675 if (gfc_match_char (']') == MATCH_YES
)
678 if (gfc_match_char (',') != MATCH_YES
)
680 gfc_error ("Expected another dimension in array declaration at %C");
684 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
686 gfc_error ("Array specification at %C has more than %d "
687 "dimensions", GFC_MAX_DIMENSIONS
);
692 if (current_type
== AS_EXPLICIT
)
694 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
698 if (as
->cotype
== AS_ASSUMED_SIZE
)
699 as
->cotype
= AS_EXPLICIT
;
702 as
->type
= as
->cotype
;
705 if (as
->rank
== 0 && as
->corank
== 0)
708 gfc_free_array_spec (as
);
712 /* If a lower bounds of an assumed shape array is blank, put in one. */
713 if (as
->type
== AS_ASSUMED_SHAPE
)
715 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
717 if (as
->lower
[i
] == NULL
)
718 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
727 /* Something went wrong. */
728 gfc_free_array_spec (as
);
733 /* Given a symbol and an array specification, modify the symbol to
734 have that array specification. The error locus is needed in case
735 something goes wrong. On failure, the caller must free the spec. */
738 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
746 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
750 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
759 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
760 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
762 gfc_error ("The assumed-rank array %qs at %L shall not have a "
763 "codimension", sym
->name
, error_loc
);
769 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
770 the codimension is simply added. */
771 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
773 sym
->as
->cotype
= as
->cotype
;
774 sym
->as
->corank
= as
->corank
;
775 for (i
= 0; i
< as
->corank
; i
++)
777 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
778 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
783 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
784 the dimension is added - but first the codimensions (if existing
785 need to be shifted to make space for the dimension. */
786 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
788 sym
->as
->rank
= as
->rank
;
789 sym
->as
->type
= as
->type
;
790 sym
->as
->cray_pointee
= as
->cray_pointee
;
791 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
793 for (i
= 0; i
< sym
->as
->corank
; i
++)
795 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
796 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
798 for (i
= 0; i
< as
->rank
; i
++)
800 sym
->as
->lower
[i
] = as
->lower
[i
];
801 sym
->as
->upper
[i
] = as
->upper
[i
];
810 /* Copy an array specification. */
813 gfc_copy_array_spec (gfc_array_spec
*src
)
815 gfc_array_spec
*dest
;
821 dest
= gfc_get_array_spec ();
825 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
827 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
828 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
835 /* Returns nonzero if the two expressions are equal. Only handles integer
839 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
841 if (bound1
== NULL
|| bound2
== NULL
842 || bound1
->expr_type
!= EXPR_CONSTANT
843 || bound2
->expr_type
!= EXPR_CONSTANT
844 || bound1
->ts
.type
!= BT_INTEGER
845 || bound2
->ts
.type
!= BT_INTEGER
)
846 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
848 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
855 /* Compares two array specifications. They must be constant or deferred
859 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
863 if (as1
== NULL
&& as2
== NULL
)
866 if (as1
== NULL
|| as2
== NULL
)
869 if (as1
->rank
!= as2
->rank
)
872 if (as1
->corank
!= as2
->corank
)
878 if (as1
->type
!= as2
->type
)
881 if (as1
->type
== AS_EXPLICIT
)
882 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
884 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
887 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
895 /****************** Array constructor functions ******************/
898 /* Given an expression node that might be an array constructor and a
899 symbol, make sure that no iterators in this or child constructors
900 use the symbol as an implied-DO iterator. Returns nonzero if a
901 duplicate was found. */
904 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
909 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
913 if (e
->expr_type
== EXPR_ARRAY
914 && check_duplicate_iterator (e
->value
.constructor
, master
))
917 if (c
->iterator
== NULL
)
920 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
922 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
923 "same name", master
->name
, &c
->where
);
933 /* Forward declaration because these functions are mutually recursive. */
934 static match
match_array_cons_element (gfc_constructor_base
*);
936 /* Match a list of array elements. */
939 match_array_list (gfc_constructor_base
*result
)
941 gfc_constructor_base head
;
949 old_loc
= gfc_current_locus
;
951 if (gfc_match_char ('(') == MATCH_NO
)
954 memset (&iter
, '\0', sizeof (gfc_iterator
));
957 m
= match_array_cons_element (&head
);
961 if (gfc_match_char (',') != MATCH_YES
)
969 m
= gfc_match_iterator (&iter
, 0);
972 if (m
== MATCH_ERROR
)
975 m
= match_array_cons_element (&head
);
976 if (m
== MATCH_ERROR
)
983 goto cleanup
; /* Could be a complex constant */
986 if (gfc_match_char (',') != MATCH_YES
)
995 if (gfc_match_char (')') != MATCH_YES
)
998 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1004 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1005 e
->value
.constructor
= head
;
1007 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1008 p
->iterator
= gfc_get_iterator ();
1009 *p
->iterator
= iter
;
1014 gfc_error ("Syntax error in array constructor at %C");
1018 gfc_constructor_free (head
);
1019 gfc_free_iterator (&iter
, 0);
1020 gfc_current_locus
= old_loc
;
1025 /* Match a single element of an array constructor, which can be a
1026 single expression or a list of elements. */
1029 match_array_cons_element (gfc_constructor_base
*result
)
1034 m
= match_array_list (result
);
1038 m
= gfc_match_expr (&expr
);
1042 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1047 /* Match an array constructor. */
1050 gfc_match_array_constructor (gfc_expr
**result
)
1052 gfc_constructor_base head
, new_cons
;
1053 gfc_undo_change_set changed_syms
;
1058 const char *end_delim
;
1061 if (gfc_match (" (/") == MATCH_NO
)
1063 if (gfc_match (" [") == MATCH_NO
)
1067 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1068 "style array constructors at %C"))
1076 where
= gfc_current_locus
;
1077 head
= new_cons
= NULL
;
1080 /* Try to match an optional "type-spec ::" */
1082 gfc_new_undo_checkpoint (changed_syms
);
1083 m
= gfc_match_type_spec (&ts
);
1086 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1090 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1091 "including type specification at %C"))
1093 gfc_restore_last_undo_checkpoint ();
1099 gfc_error ("Type-spec at %L cannot contain a deferred "
1100 "type parameter", &where
);
1101 gfc_restore_last_undo_checkpoint ();
1106 else if (m
== MATCH_ERROR
)
1108 gfc_restore_last_undo_checkpoint ();
1113 gfc_drop_last_undo_checkpoint ();
1116 gfc_restore_last_undo_checkpoint ();
1117 gfc_current_locus
= where
;
1120 if (gfc_match (end_delim
) == MATCH_YES
)
1126 gfc_error ("Empty array constructor at %C is not allowed");
1133 m
= match_array_cons_element (&head
);
1134 if (m
== MATCH_ERROR
)
1139 if (gfc_match_char (',') == MATCH_NO
)
1143 if (gfc_match (end_delim
) == MATCH_NO
)
1147 /* Size must be calculated at resolution time. */
1150 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1154 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1156 expr
->value
.constructor
= head
;
1158 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1164 gfc_error ("Syntax error in array constructor at %C");
1167 gfc_constructor_free (head
);
1173 /************** Check array constructors for correctness **************/
1175 /* Given an expression, compare it's type with the type of the current
1176 constructor. Returns nonzero if an error was issued. The
1177 cons_state variable keeps track of whether the type of the
1178 constructor being read or resolved is known to be good, bad or just
1181 static gfc_typespec constructor_ts
;
1183 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1187 check_element_type (gfc_expr
*expr
, bool convert
)
1189 if (cons_state
== CONS_BAD
)
1190 return 0; /* Suppress further errors */
1192 if (cons_state
== CONS_START
)
1194 if (expr
->ts
.type
== BT_UNKNOWN
)
1195 cons_state
= CONS_BAD
;
1198 cons_state
= CONS_GOOD
;
1199 constructor_ts
= expr
->ts
;
1205 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1209 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1211 gfc_error ("Element in %s array constructor at %L is %s",
1212 gfc_typename (&constructor_ts
), &expr
->where
,
1213 gfc_typename (&expr
->ts
));
1215 cons_state
= CONS_BAD
;
1220 /* Recursive work function for gfc_check_constructor_type(). */
1223 check_constructor_type (gfc_constructor_base base
, bool convert
)
1228 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1232 if (e
->expr_type
== EXPR_ARRAY
)
1234 if (!check_constructor_type (e
->value
.constructor
, convert
))
1240 if (check_element_type (e
, convert
))
1248 /* Check that all elements of an array constructor are the same type.
1249 On false, an error has been generated. */
1252 gfc_check_constructor_type (gfc_expr
*e
)
1256 if (e
->ts
.type
!= BT_UNKNOWN
)
1258 cons_state
= CONS_GOOD
;
1259 constructor_ts
= e
->ts
;
1263 cons_state
= CONS_START
;
1264 gfc_clear_ts (&constructor_ts
);
1267 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1268 typespec, and we will now convert the values on the fly. */
1269 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1270 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1271 e
->ts
= constructor_ts
;
1278 typedef struct cons_stack
1280 gfc_iterator
*iterator
;
1281 struct cons_stack
*previous
;
1285 static cons_stack
*base
;
1287 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1289 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1290 that that variable is an iteration variables. */
1293 gfc_check_iter_variable (gfc_expr
*expr
)
1298 sym
= expr
->symtree
->n
.sym
;
1300 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1301 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1308 /* Recursive work function for gfc_check_constructor(). This amounts
1309 to calling the check function for each expression in the
1310 constructor, giving variables with the names of iterators a pass. */
1313 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1320 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1327 if (e
->expr_type
!= EXPR_ARRAY
)
1329 if (!(*check_function
)(e
))
1334 element
.previous
= base
;
1335 element
.iterator
= c
->iterator
;
1338 t
= check_constructor (e
->value
.constructor
, check_function
);
1339 base
= element
.previous
;
1345 /* Nothing went wrong, so all OK. */
1350 /* Checks a constructor to see if it is a particular kind of
1351 expression -- specification, restricted, or initialization as
1352 determined by the check_function. */
1355 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1357 cons_stack
*base_save
;
1363 t
= check_constructor (expr
->value
.constructor
, check_function
);
1371 /**************** Simplification of array constructors ****************/
1373 iterator_stack
*iter_stack
;
1377 gfc_constructor_base base
;
1378 int extract_count
, extract_n
;
1379 gfc_expr
*extracted
;
1383 gfc_component
*component
;
1386 bool (*expand_work_function
) (gfc_expr
*);
1390 static expand_info current_expand
;
1392 static bool expand_constructor (gfc_constructor_base
);
1395 /* Work function that counts the number of elements present in a
1399 count_elements (gfc_expr
*e
)
1404 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1407 if (!gfc_array_size (e
, &result
))
1413 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1422 /* Work function that extracts a particular element from an array
1423 constructor, freeing the rest. */
1426 extract_element (gfc_expr
*e
)
1429 { /* Something unextractable */
1434 if (current_expand
.extract_count
== current_expand
.extract_n
)
1435 current_expand
.extracted
= e
;
1439 current_expand
.extract_count
++;
1445 /* Work function that constructs a new constructor out of the old one,
1446 stringing new elements together. */
1449 expand (gfc_expr
*e
)
1451 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1454 c
->n
.component
= current_expand
.component
;
1459 /* Given an initialization expression that is a variable reference,
1460 substitute the current value of the iteration variable. */
1463 gfc_simplify_iterator_var (gfc_expr
*e
)
1467 for (p
= iter_stack
; p
; p
= p
->prev
)
1468 if (e
->symtree
== p
->variable
)
1472 return; /* Variable not found */
1474 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1476 mpz_set (e
->value
.integer
, p
->value
);
1482 /* Expand an expression with that is inside of a constructor,
1483 recursing into other constructors if present. */
1486 expand_expr (gfc_expr
*e
)
1488 if (e
->expr_type
== EXPR_ARRAY
)
1489 return expand_constructor (e
->value
.constructor
);
1491 e
= gfc_copy_expr (e
);
1493 if (!gfc_simplify_expr (e
, 1))
1499 return current_expand
.expand_work_function (e
);
1504 expand_iterator (gfc_constructor
*c
)
1506 gfc_expr
*start
, *end
, *step
;
1507 iterator_stack frame
;
1516 mpz_init (frame
.value
);
1519 start
= gfc_copy_expr (c
->iterator
->start
);
1520 if (!gfc_simplify_expr (start
, 1))
1523 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1526 end
= gfc_copy_expr (c
->iterator
->end
);
1527 if (!gfc_simplify_expr (end
, 1))
1530 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1533 step
= gfc_copy_expr (c
->iterator
->step
);
1534 if (!gfc_simplify_expr (step
, 1))
1537 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1540 if (mpz_sgn (step
->value
.integer
) == 0)
1542 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1546 /* Calculate the trip count of the loop. */
1547 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1548 mpz_add (trip
, trip
, step
->value
.integer
);
1549 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1551 mpz_set (frame
.value
, start
->value
.integer
);
1553 frame
.prev
= iter_stack
;
1554 frame
.variable
= c
->iterator
->var
->symtree
;
1555 iter_stack
= &frame
;
1557 while (mpz_sgn (trip
) > 0)
1559 if (!expand_expr (c
->expr
))
1562 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1563 mpz_sub_ui (trip
, trip
, 1);
1569 gfc_free_expr (start
);
1570 gfc_free_expr (end
);
1571 gfc_free_expr (step
);
1574 mpz_clear (frame
.value
);
1576 iter_stack
= frame
.prev
;
1582 /* Expand a constructor into constant constructors without any
1583 iterators, calling the work function for each of the expanded
1584 expressions. The work function needs to either save or free the
1585 passed expression. */
1588 expand_constructor (gfc_constructor_base base
)
1593 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1595 if (c
->iterator
!= NULL
)
1597 if (!expand_iterator (c
))
1604 if (e
->expr_type
== EXPR_ARRAY
)
1606 if (!expand_constructor (e
->value
.constructor
))
1612 e
= gfc_copy_expr (e
);
1613 if (!gfc_simplify_expr (e
, 1))
1618 current_expand
.offset
= &c
->offset
;
1619 current_expand
.repeat
= &c
->repeat
;
1620 current_expand
.component
= c
->n
.component
;
1621 if (!current_expand
.expand_work_function(e
))
1628 /* Given an array expression and an element number (starting at zero),
1629 return a pointer to the array element. NULL is returned if the
1630 size of the array has been exceeded. The expression node returned
1631 remains a part of the array and should not be freed. Access is not
1632 efficient at all, but this is another place where things do not
1633 have to be particularly fast. */
1636 gfc_get_array_element (gfc_expr
*array
, int element
)
1638 expand_info expand_save
;
1642 expand_save
= current_expand
;
1643 current_expand
.extract_n
= element
;
1644 current_expand
.expand_work_function
= extract_element
;
1645 current_expand
.extracted
= NULL
;
1646 current_expand
.extract_count
= 0;
1650 rc
= expand_constructor (array
->value
.constructor
);
1651 e
= current_expand
.extracted
;
1652 current_expand
= expand_save
;
1661 /* Top level subroutine for expanding constructors. We only expand
1662 constructor if they are small enough. */
1665 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1667 expand_info expand_save
;
1671 /* If we can successfully get an array element at the max array size then
1672 the array is too big to expand, so we just return. */
1673 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1679 gfc_error ("The number of elements in the array constructor "
1680 "at %L requires an increase of the allowed %d "
1681 "upper limit. See %<-fmax-array-constructor%> "
1682 "option", &e
->where
, flag_max_array_constructor
);
1688 /* We now know the array is not too big so go ahead and try to expand it. */
1689 expand_save
= current_expand
;
1690 current_expand
.base
= NULL
;
1694 current_expand
.expand_work_function
= expand
;
1696 if (!expand_constructor (e
->value
.constructor
))
1698 gfc_constructor_free (current_expand
.base
);
1703 gfc_constructor_free (e
->value
.constructor
);
1704 e
->value
.constructor
= current_expand
.base
;
1709 current_expand
= expand_save
;
1715 /* Work function for checking that an element of a constructor is a
1716 constant, after removal of any iteration variables. We return
1720 is_constant_element (gfc_expr
*e
)
1724 rv
= gfc_is_constant_expr (e
);
1727 return rv
? true : false;
1731 /* Given an array constructor, determine if the constructor is
1732 constant or not by expanding it and making sure that all elements
1733 are constants. This is a bit of a hack since something like (/ (i,
1734 i=1,100000000) /) will take a while as* opposed to a more clever
1735 function that traverses the expression tree. FIXME. */
1738 gfc_constant_ac (gfc_expr
*e
)
1740 expand_info expand_save
;
1744 expand_save
= current_expand
;
1745 current_expand
.expand_work_function
= is_constant_element
;
1747 rc
= expand_constructor (e
->value
.constructor
);
1749 current_expand
= expand_save
;
1757 /* Returns nonzero if an array constructor has been completely
1758 expanded (no iterators) and zero if iterators are present. */
1761 gfc_expanded_ac (gfc_expr
*e
)
1765 if (e
->expr_type
== EXPR_ARRAY
)
1766 for (c
= gfc_constructor_first (e
->value
.constructor
);
1767 c
; c
= gfc_constructor_next (c
))
1768 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1775 /*************** Type resolution of array constructors ***************/
1778 /* The symbol expr_is_sought_symbol_ref will try to find. */
1779 static const gfc_symbol
*sought_symbol
= NULL
;
1782 /* Tells whether the expression E is a variable reference to the symbol
1783 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1785 To be used with gfc_expr_walker: if a reference is found we don't need
1786 to look further so we return 1 to skip any further walk. */
1789 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1792 gfc_expr
*expr
= *e
;
1793 locus
*sym_loc
= (locus
*)where
;
1795 if (expr
->expr_type
== EXPR_VARIABLE
1796 && expr
->symtree
->n
.sym
== sought_symbol
)
1798 *sym_loc
= expr
->where
;
1806 /* Tells whether the expression EXPR contains a reference to the symbol
1807 SYM and in that case sets the position SYM_LOC where the reference is. */
1810 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1814 sought_symbol
= sym
;
1815 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1816 sought_symbol
= NULL
;
1821 /* Recursive array list resolution function. All of the elements must
1822 be of the same type. */
1825 resolve_array_list (gfc_constructor_base base
)
1833 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1838 gfc_symbol
*iter_var
;
1841 if (!gfc_resolve_iterator (iter
, false, true))
1844 /* Check for bounds referencing the iterator variable. */
1845 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1846 iter_var
= iter
->var
->symtree
->n
.sym
;
1847 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1849 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1850 "expression references control variable "
1851 "at %L", &iter_var_loc
))
1854 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1856 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1857 "expression references control variable "
1858 "at %L", &iter_var_loc
))
1861 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1863 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1864 "expression references control variable "
1865 "at %L", &iter_var_loc
))
1870 if (!gfc_resolve_expr (c
->expr
))
1873 if (UNLIMITED_POLY (c
->expr
))
1875 gfc_error ("Array constructor value at %L shall not be unlimited "
1876 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1884 /* Resolve character array constructor. If it has a specified constant character
1885 length, pad/truncate the elements here; if the length is not specified and
1886 all elements are of compile-time known length, emit an error as this is
1890 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1895 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1896 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1898 if (expr
->ts
.u
.cl
== NULL
)
1900 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1901 p
; p
= gfc_constructor_next (p
))
1902 if (p
->expr
->ts
.u
.cl
!= NULL
)
1904 /* Ensure that if there is a char_len around that it is
1905 used; otherwise the middle-end confuses them! */
1906 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1910 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1917 if (expr
->ts
.u
.cl
->length
== NULL
)
1919 /* Check that all constant string elements have the same length until
1920 we reach the end or find a variable-length one. */
1922 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1923 p
; p
= gfc_constructor_next (p
))
1925 int current_length
= -1;
1927 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1928 if (ref
->type
== REF_SUBSTRING
1929 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1930 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1933 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1934 current_length
= p
->expr
->value
.character
.length
;
1938 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1939 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1940 current_length
= (int) j
;
1942 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1943 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1946 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1947 current_length
= (int) j
;
1952 gcc_assert (current_length
!= -1);
1954 if (found_length
== -1)
1955 found_length
= current_length
;
1956 else if (found_length
!= current_length
)
1958 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1959 " constructor at %L", found_length
, current_length
,
1964 gcc_assert (found_length
== current_length
);
1967 gcc_assert (found_length
!= -1);
1969 /* Update the character length of the array constructor. */
1970 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1971 NULL
, found_length
);
1975 /* We've got a character length specified. It should be an integer,
1976 otherwise an error is signalled elsewhere. */
1977 gcc_assert (expr
->ts
.u
.cl
->length
);
1979 /* If we've got a constant character length, pad according to this.
1980 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1981 max_length only if they pass. */
1982 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1984 /* Now pad/truncate the elements accordingly to the specified character
1985 length. This is ok inside this conditional, as in the case above
1986 (without typespec) all elements are verified to have the same length
1988 if (found_length
!= -1)
1989 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1990 p
; p
= gfc_constructor_next (p
))
1991 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1993 gfc_expr
*cl
= NULL
;
1994 int current_length
= -1;
1997 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1999 cl
= p
->expr
->ts
.u
.cl
->length
;
2000 gfc_extract_int (cl
, ¤t_length
);
2003 /* If gfc_extract_int above set current_length, we implicitly
2004 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2006 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2009 || (current_length
!= -1 && current_length
!= found_length
))
2010 gfc_set_constant_character_len (found_length
, p
->expr
,
2011 has_ts
? -1 : found_length
);
2019 /* Resolve all of the expressions in an array list. */
2022 gfc_resolve_array_constructor (gfc_expr
*expr
)
2026 t
= resolve_array_list (expr
->value
.constructor
);
2028 t
= gfc_check_constructor_type (expr
);
2030 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2031 the call to this function, so we don't need to call it here; if it was
2032 called twice, an error message there would be duplicated. */
2038 /* Copy an iterator structure. */
2041 gfc_copy_iterator (gfc_iterator
*src
)
2048 dest
= gfc_get_iterator ();
2050 dest
->var
= gfc_copy_expr (src
->var
);
2051 dest
->start
= gfc_copy_expr (src
->start
);
2052 dest
->end
= gfc_copy_expr (src
->end
);
2053 dest
->step
= gfc_copy_expr (src
->step
);
2059 /********* Subroutines for determining the size of an array *********/
2061 /* These are needed just to accommodate RESHAPE(). There are no
2062 diagnostics here, we just return a negative number if something
2066 /* Get the size of single dimension of an array specification. The
2067 array is guaranteed to be one dimensional. */
2070 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2075 if (dimen
< 0 || dimen
> as
->rank
- 1)
2076 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2078 if (as
->type
!= AS_EXPLICIT
2079 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2080 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2081 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2082 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2087 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2088 as
->lower
[dimen
]->value
.integer
);
2090 mpz_add_ui (*result
, *result
, 1);
2097 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2102 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2105 mpz_init_set_ui (*result
, 1);
2107 for (d
= 0; d
< as
->rank
; d
++)
2109 if (!spec_dimen_size (as
, d
, &size
))
2111 mpz_clear (*result
);
2115 mpz_mul (*result
, *result
, size
);
2123 /* Get the number of elements in an array section. Optionally, also supply
2127 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2129 mpz_t upper
, lower
, stride
;
2133 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2134 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2136 switch (ar
->dimen_type
[dimen
])
2140 mpz_set_ui (*result
, 1);
2145 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2152 if (ar
->stride
[dimen
] == NULL
)
2153 mpz_set_ui (stride
, 1);
2156 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2161 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2164 /* Calculate the number of elements via gfc_dep_differce, but only if
2165 start and end are both supplied in the reference or the array spec.
2166 This is to guard against strange but valid code like
2171 print *,size(a(n-1:))
2173 where the user changes the value of a variable. If we have to
2174 determine end as well, we cannot do this using gfc_dep_difference.
2175 Fall back to the constants-only code then. */
2181 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2183 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2184 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2185 ar
->as
->lower
[dimen
], &diff
);
2190 mpz_add (*result
, diff
, stride
);
2191 mpz_div (*result
, *result
, stride
);
2192 if (mpz_cmp_ui (*result
, 0) < 0)
2193 mpz_set_ui (*result
, 0);
2202 /* Constant-only code here, which covers more cases
2208 if (ar
->start
[dimen
] == NULL
)
2210 if (ar
->as
->lower
[dimen
] == NULL
2211 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2213 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2217 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2219 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2222 if (ar
->end
[dimen
] == NULL
)
2224 if (ar
->as
->upper
[dimen
] == NULL
2225 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2227 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2231 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2233 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2237 mpz_sub (*result
, upper
, lower
);
2238 mpz_add (*result
, *result
, stride
);
2239 mpz_div (*result
, *result
, stride
);
2241 /* Zero stride caught earlier. */
2242 if (mpz_cmp_ui (*result
, 0) < 0)
2243 mpz_set_ui (*result
, 0);
2250 mpz_sub_ui (*end
, *result
, 1UL);
2251 mpz_mul (*end
, *end
, stride
);
2252 mpz_add (*end
, *end
, lower
);
2262 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2270 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2275 mpz_init_set_ui (*result
, 1);
2277 for (d
= 0; d
< ar
->dimen
; d
++)
2279 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2281 mpz_clear (*result
);
2285 mpz_mul (*result
, *result
, size
);
2293 /* Given an array expression and a dimension, figure out how many
2294 elements it has along that dimension. Returns true if we were
2295 able to return a result in the 'result' variable, false
2299 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2304 gcc_assert (array
!= NULL
);
2306 if (array
->ts
.type
== BT_CLASS
)
2309 if (array
->rank
== -1)
2312 if (dimen
< 0 || dimen
> array
->rank
- 1)
2313 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2315 switch (array
->expr_type
)
2319 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2321 if (ref
->type
!= REF_ARRAY
)
2324 if (ref
->u
.ar
.type
== AR_FULL
)
2325 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2327 if (ref
->u
.ar
.type
== AR_SECTION
)
2329 for (i
= 0; dimen
>= 0; i
++)
2330 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2333 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2337 if (array
->shape
&& array
->shape
[dimen
])
2339 mpz_init_set (*result
, array
->shape
[dimen
]);
2343 if (array
->symtree
->n
.sym
->attr
.generic
2344 && array
->value
.function
.esym
!= NULL
)
2346 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2349 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2355 if (array
->shape
== NULL
) {
2356 /* Expressions with rank > 1 should have "shape" properly set */
2357 if ( array
->rank
!= 1 )
2358 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2359 return gfc_array_size(array
, result
);
2364 if (array
->shape
== NULL
)
2367 mpz_init_set (*result
, array
->shape
[dimen
]);
2376 /* Given an array expression, figure out how many elements are in the
2377 array. Returns true if this is possible, and sets the 'result'
2378 variable. Otherwise returns false. */
2381 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2383 expand_info expand_save
;
2388 if (array
->ts
.type
== BT_CLASS
)
2391 switch (array
->expr_type
)
2394 gfc_push_suppress_errors ();
2396 expand_save
= current_expand
;
2398 current_expand
.count
= result
;
2399 mpz_init_set_ui (*result
, 0);
2401 current_expand
.expand_work_function
= count_elements
;
2404 t
= expand_constructor (array
->value
.constructor
);
2406 gfc_pop_suppress_errors ();
2409 mpz_clear (*result
);
2410 current_expand
= expand_save
;
2414 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2416 if (ref
->type
!= REF_ARRAY
)
2419 if (ref
->u
.ar
.type
== AR_FULL
)
2420 return spec_size (ref
->u
.ar
.as
, result
);
2422 if (ref
->u
.ar
.type
== AR_SECTION
)
2423 return ref_size (&ref
->u
.ar
, result
);
2426 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2430 if (array
->rank
== 0 || array
->shape
== NULL
)
2433 mpz_init_set_ui (*result
, 1);
2435 for (i
= 0; i
< array
->rank
; i
++)
2436 mpz_mul (*result
, *result
, array
->shape
[i
]);
2445 /* Given an array reference, return the shape of the reference in an
2446 array of mpz_t integers. */
2449 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2459 for (; d
< ar
->as
->rank
; d
++)
2460 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2466 for (i
= 0; i
< ar
->dimen
; i
++)
2468 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2470 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2483 gfc_clear_shape (shape
, d
);
2488 /* Given an array expression, find the array reference structure that
2489 characterizes the reference. */
2492 gfc_find_array_ref (gfc_expr
*e
)
2496 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2497 if (ref
->type
== REF_ARRAY
2498 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2502 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2508 /* Find out if an array shape is known at compile time. */
2511 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2515 if (as
->type
!= AS_EXPLICIT
)
2518 for (i
= 0; i
< as
->rank
; i
++)
2519 if (!gfc_is_constant_expr (as
->lower
[i
])
2520 || !gfc_is_constant_expr (as
->upper
[i
]))