2 Copyright (C) 2000-2013 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"
26 #include "constructor.h"
28 /**************** Array reference matching subroutines *****************/
30 /* Copy an array reference structure. */
33 gfc_copy_array_ref (gfc_array_ref
*src
)
41 dest
= gfc_get_array_ref ();
45 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
47 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
48 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
49 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
56 /* Match a single dimension of an array reference. This can be a
57 single element or an array section. Any modifications we've made
58 to the ar structure are cleaned up by the caller. If the init
59 is set, we require the subscript to be a valid initialization
63 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
65 match m
= MATCH_ERROR
;
69 i
= ar
->dimen
+ ar
->codimen
;
71 gfc_gobble_whitespace ();
72 ar
->c_where
[i
] = gfc_current_locus
;
73 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
75 /* We can't be sure of the difference between DIMEN_ELEMENT and
76 DIMEN_VECTOR until we know the type of the element itself at
79 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
81 if (gfc_match_char (':') == MATCH_YES
)
84 /* Get start element. */
85 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
89 m
= gfc_match_init_expr (&ar
->start
[i
]);
91 m
= gfc_match_expr (&ar
->start
[i
]);
94 gfc_error ("Expected array subscript at %C");
98 if (gfc_match_char (':') == MATCH_NO
)
103 gfc_error ("Unexpected '*' in coarray subscript at %C");
107 /* Get an optional end element. Because we've seen the colon, we
108 definitely have a range along this dimension. */
110 ar
->dimen_type
[i
] = DIMEN_RANGE
;
112 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
115 m
= gfc_match_init_expr (&ar
->end
[i
]);
117 m
= gfc_match_expr (&ar
->end
[i
]);
119 if (m
== MATCH_ERROR
)
122 /* See if we have an optional stride. */
123 if (gfc_match_char (':') == MATCH_YES
)
127 gfc_error ("Strides not allowed in coarray subscript at %C");
131 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
132 : gfc_match_expr (&ar
->stride
[i
]);
135 gfc_error ("Expected array subscript stride at %C");
142 ar
->dimen_type
[i
] = DIMEN_STAR
;
148 /* Match an array reference, whether it is the whole array or a
149 particular elements or a section. If init is set, the reference has
150 to consist of init expressions. */
153 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
157 bool matched_bracket
= false;
159 memset (ar
, '\0', sizeof (*ar
));
161 ar
->where
= gfc_current_locus
;
163 ar
->type
= AR_UNKNOWN
;
165 if (gfc_match_char ('[') == MATCH_YES
)
167 matched_bracket
= true;
171 if (gfc_match_char ('(') != MATCH_YES
)
178 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
180 m
= match_subscript (ar
, init
, false);
181 if (m
== MATCH_ERROR
)
184 if (gfc_match_char (')') == MATCH_YES
)
190 if (gfc_match_char (',') != MATCH_YES
)
192 gfc_error ("Invalid form of array reference at %C");
197 gfc_error ("Array reference at %C cannot have more than %d dimensions",
202 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
210 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
212 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
218 gfc_error ("Unexpected coarray designator at %C");
222 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
224 m
= match_subscript (ar
, init
, true);
225 if (m
== MATCH_ERROR
)
228 if (gfc_match_char (']') == MATCH_YES
)
231 if (ar
->codimen
< corank
)
233 gfc_error ("Too few codimensions at %C, expected %d not %d",
234 corank
, ar
->codimen
);
237 if (ar
->codimen
> corank
)
239 gfc_error ("Too many codimensions at %C, expected %d not %d",
240 corank
, ar
->codimen
);
246 if (gfc_match_char (',') != MATCH_YES
)
248 if (gfc_match_char ('*') == MATCH_YES
)
249 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
250 ar
->codimen
+ 1, corank
);
252 gfc_error ("Invalid form of coarray reference at %C");
255 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
257 gfc_error ("Unexpected '*' for codimension %d of %d at %C",
258 ar
->codimen
+ 1, corank
);
262 if (ar
->codimen
>= corank
)
264 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
265 ar
->codimen
+ 1, corank
);
270 gfc_error ("Array reference at %C cannot have more than %d dimensions",
277 /************** Array specification matching subroutines ***************/
279 /* Free all of the expressions associated with array bounds
283 gfc_free_array_spec (gfc_array_spec
*as
)
290 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
292 gfc_free_expr (as
->lower
[i
]);
293 gfc_free_expr (as
->upper
[i
]);
300 /* Take an array bound, resolves the expression, that make up the
301 shape and check associated constraints. */
304 resolve_array_bound (gfc_expr
*e
, int check_constant
)
309 if (gfc_resolve_expr (e
) == FAILURE
310 || gfc_specification_expr (e
) == FAILURE
)
313 if (check_constant
&& !gfc_is_constant_expr (e
))
315 if (e
->expr_type
== EXPR_VARIABLE
)
316 gfc_error ("Variable '%s' at %L in this context must be constant",
317 e
->symtree
->n
.sym
->name
, &e
->where
);
319 gfc_error ("Expression at %L in this context must be constant",
328 /* Takes an array specification, resolves the expressions that make up
329 the shape and make sure everything is integral. */
332 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
340 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
343 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
347 if (resolve_array_bound (e
, check_constant
) == FAILURE
)
350 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
353 /* If the size is negative in this dimension, set it to zero. */
354 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
355 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
356 && mpz_cmp (as
->upper
[i
]->value
.integer
,
357 as
->lower
[i
]->value
.integer
) < 0)
359 gfc_free_expr (as
->upper
[i
]);
360 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
361 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
362 as
->upper
[i
]->value
.integer
, 1);
370 /* Match a single array element specification. The return values as
371 well as the upper and lower bounds of the array spec are filled
372 in according to what we see on the input. The caller makes sure
373 individual specifications make sense as a whole.
376 Parsed Lower Upper Returned
377 ------------------------------------
378 : NULL NULL AS_DEFERRED (*)
380 x: x NULL AS_ASSUMED_SHAPE
382 x:* x NULL AS_ASSUMED_SIZE
383 * 1 NULL AS_ASSUMED_SIZE
385 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
386 is fixed during the resolution of formal interfaces.
388 Anything else AS_UNKNOWN. */
391 match_array_element_spec (gfc_array_spec
*as
)
393 gfc_expr
**upper
, **lower
;
397 rank
= as
->rank
== -1 ? 0 : as
->rank
;
398 lower
= &as
->lower
[rank
+ as
->corank
- 1];
399 upper
= &as
->upper
[rank
+ as
->corank
- 1];
401 if (gfc_match_char ('*') == MATCH_YES
)
403 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
404 return AS_ASSUMED_SIZE
;
407 if (gfc_match_char (':') == MATCH_YES
)
410 m
= gfc_match_expr (upper
);
412 gfc_error ("Expected expression in array specification at %C");
415 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
418 if (gfc_match_char (':') == MATCH_NO
)
420 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
427 if (gfc_match_char ('*') == MATCH_YES
)
428 return AS_ASSUMED_SIZE
;
430 m
= gfc_match_expr (upper
);
431 if (m
== MATCH_ERROR
)
434 return AS_ASSUMED_SHAPE
;
435 if (gfc_expr_check_typed (*upper
, gfc_current_ns
, false) == FAILURE
)
442 /* Matches an array specification, incidentally figuring out what sort
443 it is. Match either a normal array specification, or a coarray spec
444 or both. Optionally allow [:] for coarrays. */
447 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
449 array_type current_type
;
453 as
= gfc_get_array_spec ();
458 if (gfc_match_char ('(') != MATCH_YES
)
465 if (gfc_match (" .. )") == MATCH_YES
)
467 as
->type
= AS_ASSUMED_RANK
;
470 if (gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C")
482 current_type
= match_array_element_spec (as
);
484 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
485 and implied-shape specifications. If the rank is at least 2, we can
486 distinguish between them. But for rank 1, we currently return
487 ASSUMED_SIZE; this gets adjusted later when we know for sure
488 whether the symbol parsed is a PARAMETER or not. */
492 if (current_type
== AS_UNKNOWN
)
494 as
->type
= current_type
;
498 { /* See how current spec meshes with the existing. */
502 case AS_IMPLIED_SHAPE
:
503 if (current_type
!= AS_ASSUMED_SHAPE
)
505 gfc_error ("Bad array specification for implied-shape"
512 if (current_type
== AS_ASSUMED_SIZE
)
514 as
->type
= AS_ASSUMED_SIZE
;
518 if (current_type
== AS_EXPLICIT
)
521 gfc_error ("Bad array specification for an explicitly shaped "
526 case AS_ASSUMED_SHAPE
:
527 if ((current_type
== AS_ASSUMED_SHAPE
)
528 || (current_type
== AS_DEFERRED
))
531 gfc_error ("Bad array specification for assumed shape "
536 if (current_type
== AS_DEFERRED
)
539 if (current_type
== AS_ASSUMED_SHAPE
)
541 as
->type
= AS_ASSUMED_SHAPE
;
545 gfc_error ("Bad specification for deferred shape array at %C");
548 case AS_ASSUMED_SIZE
:
549 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
551 as
->type
= AS_IMPLIED_SHAPE
;
555 gfc_error ("Bad specification for assumed size array at %C");
558 case AS_ASSUMED_RANK
:
562 if (gfc_match_char (')') == MATCH_YES
)
565 if (gfc_match_char (',') != MATCH_YES
)
567 gfc_error ("Expected another dimension in array declaration at %C");
571 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
573 gfc_error ("Array specification at %C has more than %d dimensions",
578 if (as
->corank
+ as
->rank
>= 7
579 && gfc_notify_std (GFC_STD_F2008
, "Array "
580 "specification at %C with more than 7 dimensions")
589 if (gfc_match_char ('[') != MATCH_YES
)
592 if (gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C")
596 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
598 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
602 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
604 gfc_error ("Array specification at %C has more than %d "
605 "dimensions", GFC_MAX_DIMENSIONS
);
612 current_type
= match_array_element_spec (as
);
614 if (current_type
== AS_UNKNOWN
)
618 as
->cotype
= current_type
;
621 { /* See how current spec meshes with the existing. */
622 case AS_IMPLIED_SHAPE
:
627 if (current_type
== AS_ASSUMED_SIZE
)
629 as
->cotype
= AS_ASSUMED_SIZE
;
633 if (current_type
== AS_EXPLICIT
)
636 gfc_error ("Bad array specification for an explicitly "
637 "shaped array at %C");
641 case AS_ASSUMED_SHAPE
:
642 if ((current_type
== AS_ASSUMED_SHAPE
)
643 || (current_type
== AS_DEFERRED
))
646 gfc_error ("Bad array specification for assumed shape "
651 if (current_type
== AS_DEFERRED
)
654 if (current_type
== AS_ASSUMED_SHAPE
)
656 as
->cotype
= AS_ASSUMED_SHAPE
;
660 gfc_error ("Bad specification for deferred shape array at %C");
663 case AS_ASSUMED_SIZE
:
664 gfc_error ("Bad specification for assumed size array at %C");
667 case AS_ASSUMED_RANK
:
671 if (gfc_match_char (']') == MATCH_YES
)
674 if (gfc_match_char (',') != MATCH_YES
)
676 gfc_error ("Expected another dimension in array declaration at %C");
680 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
682 gfc_error ("Array specification at %C has more than %d "
683 "dimensions", GFC_MAX_DIMENSIONS
);
688 if (current_type
== AS_EXPLICIT
)
690 gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
694 if (as
->cotype
== AS_ASSUMED_SIZE
)
695 as
->cotype
= AS_EXPLICIT
;
698 as
->type
= as
->cotype
;
701 if (as
->rank
== 0 && as
->corank
== 0)
704 gfc_free_array_spec (as
);
708 /* If a lower bounds of an assumed shape array is blank, put in one. */
709 if (as
->type
== AS_ASSUMED_SHAPE
)
711 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
713 if (as
->lower
[i
] == NULL
)
714 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
723 /* Something went wrong. */
724 gfc_free_array_spec (as
);
729 /* Given a symbol and an array specification, modify the symbol to
730 have that array specification. The error locus is needed in case
731 something goes wrong. On failure, the caller must free the spec. */
734 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
742 && gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
746 && gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
) == FAILURE
)
755 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
756 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
758 gfc_error ("The assumed-rank array '%s' at %L shall not have a "
759 "codimension", sym
->name
, error_loc
);
765 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
766 the codimension is simply added. */
767 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
769 sym
->as
->cotype
= as
->cotype
;
770 sym
->as
->corank
= as
->corank
;
771 for (i
= 0; i
< as
->corank
; i
++)
773 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
774 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
779 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
780 the dimension is added - but first the codimensions (if existing
781 need to be shifted to make space for the dimension. */
782 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
784 sym
->as
->rank
= as
->rank
;
785 sym
->as
->type
= as
->type
;
786 sym
->as
->cray_pointee
= as
->cray_pointee
;
787 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
789 for (i
= 0; i
< sym
->as
->corank
; i
++)
791 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
792 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
794 for (i
= 0; i
< as
->rank
; i
++)
796 sym
->as
->lower
[i
] = as
->lower
[i
];
797 sym
->as
->upper
[i
] = as
->upper
[i
];
806 /* Copy an array specification. */
809 gfc_copy_array_spec (gfc_array_spec
*src
)
811 gfc_array_spec
*dest
;
817 dest
= gfc_get_array_spec ();
821 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
823 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
824 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
831 /* Returns nonzero if the two expressions are equal. Only handles integer
835 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
837 if (bound1
== NULL
|| bound2
== NULL
838 || bound1
->expr_type
!= EXPR_CONSTANT
839 || bound2
->expr_type
!= EXPR_CONSTANT
840 || bound1
->ts
.type
!= BT_INTEGER
841 || bound2
->ts
.type
!= BT_INTEGER
)
842 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
844 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
851 /* Compares two array specifications. They must be constant or deferred
855 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
859 if (as1
== NULL
&& as2
== NULL
)
862 if (as1
== NULL
|| as2
== NULL
)
865 if (as1
->rank
!= as2
->rank
)
868 if (as1
->corank
!= as2
->corank
)
874 if (as1
->type
!= as2
->type
)
877 if (as1
->type
== AS_EXPLICIT
)
878 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
880 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
883 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
891 /****************** Array constructor functions ******************/
894 /* Given an expression node that might be an array constructor and a
895 symbol, make sure that no iterators in this or child constructors
896 use the symbol as an implied-DO iterator. Returns nonzero if a
897 duplicate was found. */
900 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
905 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
909 if (e
->expr_type
== EXPR_ARRAY
910 && check_duplicate_iterator (e
->value
.constructor
, master
))
913 if (c
->iterator
== NULL
)
916 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
918 gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
919 "same name", master
->name
, &c
->where
);
929 /* Forward declaration because these functions are mutually recursive. */
930 static match
match_array_cons_element (gfc_constructor_base
*);
932 /* Match a list of array elements. */
935 match_array_list (gfc_constructor_base
*result
)
937 gfc_constructor_base head
;
945 old_loc
= gfc_current_locus
;
947 if (gfc_match_char ('(') == MATCH_NO
)
950 memset (&iter
, '\0', sizeof (gfc_iterator
));
953 m
= match_array_cons_element (&head
);
957 if (gfc_match_char (',') != MATCH_YES
)
965 m
= gfc_match_iterator (&iter
, 0);
968 if (m
== MATCH_ERROR
)
971 m
= match_array_cons_element (&head
);
972 if (m
== MATCH_ERROR
)
979 goto cleanup
; /* Could be a complex constant */
982 if (gfc_match_char (',') != MATCH_YES
)
991 if (gfc_match_char (')') != MATCH_YES
)
994 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1000 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1001 e
->value
.constructor
= head
;
1003 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1004 p
->iterator
= gfc_get_iterator ();
1005 *p
->iterator
= iter
;
1010 gfc_error ("Syntax error in array constructor at %C");
1014 gfc_constructor_free (head
);
1015 gfc_free_iterator (&iter
, 0);
1016 gfc_current_locus
= old_loc
;
1021 /* Match a single element of an array constructor, which can be a
1022 single expression or a list of elements. */
1025 match_array_cons_element (gfc_constructor_base
*result
)
1030 m
= match_array_list (result
);
1034 m
= gfc_match_expr (&expr
);
1038 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1043 /* Match an array constructor. */
1046 gfc_match_array_constructor (gfc_expr
**result
)
1048 gfc_constructor_base head
, new_cons
;
1053 const char *end_delim
;
1056 if (gfc_match (" (/") == MATCH_NO
)
1058 if (gfc_match (" [") == MATCH_NO
)
1062 if (gfc_notify_std (GFC_STD_F2003
, "[...] "
1063 "style array constructors at %C") == FAILURE
)
1071 where
= gfc_current_locus
;
1072 head
= new_cons
= NULL
;
1075 /* Try to match an optional "type-spec ::" */
1077 if (gfc_match_decl_type_spec (&ts
, 0) == MATCH_YES
)
1079 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1083 if (gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1084 "including type specification at %C") == FAILURE
)
1089 gfc_error ("Type-spec at %L cannot contain a deferred "
1090 "type parameter", &where
);
1097 gfc_current_locus
= where
;
1099 if (gfc_match (end_delim
) == MATCH_YES
)
1105 gfc_error ("Empty array constructor at %C is not allowed");
1112 m
= match_array_cons_element (&head
);
1113 if (m
== MATCH_ERROR
)
1118 if (gfc_match_char (',') == MATCH_NO
)
1122 if (gfc_match (end_delim
) == MATCH_NO
)
1126 /* Size must be calculated at resolution time. */
1129 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1133 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1135 expr
->value
.constructor
= head
;
1137 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1143 gfc_error ("Syntax error in array constructor at %C");
1146 gfc_constructor_free (head
);
1152 /************** Check array constructors for correctness **************/
1154 /* Given an expression, compare it's type with the type of the current
1155 constructor. Returns nonzero if an error was issued. The
1156 cons_state variable keeps track of whether the type of the
1157 constructor being read or resolved is known to be good, bad or just
1160 static gfc_typespec constructor_ts
;
1162 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1166 check_element_type (gfc_expr
*expr
, bool convert
)
1168 if (cons_state
== CONS_BAD
)
1169 return 0; /* Suppress further errors */
1171 if (cons_state
== CONS_START
)
1173 if (expr
->ts
.type
== BT_UNKNOWN
)
1174 cons_state
= CONS_BAD
;
1177 cons_state
= CONS_GOOD
;
1178 constructor_ts
= expr
->ts
;
1184 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1188 return gfc_convert_type (expr
, &constructor_ts
, 1) == SUCCESS
? 0 : 1;
1190 gfc_error ("Element in %s array constructor at %L is %s",
1191 gfc_typename (&constructor_ts
), &expr
->where
,
1192 gfc_typename (&expr
->ts
));
1194 cons_state
= CONS_BAD
;
1199 /* Recursive work function for gfc_check_constructor_type(). */
1202 check_constructor_type (gfc_constructor_base base
, bool convert
)
1207 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1211 if (e
->expr_type
== EXPR_ARRAY
)
1213 if (check_constructor_type (e
->value
.constructor
, convert
) == FAILURE
)
1219 if (check_element_type (e
, convert
))
1227 /* Check that all elements of an array constructor are the same type.
1228 On FAILURE, an error has been generated. */
1231 gfc_check_constructor_type (gfc_expr
*e
)
1235 if (e
->ts
.type
!= BT_UNKNOWN
)
1237 cons_state
= CONS_GOOD
;
1238 constructor_ts
= e
->ts
;
1242 cons_state
= CONS_START
;
1243 gfc_clear_ts (&constructor_ts
);
1246 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1247 typespec, and we will now convert the values on the fly. */
1248 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1249 if (t
== SUCCESS
&& e
->ts
.type
== BT_UNKNOWN
)
1250 e
->ts
= constructor_ts
;
1257 typedef struct cons_stack
1259 gfc_iterator
*iterator
;
1260 struct cons_stack
*previous
;
1264 static cons_stack
*base
;
1266 static gfc_try
check_constructor (gfc_constructor_base
, gfc_try (*) (gfc_expr
*));
1268 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1269 that that variable is an iteration variables. */
1272 gfc_check_iter_variable (gfc_expr
*expr
)
1277 sym
= expr
->symtree
->n
.sym
;
1279 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1280 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1287 /* Recursive work function for gfc_check_constructor(). This amounts
1288 to calling the check function for each expression in the
1289 constructor, giving variables with the names of iterators a pass. */
1292 check_constructor (gfc_constructor_base ctor
, gfc_try (*check_function
) (gfc_expr
*))
1299 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1303 if (e
->expr_type
!= EXPR_ARRAY
)
1305 if ((*check_function
) (e
) == FAILURE
)
1310 element
.previous
= base
;
1311 element
.iterator
= c
->iterator
;
1314 t
= check_constructor (e
->value
.constructor
, check_function
);
1315 base
= element
.previous
;
1321 /* Nothing went wrong, so all OK. */
1326 /* Checks a constructor to see if it is a particular kind of
1327 expression -- specification, restricted, or initialization as
1328 determined by the check_function. */
1331 gfc_check_constructor (gfc_expr
*expr
, gfc_try (*check_function
) (gfc_expr
*))
1333 cons_stack
*base_save
;
1339 t
= check_constructor (expr
->value
.constructor
, check_function
);
1347 /**************** Simplification of array constructors ****************/
1349 iterator_stack
*iter_stack
;
1353 gfc_constructor_base base
;
1354 int extract_count
, extract_n
;
1355 gfc_expr
*extracted
;
1359 gfc_component
*component
;
1362 gfc_try (*expand_work_function
) (gfc_expr
*);
1366 static expand_info current_expand
;
1368 static gfc_try
expand_constructor (gfc_constructor_base
);
1371 /* Work function that counts the number of elements present in a
1375 count_elements (gfc_expr
*e
)
1380 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1383 if (gfc_array_size (e
, &result
) == FAILURE
)
1389 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1398 /* Work function that extracts a particular element from an array
1399 constructor, freeing the rest. */
1402 extract_element (gfc_expr
*e
)
1405 { /* Something unextractable */
1410 if (current_expand
.extract_count
== current_expand
.extract_n
)
1411 current_expand
.extracted
= e
;
1415 current_expand
.extract_count
++;
1421 /* Work function that constructs a new constructor out of the old one,
1422 stringing new elements together. */
1425 expand (gfc_expr
*e
)
1427 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1430 c
->n
.component
= current_expand
.component
;
1435 /* Given an initialization expression that is a variable reference,
1436 substitute the current value of the iteration variable. */
1439 gfc_simplify_iterator_var (gfc_expr
*e
)
1443 for (p
= iter_stack
; p
; p
= p
->prev
)
1444 if (e
->symtree
== p
->variable
)
1448 return; /* Variable not found */
1450 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1452 mpz_set (e
->value
.integer
, p
->value
);
1458 /* Expand an expression with that is inside of a constructor,
1459 recursing into other constructors if present. */
1462 expand_expr (gfc_expr
*e
)
1464 if (e
->expr_type
== EXPR_ARRAY
)
1465 return expand_constructor (e
->value
.constructor
);
1467 e
= gfc_copy_expr (e
);
1469 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1475 return current_expand
.expand_work_function (e
);
1480 expand_iterator (gfc_constructor
*c
)
1482 gfc_expr
*start
, *end
, *step
;
1483 iterator_stack frame
;
1492 mpz_init (frame
.value
);
1495 start
= gfc_copy_expr (c
->iterator
->start
);
1496 if (gfc_simplify_expr (start
, 1) == FAILURE
)
1499 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1502 end
= gfc_copy_expr (c
->iterator
->end
);
1503 if (gfc_simplify_expr (end
, 1) == FAILURE
)
1506 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1509 step
= gfc_copy_expr (c
->iterator
->step
);
1510 if (gfc_simplify_expr (step
, 1) == FAILURE
)
1513 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1516 if (mpz_sgn (step
->value
.integer
) == 0)
1518 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1522 /* Calculate the trip count of the loop. */
1523 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1524 mpz_add (trip
, trip
, step
->value
.integer
);
1525 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1527 mpz_set (frame
.value
, start
->value
.integer
);
1529 frame
.prev
= iter_stack
;
1530 frame
.variable
= c
->iterator
->var
->symtree
;
1531 iter_stack
= &frame
;
1533 while (mpz_sgn (trip
) > 0)
1535 if (expand_expr (c
->expr
) == FAILURE
)
1538 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1539 mpz_sub_ui (trip
, trip
, 1);
1545 gfc_free_expr (start
);
1546 gfc_free_expr (end
);
1547 gfc_free_expr (step
);
1550 mpz_clear (frame
.value
);
1552 iter_stack
= frame
.prev
;
1558 /* Expand a constructor into constant constructors without any
1559 iterators, calling the work function for each of the expanded
1560 expressions. The work function needs to either save or free the
1561 passed expression. */
1564 expand_constructor (gfc_constructor_base base
)
1569 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1571 if (c
->iterator
!= NULL
)
1573 if (expand_iterator (c
) == FAILURE
)
1580 if (e
->expr_type
== EXPR_ARRAY
)
1582 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1588 e
= gfc_copy_expr (e
);
1589 if (gfc_simplify_expr (e
, 1) == FAILURE
)
1594 current_expand
.offset
= &c
->offset
;
1595 current_expand
.repeat
= &c
->repeat
;
1596 current_expand
.component
= c
->n
.component
;
1597 if (current_expand
.expand_work_function (e
) == FAILURE
)
1604 /* Given an array expression and an element number (starting at zero),
1605 return a pointer to the array element. NULL is returned if the
1606 size of the array has been exceeded. The expression node returned
1607 remains a part of the array and should not be freed. Access is not
1608 efficient at all, but this is another place where things do not
1609 have to be particularly fast. */
1612 gfc_get_array_element (gfc_expr
*array
, int element
)
1614 expand_info expand_save
;
1618 expand_save
= current_expand
;
1619 current_expand
.extract_n
= element
;
1620 current_expand
.expand_work_function
= extract_element
;
1621 current_expand
.extracted
= NULL
;
1622 current_expand
.extract_count
= 0;
1626 rc
= expand_constructor (array
->value
.constructor
);
1627 e
= current_expand
.extracted
;
1628 current_expand
= expand_save
;
1637 /* Top level subroutine for expanding constructors. We only expand
1638 constructor if they are small enough. */
1641 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1643 expand_info expand_save
;
1647 /* If we can successfully get an array element at the max array size then
1648 the array is too big to expand, so we just return. */
1649 f
= gfc_get_array_element (e
, gfc_option
.flag_max_array_constructor
);
1655 gfc_error ("The number of elements in the array constructor "
1656 "at %L requires an increase of the allowed %d "
1657 "upper limit. See -fmax-array-constructor "
1658 "option", &e
->where
,
1659 gfc_option
.flag_max_array_constructor
);
1665 /* We now know the array is not too big so go ahead and try to expand it. */
1666 expand_save
= current_expand
;
1667 current_expand
.base
= NULL
;
1671 current_expand
.expand_work_function
= expand
;
1673 if (expand_constructor (e
->value
.constructor
) == FAILURE
)
1675 gfc_constructor_free (current_expand
.base
);
1680 gfc_constructor_free (e
->value
.constructor
);
1681 e
->value
.constructor
= current_expand
.base
;
1686 current_expand
= expand_save
;
1692 /* Work function for checking that an element of a constructor is a
1693 constant, after removal of any iteration variables. We return
1694 FAILURE if not so. */
1697 is_constant_element (gfc_expr
*e
)
1701 rv
= gfc_is_constant_expr (e
);
1704 return rv
? SUCCESS
: FAILURE
;
1708 /* Given an array constructor, determine if the constructor is
1709 constant or not by expanding it and making sure that all elements
1710 are constants. This is a bit of a hack since something like (/ (i,
1711 i=1,100000000) /) will take a while as* opposed to a more clever
1712 function that traverses the expression tree. FIXME. */
1715 gfc_constant_ac (gfc_expr
*e
)
1717 expand_info expand_save
;
1721 expand_save
= current_expand
;
1722 current_expand
.expand_work_function
= is_constant_element
;
1724 rc
= expand_constructor (e
->value
.constructor
);
1726 current_expand
= expand_save
;
1734 /* Returns nonzero if an array constructor has been completely
1735 expanded (no iterators) and zero if iterators are present. */
1738 gfc_expanded_ac (gfc_expr
*e
)
1742 if (e
->expr_type
== EXPR_ARRAY
)
1743 for (c
= gfc_constructor_first (e
->value
.constructor
);
1744 c
; c
= gfc_constructor_next (c
))
1745 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1752 /*************** Type resolution of array constructors ***************/
1755 /* The symbol expr_is_sought_symbol_ref will try to find. */
1756 static const gfc_symbol
*sought_symbol
= NULL
;
1759 /* Tells whether the expression E is a variable reference to the symbol
1760 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1762 To be used with gfc_expr_walker: if a reference is found we don't need
1763 to look further so we return 1 to skip any further walk. */
1766 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1769 gfc_expr
*expr
= *e
;
1770 locus
*sym_loc
= (locus
*)where
;
1772 if (expr
->expr_type
== EXPR_VARIABLE
1773 && expr
->symtree
->n
.sym
== sought_symbol
)
1775 *sym_loc
= expr
->where
;
1783 /* Tells whether the expression EXPR contains a reference to the symbol
1784 SYM and in that case sets the position SYM_LOC where the reference is. */
1787 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1791 sought_symbol
= sym
;
1792 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1793 sought_symbol
= NULL
;
1798 /* Recursive array list resolution function. All of the elements must
1799 be of the same type. */
1802 resolve_array_list (gfc_constructor_base base
)
1810 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1815 gfc_symbol
*iter_var
;
1818 if (gfc_resolve_iterator (iter
, false, true) == FAILURE
)
1821 /* Check for bounds referencing the iterator variable. */
1822 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1823 iter_var
= iter
->var
->symtree
->n
.sym
;
1824 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1826 if (gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1827 "expression references control variable "
1828 "at %L", &iter_var_loc
) == FAILURE
)
1831 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1833 if (gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1834 "expression references control variable "
1835 "at %L", &iter_var_loc
) == FAILURE
)
1838 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1840 if (gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1841 "expression references control variable "
1842 "at %L", &iter_var_loc
) == FAILURE
)
1847 if (gfc_resolve_expr (c
->expr
) == FAILURE
)
1850 if (UNLIMITED_POLY (c
->expr
))
1852 gfc_error ("Array constructor value at %L shall not be unlimited "
1853 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1861 /* Resolve character array constructor. If it has a specified constant character
1862 length, pad/truncate the elements here; if the length is not specified and
1863 all elements are of compile-time known length, emit an error as this is
1867 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1872 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1873 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1875 if (expr
->ts
.u
.cl
== NULL
)
1877 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1878 p
; p
= gfc_constructor_next (p
))
1879 if (p
->expr
->ts
.u
.cl
!= NULL
)
1881 /* Ensure that if there is a char_len around that it is
1882 used; otherwise the middle-end confuses them! */
1883 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1887 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1894 if (expr
->ts
.u
.cl
->length
== NULL
)
1896 /* Check that all constant string elements have the same length until
1897 we reach the end or find a variable-length one. */
1899 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1900 p
; p
= gfc_constructor_next (p
))
1902 int current_length
= -1;
1904 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1905 if (ref
->type
== REF_SUBSTRING
1906 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1907 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1910 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1911 current_length
= p
->expr
->value
.character
.length
;
1915 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1916 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1917 current_length
= (int) j
;
1919 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1920 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1923 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1924 current_length
= (int) j
;
1929 gcc_assert (current_length
!= -1);
1931 if (found_length
== -1)
1932 found_length
= current_length
;
1933 else if (found_length
!= current_length
)
1935 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1936 " constructor at %L", found_length
, current_length
,
1941 gcc_assert (found_length
== current_length
);
1944 gcc_assert (found_length
!= -1);
1946 /* Update the character length of the array constructor. */
1947 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1948 NULL
, found_length
);
1952 /* We've got a character length specified. It should be an integer,
1953 otherwise an error is signalled elsewhere. */
1954 gcc_assert (expr
->ts
.u
.cl
->length
);
1956 /* If we've got a constant character length, pad according to this.
1957 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1958 max_length only if they pass. */
1959 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1961 /* Now pad/truncate the elements accordingly to the specified character
1962 length. This is ok inside this conditional, as in the case above
1963 (without typespec) all elements are verified to have the same length
1965 if (found_length
!= -1)
1966 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1967 p
; p
= gfc_constructor_next (p
))
1968 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1970 gfc_expr
*cl
= NULL
;
1971 int current_length
= -1;
1974 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1976 cl
= p
->expr
->ts
.u
.cl
->length
;
1977 gfc_extract_int (cl
, ¤t_length
);
1980 /* If gfc_extract_int above set current_length, we implicitly
1981 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1983 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
1986 || (current_length
!= -1 && current_length
!= found_length
))
1987 gfc_set_constant_character_len (found_length
, p
->expr
,
1988 has_ts
? -1 : found_length
);
1996 /* Resolve all of the expressions in an array list. */
1999 gfc_resolve_array_constructor (gfc_expr
*expr
)
2003 t
= resolve_array_list (expr
->value
.constructor
);
2005 t
= gfc_check_constructor_type (expr
);
2007 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2008 the call to this function, so we don't need to call it here; if it was
2009 called twice, an error message there would be duplicated. */
2015 /* Copy an iterator structure. */
2018 gfc_copy_iterator (gfc_iterator
*src
)
2025 dest
= gfc_get_iterator ();
2027 dest
->var
= gfc_copy_expr (src
->var
);
2028 dest
->start
= gfc_copy_expr (src
->start
);
2029 dest
->end
= gfc_copy_expr (src
->end
);
2030 dest
->step
= gfc_copy_expr (src
->step
);
2036 /********* Subroutines for determining the size of an array *********/
2038 /* These are needed just to accommodate RESHAPE(). There are no
2039 diagnostics here, we just return a negative number if something
2043 /* Get the size of single dimension of an array specification. The
2044 array is guaranteed to be one dimensional. */
2047 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2052 if (dimen
< 0 || dimen
> as
->rank
- 1)
2053 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2055 if (as
->type
!= AS_EXPLICIT
2056 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2057 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2058 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2059 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2064 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2065 as
->lower
[dimen
]->value
.integer
);
2067 mpz_add_ui (*result
, *result
, 1);
2074 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2079 if (as
->type
== AS_ASSUMED_RANK
)
2082 mpz_init_set_ui (*result
, 1);
2084 for (d
= 0; d
< as
->rank
; d
++)
2086 if (spec_dimen_size (as
, d
, &size
) == FAILURE
)
2088 mpz_clear (*result
);
2092 mpz_mul (*result
, *result
, size
);
2100 /* Get the number of elements in an array section. Optionally, also supply
2104 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2106 mpz_t upper
, lower
, stride
;
2109 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2110 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2112 switch (ar
->dimen_type
[dimen
])
2116 mpz_set_ui (*result
, 1);
2121 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2130 if (ar
->start
[dimen
] == NULL
)
2132 if (ar
->as
->lower
[dimen
] == NULL
2133 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2135 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2139 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2141 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2144 if (ar
->end
[dimen
] == NULL
)
2146 if (ar
->as
->upper
[dimen
] == NULL
2147 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2149 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2153 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2155 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2158 if (ar
->stride
[dimen
] == NULL
)
2159 mpz_set_ui (stride
, 1);
2162 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2164 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2168 mpz_sub (*result
, upper
, lower
);
2169 mpz_add (*result
, *result
, stride
);
2170 mpz_div (*result
, *result
, stride
);
2172 /* Zero stride caught earlier. */
2173 if (mpz_cmp_ui (*result
, 0) < 0)
2174 mpz_set_ui (*result
, 0);
2181 mpz_sub_ui (*end
, *result
, 1UL);
2182 mpz_mul (*end
, *end
, stride
);
2183 mpz_add (*end
, *end
, lower
);
2193 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2201 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2206 mpz_init_set_ui (*result
, 1);
2208 for (d
= 0; d
< ar
->dimen
; d
++)
2210 if (gfc_ref_dimen_size (ar
, d
, &size
, NULL
) == FAILURE
)
2212 mpz_clear (*result
);
2216 mpz_mul (*result
, *result
, size
);
2224 /* Given an array expression and a dimension, figure out how many
2225 elements it has along that dimension. Returns SUCCESS if we were
2226 able to return a result in the 'result' variable, FAILURE
2230 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2235 gcc_assert (array
!= NULL
);
2237 if (array
->ts
.type
== BT_CLASS
)
2240 if (array
->rank
== -1)
2243 if (dimen
< 0 || dimen
> array
->rank
- 1)
2244 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2246 switch (array
->expr_type
)
2250 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2252 if (ref
->type
!= REF_ARRAY
)
2255 if (ref
->u
.ar
.type
== AR_FULL
)
2256 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2258 if (ref
->u
.ar
.type
== AR_SECTION
)
2260 for (i
= 0; dimen
>= 0; i
++)
2261 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2264 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2268 if (array
->shape
&& array
->shape
[dimen
])
2270 mpz_init_set (*result
, array
->shape
[dimen
]);
2274 if (array
->symtree
->n
.sym
->attr
.generic
2275 && array
->value
.function
.esym
!= NULL
)
2277 if (spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
)
2281 else if (spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
)
2288 if (array
->shape
== NULL
) {
2289 /* Expressions with rank > 1 should have "shape" properly set */
2290 if ( array
->rank
!= 1 )
2291 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2292 return gfc_array_size(array
, result
);
2297 if (array
->shape
== NULL
)
2300 mpz_init_set (*result
, array
->shape
[dimen
]);
2309 /* Given an array expression, figure out how many elements are in the
2310 array. Returns SUCCESS if this is possible, and sets the 'result'
2311 variable. Otherwise returns FAILURE. */
2314 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2316 expand_info expand_save
;
2321 if (array
->ts
.type
== BT_CLASS
)
2324 switch (array
->expr_type
)
2327 gfc_push_suppress_errors ();
2329 expand_save
= current_expand
;
2331 current_expand
.count
= result
;
2332 mpz_init_set_ui (*result
, 0);
2334 current_expand
.expand_work_function
= count_elements
;
2337 t
= expand_constructor (array
->value
.constructor
);
2339 gfc_pop_suppress_errors ();
2342 mpz_clear (*result
);
2343 current_expand
= expand_save
;
2347 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2349 if (ref
->type
!= REF_ARRAY
)
2352 if (ref
->u
.ar
.type
== AR_FULL
)
2353 return spec_size (ref
->u
.ar
.as
, result
);
2355 if (ref
->u
.ar
.type
== AR_SECTION
)
2356 return ref_size (&ref
->u
.ar
, result
);
2359 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2363 if (array
->rank
== 0 || array
->shape
== NULL
)
2366 mpz_init_set_ui (*result
, 1);
2368 for (i
= 0; i
< array
->rank
; i
++)
2369 mpz_mul (*result
, *result
, array
->shape
[i
]);
2378 /* Given an array reference, return the shape of the reference in an
2379 array of mpz_t integers. */
2382 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2392 for (; d
< ar
->as
->rank
; d
++)
2393 if (spec_dimen_size (ar
->as
, d
, &shape
[d
]) == FAILURE
)
2399 for (i
= 0; i
< ar
->dimen
; i
++)
2401 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2403 if (gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
) == FAILURE
)
2416 gfc_clear_shape (shape
, d
);
2421 /* Given an array expression, find the array reference structure that
2422 characterizes the reference. */
2425 gfc_find_array_ref (gfc_expr
*e
)
2429 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2430 if (ref
->type
== REF_ARRAY
2431 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2435 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2441 /* Find out if an array shape is known at compile time. */
2444 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2448 if (as
->type
!= AS_EXPLICIT
)
2451 for (i
= 0; i
< as
->rank
; i
++)
2452 if (!gfc_is_constant_expr (as
->lower
[i
])
2453 || !gfc_is_constant_expr (as
->upper
[i
]))