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 if (gfc_match_type_spec (&ts
) == MATCH_YES
)
1085 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1089 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1090 "including type specification at %C"))
1092 gfc_restore_last_undo_checkpoint ();
1098 gfc_error ("Type-spec at %L cannot contain a deferred "
1099 "type parameter", &where
);
1100 gfc_restore_last_undo_checkpoint ();
1107 gfc_drop_last_undo_checkpoint ();
1110 gfc_restore_last_undo_checkpoint ();
1111 gfc_current_locus
= where
;
1114 if (gfc_match (end_delim
) == MATCH_YES
)
1120 gfc_error ("Empty array constructor at %C is not allowed");
1127 m
= match_array_cons_element (&head
);
1128 if (m
== MATCH_ERROR
)
1133 if (gfc_match_char (',') == MATCH_NO
)
1137 if (gfc_match (end_delim
) == MATCH_NO
)
1141 /* Size must be calculated at resolution time. */
1144 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1148 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1150 expr
->value
.constructor
= head
;
1152 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1158 gfc_error ("Syntax error in array constructor at %C");
1161 gfc_constructor_free (head
);
1167 /************** Check array constructors for correctness **************/
1169 /* Given an expression, compare it's type with the type of the current
1170 constructor. Returns nonzero if an error was issued. The
1171 cons_state variable keeps track of whether the type of the
1172 constructor being read or resolved is known to be good, bad or just
1175 static gfc_typespec constructor_ts
;
1177 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1181 check_element_type (gfc_expr
*expr
, bool convert
)
1183 if (cons_state
== CONS_BAD
)
1184 return 0; /* Suppress further errors */
1186 if (cons_state
== CONS_START
)
1188 if (expr
->ts
.type
== BT_UNKNOWN
)
1189 cons_state
= CONS_BAD
;
1192 cons_state
= CONS_GOOD
;
1193 constructor_ts
= expr
->ts
;
1199 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1203 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1205 gfc_error ("Element in %s array constructor at %L is %s",
1206 gfc_typename (&constructor_ts
), &expr
->where
,
1207 gfc_typename (&expr
->ts
));
1209 cons_state
= CONS_BAD
;
1214 /* Recursive work function for gfc_check_constructor_type(). */
1217 check_constructor_type (gfc_constructor_base base
, bool convert
)
1222 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1226 if (e
->expr_type
== EXPR_ARRAY
)
1228 if (!check_constructor_type (e
->value
.constructor
, convert
))
1234 if (check_element_type (e
, convert
))
1242 /* Check that all elements of an array constructor are the same type.
1243 On false, an error has been generated. */
1246 gfc_check_constructor_type (gfc_expr
*e
)
1250 if (e
->ts
.type
!= BT_UNKNOWN
)
1252 cons_state
= CONS_GOOD
;
1253 constructor_ts
= e
->ts
;
1257 cons_state
= CONS_START
;
1258 gfc_clear_ts (&constructor_ts
);
1261 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1262 typespec, and we will now convert the values on the fly. */
1263 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1264 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1265 e
->ts
= constructor_ts
;
1272 typedef struct cons_stack
1274 gfc_iterator
*iterator
;
1275 struct cons_stack
*previous
;
1279 static cons_stack
*base
;
1281 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1283 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1284 that that variable is an iteration variables. */
1287 gfc_check_iter_variable (gfc_expr
*expr
)
1292 sym
= expr
->symtree
->n
.sym
;
1294 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1295 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1302 /* Recursive work function for gfc_check_constructor(). This amounts
1303 to calling the check function for each expression in the
1304 constructor, giving variables with the names of iterators a pass. */
1307 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1314 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1321 if (e
->expr_type
!= EXPR_ARRAY
)
1323 if (!(*check_function
)(e
))
1328 element
.previous
= base
;
1329 element
.iterator
= c
->iterator
;
1332 t
= check_constructor (e
->value
.constructor
, check_function
);
1333 base
= element
.previous
;
1339 /* Nothing went wrong, so all OK. */
1344 /* Checks a constructor to see if it is a particular kind of
1345 expression -- specification, restricted, or initialization as
1346 determined by the check_function. */
1349 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1351 cons_stack
*base_save
;
1357 t
= check_constructor (expr
->value
.constructor
, check_function
);
1365 /**************** Simplification of array constructors ****************/
1367 iterator_stack
*iter_stack
;
1371 gfc_constructor_base base
;
1372 int extract_count
, extract_n
;
1373 gfc_expr
*extracted
;
1377 gfc_component
*component
;
1380 bool (*expand_work_function
) (gfc_expr
*);
1384 static expand_info current_expand
;
1386 static bool expand_constructor (gfc_constructor_base
);
1389 /* Work function that counts the number of elements present in a
1393 count_elements (gfc_expr
*e
)
1398 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1401 if (!gfc_array_size (e
, &result
))
1407 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1416 /* Work function that extracts a particular element from an array
1417 constructor, freeing the rest. */
1420 extract_element (gfc_expr
*e
)
1423 { /* Something unextractable */
1428 if (current_expand
.extract_count
== current_expand
.extract_n
)
1429 current_expand
.extracted
= e
;
1433 current_expand
.extract_count
++;
1439 /* Work function that constructs a new constructor out of the old one,
1440 stringing new elements together. */
1443 expand (gfc_expr
*e
)
1445 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1448 c
->n
.component
= current_expand
.component
;
1453 /* Given an initialization expression that is a variable reference,
1454 substitute the current value of the iteration variable. */
1457 gfc_simplify_iterator_var (gfc_expr
*e
)
1461 for (p
= iter_stack
; p
; p
= p
->prev
)
1462 if (e
->symtree
== p
->variable
)
1466 return; /* Variable not found */
1468 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1470 mpz_set (e
->value
.integer
, p
->value
);
1476 /* Expand an expression with that is inside of a constructor,
1477 recursing into other constructors if present. */
1480 expand_expr (gfc_expr
*e
)
1482 if (e
->expr_type
== EXPR_ARRAY
)
1483 return expand_constructor (e
->value
.constructor
);
1485 e
= gfc_copy_expr (e
);
1487 if (!gfc_simplify_expr (e
, 1))
1493 return current_expand
.expand_work_function (e
);
1498 expand_iterator (gfc_constructor
*c
)
1500 gfc_expr
*start
, *end
, *step
;
1501 iterator_stack frame
;
1510 mpz_init (frame
.value
);
1513 start
= gfc_copy_expr (c
->iterator
->start
);
1514 if (!gfc_simplify_expr (start
, 1))
1517 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1520 end
= gfc_copy_expr (c
->iterator
->end
);
1521 if (!gfc_simplify_expr (end
, 1))
1524 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1527 step
= gfc_copy_expr (c
->iterator
->step
);
1528 if (!gfc_simplify_expr (step
, 1))
1531 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1534 if (mpz_sgn (step
->value
.integer
) == 0)
1536 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1540 /* Calculate the trip count of the loop. */
1541 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1542 mpz_add (trip
, trip
, step
->value
.integer
);
1543 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1545 mpz_set (frame
.value
, start
->value
.integer
);
1547 frame
.prev
= iter_stack
;
1548 frame
.variable
= c
->iterator
->var
->symtree
;
1549 iter_stack
= &frame
;
1551 while (mpz_sgn (trip
) > 0)
1553 if (!expand_expr (c
->expr
))
1556 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1557 mpz_sub_ui (trip
, trip
, 1);
1563 gfc_free_expr (start
);
1564 gfc_free_expr (end
);
1565 gfc_free_expr (step
);
1568 mpz_clear (frame
.value
);
1570 iter_stack
= frame
.prev
;
1576 /* Expand a constructor into constant constructors without any
1577 iterators, calling the work function for each of the expanded
1578 expressions. The work function needs to either save or free the
1579 passed expression. */
1582 expand_constructor (gfc_constructor_base base
)
1587 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1589 if (c
->iterator
!= NULL
)
1591 if (!expand_iterator (c
))
1598 if (e
->expr_type
== EXPR_ARRAY
)
1600 if (!expand_constructor (e
->value
.constructor
))
1606 e
= gfc_copy_expr (e
);
1607 if (!gfc_simplify_expr (e
, 1))
1612 current_expand
.offset
= &c
->offset
;
1613 current_expand
.repeat
= &c
->repeat
;
1614 current_expand
.component
= c
->n
.component
;
1615 if (!current_expand
.expand_work_function(e
))
1622 /* Given an array expression and an element number (starting at zero),
1623 return a pointer to the array element. NULL is returned if the
1624 size of the array has been exceeded. The expression node returned
1625 remains a part of the array and should not be freed. Access is not
1626 efficient at all, but this is another place where things do not
1627 have to be particularly fast. */
1630 gfc_get_array_element (gfc_expr
*array
, int element
)
1632 expand_info expand_save
;
1636 expand_save
= current_expand
;
1637 current_expand
.extract_n
= element
;
1638 current_expand
.expand_work_function
= extract_element
;
1639 current_expand
.extracted
= NULL
;
1640 current_expand
.extract_count
= 0;
1644 rc
= expand_constructor (array
->value
.constructor
);
1645 e
= current_expand
.extracted
;
1646 current_expand
= expand_save
;
1655 /* Top level subroutine for expanding constructors. We only expand
1656 constructor if they are small enough. */
1659 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1661 expand_info expand_save
;
1665 /* If we can successfully get an array element at the max array size then
1666 the array is too big to expand, so we just return. */
1667 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1673 gfc_error ("The number of elements in the array constructor "
1674 "at %L requires an increase of the allowed %d "
1675 "upper limit. See %<-fmax-array-constructor%> "
1676 "option", &e
->where
, flag_max_array_constructor
);
1682 /* We now know the array is not too big so go ahead and try to expand it. */
1683 expand_save
= current_expand
;
1684 current_expand
.base
= NULL
;
1688 current_expand
.expand_work_function
= expand
;
1690 if (!expand_constructor (e
->value
.constructor
))
1692 gfc_constructor_free (current_expand
.base
);
1697 gfc_constructor_free (e
->value
.constructor
);
1698 e
->value
.constructor
= current_expand
.base
;
1703 current_expand
= expand_save
;
1709 /* Work function for checking that an element of a constructor is a
1710 constant, after removal of any iteration variables. We return
1714 is_constant_element (gfc_expr
*e
)
1718 rv
= gfc_is_constant_expr (e
);
1721 return rv
? true : false;
1725 /* Given an array constructor, determine if the constructor is
1726 constant or not by expanding it and making sure that all elements
1727 are constants. This is a bit of a hack since something like (/ (i,
1728 i=1,100000000) /) will take a while as* opposed to a more clever
1729 function that traverses the expression tree. FIXME. */
1732 gfc_constant_ac (gfc_expr
*e
)
1734 expand_info expand_save
;
1738 expand_save
= current_expand
;
1739 current_expand
.expand_work_function
= is_constant_element
;
1741 rc
= expand_constructor (e
->value
.constructor
);
1743 current_expand
= expand_save
;
1751 /* Returns nonzero if an array constructor has been completely
1752 expanded (no iterators) and zero if iterators are present. */
1755 gfc_expanded_ac (gfc_expr
*e
)
1759 if (e
->expr_type
== EXPR_ARRAY
)
1760 for (c
= gfc_constructor_first (e
->value
.constructor
);
1761 c
; c
= gfc_constructor_next (c
))
1762 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1769 /*************** Type resolution of array constructors ***************/
1772 /* The symbol expr_is_sought_symbol_ref will try to find. */
1773 static const gfc_symbol
*sought_symbol
= NULL
;
1776 /* Tells whether the expression E is a variable reference to the symbol
1777 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1779 To be used with gfc_expr_walker: if a reference is found we don't need
1780 to look further so we return 1 to skip any further walk. */
1783 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1786 gfc_expr
*expr
= *e
;
1787 locus
*sym_loc
= (locus
*)where
;
1789 if (expr
->expr_type
== EXPR_VARIABLE
1790 && expr
->symtree
->n
.sym
== sought_symbol
)
1792 *sym_loc
= expr
->where
;
1800 /* Tells whether the expression EXPR contains a reference to the symbol
1801 SYM and in that case sets the position SYM_LOC where the reference is. */
1804 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1808 sought_symbol
= sym
;
1809 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1810 sought_symbol
= NULL
;
1815 /* Recursive array list resolution function. All of the elements must
1816 be of the same type. */
1819 resolve_array_list (gfc_constructor_base base
)
1827 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1832 gfc_symbol
*iter_var
;
1835 if (!gfc_resolve_iterator (iter
, false, true))
1838 /* Check for bounds referencing the iterator variable. */
1839 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1840 iter_var
= iter
->var
->symtree
->n
.sym
;
1841 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1843 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1844 "expression references control variable "
1845 "at %L", &iter_var_loc
))
1848 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1850 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1851 "expression references control variable "
1852 "at %L", &iter_var_loc
))
1855 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1857 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1858 "expression references control variable "
1859 "at %L", &iter_var_loc
))
1864 if (!gfc_resolve_expr (c
->expr
))
1867 if (UNLIMITED_POLY (c
->expr
))
1869 gfc_error ("Array constructor value at %L shall not be unlimited "
1870 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1878 /* Resolve character array constructor. If it has a specified constant character
1879 length, pad/truncate the elements here; if the length is not specified and
1880 all elements are of compile-time known length, emit an error as this is
1884 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1889 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1890 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1892 if (expr
->ts
.u
.cl
== NULL
)
1894 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1895 p
; p
= gfc_constructor_next (p
))
1896 if (p
->expr
->ts
.u
.cl
!= NULL
)
1898 /* Ensure that if there is a char_len around that it is
1899 used; otherwise the middle-end confuses them! */
1900 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1904 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1911 if (expr
->ts
.u
.cl
->length
== NULL
)
1913 /* Check that all constant string elements have the same length until
1914 we reach the end or find a variable-length one. */
1916 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1917 p
; p
= gfc_constructor_next (p
))
1919 int current_length
= -1;
1921 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1922 if (ref
->type
== REF_SUBSTRING
1923 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1924 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1927 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1928 current_length
= p
->expr
->value
.character
.length
;
1932 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1933 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1934 current_length
= (int) j
;
1936 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1937 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1940 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1941 current_length
= (int) j
;
1946 gcc_assert (current_length
!= -1);
1948 if (found_length
== -1)
1949 found_length
= current_length
;
1950 else if (found_length
!= current_length
)
1952 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1953 " constructor at %L", found_length
, current_length
,
1958 gcc_assert (found_length
== current_length
);
1961 gcc_assert (found_length
!= -1);
1963 /* Update the character length of the array constructor. */
1964 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1965 NULL
, found_length
);
1969 /* We've got a character length specified. It should be an integer,
1970 otherwise an error is signalled elsewhere. */
1971 gcc_assert (expr
->ts
.u
.cl
->length
);
1973 /* If we've got a constant character length, pad according to this.
1974 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1975 max_length only if they pass. */
1976 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1978 /* Now pad/truncate the elements accordingly to the specified character
1979 length. This is ok inside this conditional, as in the case above
1980 (without typespec) all elements are verified to have the same length
1982 if (found_length
!= -1)
1983 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1984 p
; p
= gfc_constructor_next (p
))
1985 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1987 gfc_expr
*cl
= NULL
;
1988 int current_length
= -1;
1991 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1993 cl
= p
->expr
->ts
.u
.cl
->length
;
1994 gfc_extract_int (cl
, ¤t_length
);
1997 /* If gfc_extract_int above set current_length, we implicitly
1998 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2000 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2003 || (current_length
!= -1 && current_length
!= found_length
))
2004 gfc_set_constant_character_len (found_length
, p
->expr
,
2005 has_ts
? -1 : found_length
);
2013 /* Resolve all of the expressions in an array list. */
2016 gfc_resolve_array_constructor (gfc_expr
*expr
)
2020 t
= resolve_array_list (expr
->value
.constructor
);
2022 t
= gfc_check_constructor_type (expr
);
2024 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2025 the call to this function, so we don't need to call it here; if it was
2026 called twice, an error message there would be duplicated. */
2032 /* Copy an iterator structure. */
2035 gfc_copy_iterator (gfc_iterator
*src
)
2042 dest
= gfc_get_iterator ();
2044 dest
->var
= gfc_copy_expr (src
->var
);
2045 dest
->start
= gfc_copy_expr (src
->start
);
2046 dest
->end
= gfc_copy_expr (src
->end
);
2047 dest
->step
= gfc_copy_expr (src
->step
);
2053 /********* Subroutines for determining the size of an array *********/
2055 /* These are needed just to accommodate RESHAPE(). There are no
2056 diagnostics here, we just return a negative number if something
2060 /* Get the size of single dimension of an array specification. The
2061 array is guaranteed to be one dimensional. */
2064 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2069 if (dimen
< 0 || dimen
> as
->rank
- 1)
2070 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2072 if (as
->type
!= AS_EXPLICIT
2073 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2074 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2075 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2076 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2081 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2082 as
->lower
[dimen
]->value
.integer
);
2084 mpz_add_ui (*result
, *result
, 1);
2091 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2096 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2099 mpz_init_set_ui (*result
, 1);
2101 for (d
= 0; d
< as
->rank
; d
++)
2103 if (!spec_dimen_size (as
, d
, &size
))
2105 mpz_clear (*result
);
2109 mpz_mul (*result
, *result
, size
);
2117 /* Get the number of elements in an array section. Optionally, also supply
2121 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2123 mpz_t upper
, lower
, stride
;
2127 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2128 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2130 switch (ar
->dimen_type
[dimen
])
2134 mpz_set_ui (*result
, 1);
2139 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2146 if (ar
->stride
[dimen
] == NULL
)
2147 mpz_set_ui (stride
, 1);
2150 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2155 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2158 /* Calculate the number of elements via gfc_dep_differce, but only if
2159 start and end are both supplied in the reference or the array spec.
2160 This is to guard against strange but valid code like
2165 print *,size(a(n-1:))
2167 where the user changes the value of a variable. If we have to
2168 determine end as well, we cannot do this using gfc_dep_difference.
2169 Fall back to the constants-only code then. */
2175 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2177 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2178 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2179 ar
->as
->lower
[dimen
], &diff
);
2184 mpz_add (*result
, diff
, stride
);
2185 mpz_div (*result
, *result
, stride
);
2186 if (mpz_cmp_ui (*result
, 0) < 0)
2187 mpz_set_ui (*result
, 0);
2196 /* Constant-only code here, which covers more cases
2202 if (ar
->start
[dimen
] == NULL
)
2204 if (ar
->as
->lower
[dimen
] == NULL
2205 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2207 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2211 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2213 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2216 if (ar
->end
[dimen
] == NULL
)
2218 if (ar
->as
->upper
[dimen
] == NULL
2219 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2221 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2225 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2227 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2231 mpz_sub (*result
, upper
, lower
);
2232 mpz_add (*result
, *result
, stride
);
2233 mpz_div (*result
, *result
, stride
);
2235 /* Zero stride caught earlier. */
2236 if (mpz_cmp_ui (*result
, 0) < 0)
2237 mpz_set_ui (*result
, 0);
2244 mpz_sub_ui (*end
, *result
, 1UL);
2245 mpz_mul (*end
, *end
, stride
);
2246 mpz_add (*end
, *end
, lower
);
2256 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2264 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2269 mpz_init_set_ui (*result
, 1);
2271 for (d
= 0; d
< ar
->dimen
; d
++)
2273 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2275 mpz_clear (*result
);
2279 mpz_mul (*result
, *result
, size
);
2287 /* Given an array expression and a dimension, figure out how many
2288 elements it has along that dimension. Returns true if we were
2289 able to return a result in the 'result' variable, false
2293 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2298 gcc_assert (array
!= NULL
);
2300 if (array
->ts
.type
== BT_CLASS
)
2303 if (array
->rank
== -1)
2306 if (dimen
< 0 || dimen
> array
->rank
- 1)
2307 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2309 switch (array
->expr_type
)
2313 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2315 if (ref
->type
!= REF_ARRAY
)
2318 if (ref
->u
.ar
.type
== AR_FULL
)
2319 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2321 if (ref
->u
.ar
.type
== AR_SECTION
)
2323 for (i
= 0; dimen
>= 0; i
++)
2324 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2327 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2331 if (array
->shape
&& array
->shape
[dimen
])
2333 mpz_init_set (*result
, array
->shape
[dimen
]);
2337 if (array
->symtree
->n
.sym
->attr
.generic
2338 && array
->value
.function
.esym
!= NULL
)
2340 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2343 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2349 if (array
->shape
== NULL
) {
2350 /* Expressions with rank > 1 should have "shape" properly set */
2351 if ( array
->rank
!= 1 )
2352 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2353 return gfc_array_size(array
, result
);
2358 if (array
->shape
== NULL
)
2361 mpz_init_set (*result
, array
->shape
[dimen
]);
2370 /* Given an array expression, figure out how many elements are in the
2371 array. Returns true if this is possible, and sets the 'result'
2372 variable. Otherwise returns false. */
2375 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2377 expand_info expand_save
;
2382 if (array
->ts
.type
== BT_CLASS
)
2385 switch (array
->expr_type
)
2388 gfc_push_suppress_errors ();
2390 expand_save
= current_expand
;
2392 current_expand
.count
= result
;
2393 mpz_init_set_ui (*result
, 0);
2395 current_expand
.expand_work_function
= count_elements
;
2398 t
= expand_constructor (array
->value
.constructor
);
2400 gfc_pop_suppress_errors ();
2403 mpz_clear (*result
);
2404 current_expand
= expand_save
;
2408 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2410 if (ref
->type
!= REF_ARRAY
)
2413 if (ref
->u
.ar
.type
== AR_FULL
)
2414 return spec_size (ref
->u
.ar
.as
, result
);
2416 if (ref
->u
.ar
.type
== AR_SECTION
)
2417 return ref_size (&ref
->u
.ar
, result
);
2420 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2424 if (array
->rank
== 0 || array
->shape
== NULL
)
2427 mpz_init_set_ui (*result
, 1);
2429 for (i
= 0; i
< array
->rank
; i
++)
2430 mpz_mul (*result
, *result
, array
->shape
[i
]);
2439 /* Given an array reference, return the shape of the reference in an
2440 array of mpz_t integers. */
2443 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2453 for (; d
< ar
->as
->rank
; d
++)
2454 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2460 for (i
= 0; i
< ar
->dimen
; i
++)
2462 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2464 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2477 gfc_clear_shape (shape
, d
);
2482 /* Given an array expression, find the array reference structure that
2483 characterizes the reference. */
2486 gfc_find_array_ref (gfc_expr
*e
)
2490 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2491 if (ref
->type
== REF_ARRAY
2492 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2496 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2502 /* Find out if an array shape is known at compile time. */
2505 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2509 if (as
->type
!= AS_EXPLICIT
)
2512 for (i
= 0; i
< as
->rank
; i
++)
2513 if (!gfc_is_constant_expr (as
->lower
[i
])
2514 || !gfc_is_constant_expr (as
->upper
[i
]))