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"
27 #include "constructor.h"
29 /**************** Array reference matching subroutines *****************/
31 /* Copy an array reference structure. */
34 gfc_copy_array_ref (gfc_array_ref
*src
)
42 dest
= gfc_get_array_ref ();
46 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
48 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
49 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
50 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
57 /* Match a single dimension of an array reference. This can be a
58 single element or an array section. Any modifications we've made
59 to the ar structure are cleaned up by the caller. If the init
60 is set, we require the subscript to be a valid initialization
64 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
66 match m
= MATCH_ERROR
;
70 i
= ar
->dimen
+ ar
->codimen
;
72 gfc_gobble_whitespace ();
73 ar
->c_where
[i
] = gfc_current_locus
;
74 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
76 /* We can't be sure of the difference between DIMEN_ELEMENT and
77 DIMEN_VECTOR until we know the type of the element itself at
80 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
82 if (gfc_match_char (':') == MATCH_YES
)
85 /* Get start element. */
86 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
90 m
= gfc_match_init_expr (&ar
->start
[i
]);
92 m
= gfc_match_expr (&ar
->start
[i
]);
95 gfc_error ("Expected array subscript at %C");
99 if (gfc_match_char (':') == MATCH_NO
)
104 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
108 /* Get an optional end element. Because we've seen the colon, we
109 definitely have a range along this dimension. */
111 ar
->dimen_type
[i
] = DIMEN_RANGE
;
113 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
116 m
= gfc_match_init_expr (&ar
->end
[i
]);
118 m
= gfc_match_expr (&ar
->end
[i
]);
120 if (m
== MATCH_ERROR
)
123 /* See if we have an optional stride. */
124 if (gfc_match_char (':') == MATCH_YES
)
128 gfc_error ("Strides not allowed in coarray subscript at %C");
132 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
133 : gfc_match_expr (&ar
->stride
[i
]);
136 gfc_error ("Expected array subscript stride at %C");
143 ar
->dimen_type
[i
] = DIMEN_STAR
;
149 /* Match an array reference, whether it is the whole array or a
150 particular elements or a section. If init is set, the reference has
151 to consist of init expressions. */
154 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
158 bool matched_bracket
= false;
160 memset (ar
, '\0', sizeof (*ar
));
162 ar
->where
= gfc_current_locus
;
164 ar
->type
= AR_UNKNOWN
;
166 if (gfc_match_char ('[') == MATCH_YES
)
168 matched_bracket
= true;
172 if (gfc_match_char ('(') != MATCH_YES
)
179 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
181 m
= match_subscript (ar
, init
, false);
182 if (m
== MATCH_ERROR
)
185 if (gfc_match_char (')') == MATCH_YES
)
191 if (gfc_match_char (',') != MATCH_YES
)
193 gfc_error ("Invalid form of array reference at %C");
198 gfc_error ("Array reference at %C cannot have more than %d dimensions",
203 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
211 if (flag_coarray
== GFC_FCOARRAY_NONE
)
213 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
219 gfc_error ("Unexpected coarray designator at %C");
223 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
225 m
= match_subscript (ar
, init
, true);
226 if (m
== MATCH_ERROR
)
229 if (gfc_match_char (']') == MATCH_YES
)
232 if (ar
->codimen
< corank
)
234 gfc_error ("Too few codimensions at %C, expected %d not %d",
235 corank
, ar
->codimen
);
238 if (ar
->codimen
> corank
)
240 gfc_error ("Too many codimensions at %C, expected %d not %d",
241 corank
, ar
->codimen
);
247 if (gfc_match_char (',') != MATCH_YES
)
249 if (gfc_match_char ('*') == MATCH_YES
)
250 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
251 ar
->codimen
+ 1, corank
);
253 gfc_error ("Invalid form of coarray reference at %C");
256 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
258 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
259 ar
->codimen
+ 1, corank
);
263 if (ar
->codimen
>= corank
)
265 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
266 ar
->codimen
+ 1, corank
);
271 gfc_error ("Array reference at %C cannot have more than %d dimensions",
278 /************** Array specification matching subroutines ***************/
280 /* Free all of the expressions associated with array bounds
284 gfc_free_array_spec (gfc_array_spec
*as
)
291 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
293 gfc_free_expr (as
->lower
[i
]);
294 gfc_free_expr (as
->upper
[i
]);
301 /* Take an array bound, resolves the expression, that make up the
302 shape and check associated constraints. */
305 resolve_array_bound (gfc_expr
*e
, int check_constant
)
310 if (!gfc_resolve_expr (e
)
311 || !gfc_specification_expr (e
))
314 if (check_constant
&& !gfc_is_constant_expr (e
))
316 if (e
->expr_type
== EXPR_VARIABLE
)
317 gfc_error ("Variable %qs at %L in this context must be constant",
318 e
->symtree
->n
.sym
->name
, &e
->where
);
320 gfc_error ("Expression at %L in this context must be constant",
329 /* Takes an array specification, resolves the expressions that make up
330 the shape and make sure everything is integral. */
333 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
344 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
347 if (!resolve_array_bound (e
, check_constant
))
351 if (!resolve_array_bound (e
, check_constant
))
354 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
357 /* If the size is negative in this dimension, set it to zero. */
358 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
359 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
360 && mpz_cmp (as
->upper
[i
]->value
.integer
,
361 as
->lower
[i
]->value
.integer
) < 0)
363 gfc_free_expr (as
->upper
[i
]);
364 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
365 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
366 as
->upper
[i
]->value
.integer
, 1);
376 /* Match a single array element specification. The return values as
377 well as the upper and lower bounds of the array spec are filled
378 in according to what we see on the input. The caller makes sure
379 individual specifications make sense as a whole.
382 Parsed Lower Upper Returned
383 ------------------------------------
384 : NULL NULL AS_DEFERRED (*)
386 x: x NULL AS_ASSUMED_SHAPE
388 x:* x NULL AS_ASSUMED_SIZE
389 * 1 NULL AS_ASSUMED_SIZE
391 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
392 is fixed during the resolution of formal interfaces.
394 Anything else AS_UNKNOWN. */
397 match_array_element_spec (gfc_array_spec
*as
)
399 gfc_expr
**upper
, **lower
;
403 rank
= as
->rank
== -1 ? 0 : as
->rank
;
404 lower
= &as
->lower
[rank
+ as
->corank
- 1];
405 upper
= &as
->upper
[rank
+ as
->corank
- 1];
407 if (gfc_match_char ('*') == MATCH_YES
)
409 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
410 return AS_ASSUMED_SIZE
;
413 if (gfc_match_char (':') == MATCH_YES
)
416 m
= gfc_match_expr (upper
);
418 gfc_error ("Expected expression in array specification at %C");
421 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
424 if (gfc_match_char (':') == MATCH_NO
)
426 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
433 if (gfc_match_char ('*') == MATCH_YES
)
434 return AS_ASSUMED_SIZE
;
436 m
= gfc_match_expr (upper
);
437 if (m
== MATCH_ERROR
)
440 return AS_ASSUMED_SHAPE
;
441 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
448 /* Matches an array specification, incidentally figuring out what sort
449 it is. Match either a normal array specification, or a coarray spec
450 or both. Optionally allow [:] for coarrays. */
453 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
455 array_type current_type
;
459 as
= gfc_get_array_spec ();
464 if (gfc_match_char ('(') != MATCH_YES
)
471 if (gfc_match (" .. )") == MATCH_YES
)
473 as
->type
= AS_ASSUMED_RANK
;
476 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C"))
487 current_type
= match_array_element_spec (as
);
489 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
490 and implied-shape specifications. If the rank is at least 2, we can
491 distinguish between them. But for rank 1, we currently return
492 ASSUMED_SIZE; this gets adjusted later when we know for sure
493 whether the symbol parsed is a PARAMETER or not. */
497 if (current_type
== AS_UNKNOWN
)
499 as
->type
= current_type
;
503 { /* See how current spec meshes with the existing. */
507 case AS_IMPLIED_SHAPE
:
508 if (current_type
!= AS_ASSUMED_SHAPE
)
510 gfc_error ("Bad array specification for implied-shape"
517 if (current_type
== AS_ASSUMED_SIZE
)
519 as
->type
= AS_ASSUMED_SIZE
;
523 if (current_type
== AS_EXPLICIT
)
526 gfc_error ("Bad array specification for an explicitly shaped "
531 case AS_ASSUMED_SHAPE
:
532 if ((current_type
== AS_ASSUMED_SHAPE
)
533 || (current_type
== AS_DEFERRED
))
536 gfc_error ("Bad array specification for assumed shape "
541 if (current_type
== AS_DEFERRED
)
544 if (current_type
== AS_ASSUMED_SHAPE
)
546 as
->type
= AS_ASSUMED_SHAPE
;
550 gfc_error ("Bad specification for deferred shape array at %C");
553 case AS_ASSUMED_SIZE
:
554 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
556 as
->type
= AS_IMPLIED_SHAPE
;
560 gfc_error ("Bad specification for assumed size array at %C");
563 case AS_ASSUMED_RANK
:
567 if (gfc_match_char (')') == MATCH_YES
)
570 if (gfc_match_char (',') != MATCH_YES
)
572 gfc_error ("Expected another dimension in array declaration at %C");
576 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
578 gfc_error ("Array specification at %C has more than %d dimensions",
583 if (as
->corank
+ as
->rank
>= 7
584 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
585 "with more than 7 dimensions"))
593 if (gfc_match_char ('[') != MATCH_YES
)
596 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
599 if (flag_coarray
== GFC_FCOARRAY_NONE
)
601 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
605 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
607 gfc_error ("Array specification at %C has more than %d "
608 "dimensions", GFC_MAX_DIMENSIONS
);
615 current_type
= match_array_element_spec (as
);
617 if (current_type
== AS_UNKNOWN
)
621 as
->cotype
= current_type
;
624 { /* See how current spec meshes with the existing. */
625 case AS_IMPLIED_SHAPE
:
630 if (current_type
== AS_ASSUMED_SIZE
)
632 as
->cotype
= AS_ASSUMED_SIZE
;
636 if (current_type
== AS_EXPLICIT
)
639 gfc_error ("Bad array specification for an explicitly "
640 "shaped array at %C");
644 case AS_ASSUMED_SHAPE
:
645 if ((current_type
== AS_ASSUMED_SHAPE
)
646 || (current_type
== AS_DEFERRED
))
649 gfc_error ("Bad array specification for assumed shape "
654 if (current_type
== AS_DEFERRED
)
657 if (current_type
== AS_ASSUMED_SHAPE
)
659 as
->cotype
= AS_ASSUMED_SHAPE
;
663 gfc_error ("Bad specification for deferred shape array at %C");
666 case AS_ASSUMED_SIZE
:
667 gfc_error ("Bad specification for assumed size array at %C");
670 case AS_ASSUMED_RANK
:
674 if (gfc_match_char (']') == MATCH_YES
)
677 if (gfc_match_char (',') != MATCH_YES
)
679 gfc_error ("Expected another dimension in array declaration at %C");
683 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
685 gfc_error ("Array specification at %C has more than %d "
686 "dimensions", GFC_MAX_DIMENSIONS
);
691 if (current_type
== AS_EXPLICIT
)
693 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
697 if (as
->cotype
== AS_ASSUMED_SIZE
)
698 as
->cotype
= AS_EXPLICIT
;
701 as
->type
= as
->cotype
;
704 if (as
->rank
== 0 && as
->corank
== 0)
707 gfc_free_array_spec (as
);
711 /* If a lower bounds of an assumed shape array is blank, put in one. */
712 if (as
->type
== AS_ASSUMED_SHAPE
)
714 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
716 if (as
->lower
[i
] == NULL
)
717 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
726 /* Something went wrong. */
727 gfc_free_array_spec (as
);
732 /* Given a symbol and an array specification, modify the symbol to
733 have that array specification. The error locus is needed in case
734 something goes wrong. On failure, the caller must free the spec. */
737 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
745 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
749 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
758 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
759 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
761 gfc_error ("The assumed-rank array %qs at %L shall not have a "
762 "codimension", sym
->name
, error_loc
);
768 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
769 the codimension is simply added. */
770 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
772 sym
->as
->cotype
= as
->cotype
;
773 sym
->as
->corank
= as
->corank
;
774 for (i
= 0; i
< as
->corank
; i
++)
776 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
777 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
782 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
783 the dimension is added - but first the codimensions (if existing
784 need to be shifted to make space for the dimension. */
785 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
787 sym
->as
->rank
= as
->rank
;
788 sym
->as
->type
= as
->type
;
789 sym
->as
->cray_pointee
= as
->cray_pointee
;
790 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
792 for (i
= 0; i
< sym
->as
->corank
; i
++)
794 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
795 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
797 for (i
= 0; i
< as
->rank
; i
++)
799 sym
->as
->lower
[i
] = as
->lower
[i
];
800 sym
->as
->upper
[i
] = as
->upper
[i
];
809 /* Copy an array specification. */
812 gfc_copy_array_spec (gfc_array_spec
*src
)
814 gfc_array_spec
*dest
;
820 dest
= gfc_get_array_spec ();
824 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
826 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
827 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
834 /* Returns nonzero if the two expressions are equal. Only handles integer
838 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
840 if (bound1
== NULL
|| bound2
== NULL
841 || bound1
->expr_type
!= EXPR_CONSTANT
842 || bound2
->expr_type
!= EXPR_CONSTANT
843 || bound1
->ts
.type
!= BT_INTEGER
844 || bound2
->ts
.type
!= BT_INTEGER
)
845 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
847 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
854 /* Compares two array specifications. They must be constant or deferred
858 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
862 if (as1
== NULL
&& as2
== NULL
)
865 if (as1
== NULL
|| as2
== NULL
)
868 if (as1
->rank
!= as2
->rank
)
871 if (as1
->corank
!= as2
->corank
)
877 if (as1
->type
!= as2
->type
)
880 if (as1
->type
== AS_EXPLICIT
)
881 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
883 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
886 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
894 /****************** Array constructor functions ******************/
897 /* Given an expression node that might be an array constructor and a
898 symbol, make sure that no iterators in this or child constructors
899 use the symbol as an implied-DO iterator. Returns nonzero if a
900 duplicate was found. */
903 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
908 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
912 if (e
->expr_type
== EXPR_ARRAY
913 && check_duplicate_iterator (e
->value
.constructor
, master
))
916 if (c
->iterator
== NULL
)
919 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
921 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
922 "same name", master
->name
, &c
->where
);
932 /* Forward declaration because these functions are mutually recursive. */
933 static match
match_array_cons_element (gfc_constructor_base
*);
935 /* Match a list of array elements. */
938 match_array_list (gfc_constructor_base
*result
)
940 gfc_constructor_base head
;
948 old_loc
= gfc_current_locus
;
950 if (gfc_match_char ('(') == MATCH_NO
)
953 memset (&iter
, '\0', sizeof (gfc_iterator
));
956 m
= match_array_cons_element (&head
);
960 if (gfc_match_char (',') != MATCH_YES
)
968 m
= gfc_match_iterator (&iter
, 0);
971 if (m
== MATCH_ERROR
)
974 m
= match_array_cons_element (&head
);
975 if (m
== MATCH_ERROR
)
982 goto cleanup
; /* Could be a complex constant */
985 if (gfc_match_char (',') != MATCH_YES
)
994 if (gfc_match_char (')') != MATCH_YES
)
997 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1003 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1004 e
->value
.constructor
= head
;
1006 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1007 p
->iterator
= gfc_get_iterator ();
1008 *p
->iterator
= iter
;
1013 gfc_error ("Syntax error in array constructor at %C");
1017 gfc_constructor_free (head
);
1018 gfc_free_iterator (&iter
, 0);
1019 gfc_current_locus
= old_loc
;
1024 /* Match a single element of an array constructor, which can be a
1025 single expression or a list of elements. */
1028 match_array_cons_element (gfc_constructor_base
*result
)
1033 m
= match_array_list (result
);
1037 m
= gfc_match_expr (&expr
);
1041 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1046 /* Match an array constructor. */
1049 gfc_match_array_constructor (gfc_expr
**result
)
1051 gfc_constructor_base head
, new_cons
;
1052 gfc_undo_change_set changed_syms
;
1057 const char *end_delim
;
1060 if (gfc_match (" (/") == MATCH_NO
)
1062 if (gfc_match (" [") == MATCH_NO
)
1066 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1067 "style array constructors at %C"))
1075 where
= gfc_current_locus
;
1076 head
= new_cons
= NULL
;
1079 /* Try to match an optional "type-spec ::" */
1081 gfc_new_undo_checkpoint (changed_syms
);
1082 if (gfc_match_type_spec (&ts
) == MATCH_YES
)
1084 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1088 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1089 "including type specification at %C"))
1091 gfc_restore_last_undo_checkpoint ();
1097 gfc_error ("Type-spec at %L cannot contain a deferred "
1098 "type parameter", &where
);
1099 gfc_restore_last_undo_checkpoint ();
1106 gfc_drop_last_undo_checkpoint ();
1109 gfc_restore_last_undo_checkpoint ();
1110 gfc_current_locus
= where
;
1113 if (gfc_match (end_delim
) == MATCH_YES
)
1119 gfc_error ("Empty array constructor at %C is not allowed");
1126 m
= match_array_cons_element (&head
);
1127 if (m
== MATCH_ERROR
)
1132 if (gfc_match_char (',') == MATCH_NO
)
1136 if (gfc_match (end_delim
) == MATCH_NO
)
1140 /* Size must be calculated at resolution time. */
1143 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1147 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1149 expr
->value
.constructor
= head
;
1151 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1157 gfc_error ("Syntax error in array constructor at %C");
1160 gfc_constructor_free (head
);
1166 /************** Check array constructors for correctness **************/
1168 /* Given an expression, compare it's type with the type of the current
1169 constructor. Returns nonzero if an error was issued. The
1170 cons_state variable keeps track of whether the type of the
1171 constructor being read or resolved is known to be good, bad or just
1174 static gfc_typespec constructor_ts
;
1176 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1180 check_element_type (gfc_expr
*expr
, bool convert
)
1182 if (cons_state
== CONS_BAD
)
1183 return 0; /* Suppress further errors */
1185 if (cons_state
== CONS_START
)
1187 if (expr
->ts
.type
== BT_UNKNOWN
)
1188 cons_state
= CONS_BAD
;
1191 cons_state
= CONS_GOOD
;
1192 constructor_ts
= expr
->ts
;
1198 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1202 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1204 gfc_error ("Element in %s array constructor at %L is %s",
1205 gfc_typename (&constructor_ts
), &expr
->where
,
1206 gfc_typename (&expr
->ts
));
1208 cons_state
= CONS_BAD
;
1213 /* Recursive work function for gfc_check_constructor_type(). */
1216 check_constructor_type (gfc_constructor_base base
, bool convert
)
1221 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1225 if (e
->expr_type
== EXPR_ARRAY
)
1227 if (!check_constructor_type (e
->value
.constructor
, convert
))
1233 if (check_element_type (e
, convert
))
1241 /* Check that all elements of an array constructor are the same type.
1242 On false, an error has been generated. */
1245 gfc_check_constructor_type (gfc_expr
*e
)
1249 if (e
->ts
.type
!= BT_UNKNOWN
)
1251 cons_state
= CONS_GOOD
;
1252 constructor_ts
= e
->ts
;
1256 cons_state
= CONS_START
;
1257 gfc_clear_ts (&constructor_ts
);
1260 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1261 typespec, and we will now convert the values on the fly. */
1262 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1263 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1264 e
->ts
= constructor_ts
;
1271 typedef struct cons_stack
1273 gfc_iterator
*iterator
;
1274 struct cons_stack
*previous
;
1278 static cons_stack
*base
;
1280 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1282 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1283 that that variable is an iteration variables. */
1286 gfc_check_iter_variable (gfc_expr
*expr
)
1291 sym
= expr
->symtree
->n
.sym
;
1293 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1294 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1301 /* Recursive work function for gfc_check_constructor(). This amounts
1302 to calling the check function for each expression in the
1303 constructor, giving variables with the names of iterators a pass. */
1306 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1313 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1320 if (e
->expr_type
!= EXPR_ARRAY
)
1322 if (!(*check_function
)(e
))
1327 element
.previous
= base
;
1328 element
.iterator
= c
->iterator
;
1331 t
= check_constructor (e
->value
.constructor
, check_function
);
1332 base
= element
.previous
;
1338 /* Nothing went wrong, so all OK. */
1343 /* Checks a constructor to see if it is a particular kind of
1344 expression -- specification, restricted, or initialization as
1345 determined by the check_function. */
1348 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1350 cons_stack
*base_save
;
1356 t
= check_constructor (expr
->value
.constructor
, check_function
);
1364 /**************** Simplification of array constructors ****************/
1366 iterator_stack
*iter_stack
;
1370 gfc_constructor_base base
;
1371 int extract_count
, extract_n
;
1372 gfc_expr
*extracted
;
1376 gfc_component
*component
;
1379 bool (*expand_work_function
) (gfc_expr
*);
1383 static expand_info current_expand
;
1385 static bool expand_constructor (gfc_constructor_base
);
1388 /* Work function that counts the number of elements present in a
1392 count_elements (gfc_expr
*e
)
1397 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1400 if (!gfc_array_size (e
, &result
))
1406 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1415 /* Work function that extracts a particular element from an array
1416 constructor, freeing the rest. */
1419 extract_element (gfc_expr
*e
)
1422 { /* Something unextractable */
1427 if (current_expand
.extract_count
== current_expand
.extract_n
)
1428 current_expand
.extracted
= e
;
1432 current_expand
.extract_count
++;
1438 /* Work function that constructs a new constructor out of the old one,
1439 stringing new elements together. */
1442 expand (gfc_expr
*e
)
1444 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1447 c
->n
.component
= current_expand
.component
;
1452 /* Given an initialization expression that is a variable reference,
1453 substitute the current value of the iteration variable. */
1456 gfc_simplify_iterator_var (gfc_expr
*e
)
1460 for (p
= iter_stack
; p
; p
= p
->prev
)
1461 if (e
->symtree
== p
->variable
)
1465 return; /* Variable not found */
1467 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1469 mpz_set (e
->value
.integer
, p
->value
);
1475 /* Expand an expression with that is inside of a constructor,
1476 recursing into other constructors if present. */
1479 expand_expr (gfc_expr
*e
)
1481 if (e
->expr_type
== EXPR_ARRAY
)
1482 return expand_constructor (e
->value
.constructor
);
1484 e
= gfc_copy_expr (e
);
1486 if (!gfc_simplify_expr (e
, 1))
1492 return current_expand
.expand_work_function (e
);
1497 expand_iterator (gfc_constructor
*c
)
1499 gfc_expr
*start
, *end
, *step
;
1500 iterator_stack frame
;
1509 mpz_init (frame
.value
);
1512 start
= gfc_copy_expr (c
->iterator
->start
);
1513 if (!gfc_simplify_expr (start
, 1))
1516 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1519 end
= gfc_copy_expr (c
->iterator
->end
);
1520 if (!gfc_simplify_expr (end
, 1))
1523 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1526 step
= gfc_copy_expr (c
->iterator
->step
);
1527 if (!gfc_simplify_expr (step
, 1))
1530 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1533 if (mpz_sgn (step
->value
.integer
) == 0)
1535 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1539 /* Calculate the trip count of the loop. */
1540 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1541 mpz_add (trip
, trip
, step
->value
.integer
);
1542 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1544 mpz_set (frame
.value
, start
->value
.integer
);
1546 frame
.prev
= iter_stack
;
1547 frame
.variable
= c
->iterator
->var
->symtree
;
1548 iter_stack
= &frame
;
1550 while (mpz_sgn (trip
) > 0)
1552 if (!expand_expr (c
->expr
))
1555 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1556 mpz_sub_ui (trip
, trip
, 1);
1562 gfc_free_expr (start
);
1563 gfc_free_expr (end
);
1564 gfc_free_expr (step
);
1567 mpz_clear (frame
.value
);
1569 iter_stack
= frame
.prev
;
1575 /* Expand a constructor into constant constructors without any
1576 iterators, calling the work function for each of the expanded
1577 expressions. The work function needs to either save or free the
1578 passed expression. */
1581 expand_constructor (gfc_constructor_base base
)
1586 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1588 if (c
->iterator
!= NULL
)
1590 if (!expand_iterator (c
))
1597 if (e
->expr_type
== EXPR_ARRAY
)
1599 if (!expand_constructor (e
->value
.constructor
))
1605 e
= gfc_copy_expr (e
);
1606 if (!gfc_simplify_expr (e
, 1))
1611 current_expand
.offset
= &c
->offset
;
1612 current_expand
.repeat
= &c
->repeat
;
1613 current_expand
.component
= c
->n
.component
;
1614 if (!current_expand
.expand_work_function(e
))
1621 /* Given an array expression and an element number (starting at zero),
1622 return a pointer to the array element. NULL is returned if the
1623 size of the array has been exceeded. The expression node returned
1624 remains a part of the array and should not be freed. Access is not
1625 efficient at all, but this is another place where things do not
1626 have to be particularly fast. */
1629 gfc_get_array_element (gfc_expr
*array
, int element
)
1631 expand_info expand_save
;
1635 expand_save
= current_expand
;
1636 current_expand
.extract_n
= element
;
1637 current_expand
.expand_work_function
= extract_element
;
1638 current_expand
.extracted
= NULL
;
1639 current_expand
.extract_count
= 0;
1643 rc
= expand_constructor (array
->value
.constructor
);
1644 e
= current_expand
.extracted
;
1645 current_expand
= expand_save
;
1654 /* Top level subroutine for expanding constructors. We only expand
1655 constructor if they are small enough. */
1658 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1660 expand_info expand_save
;
1664 /* If we can successfully get an array element at the max array size then
1665 the array is too big to expand, so we just return. */
1666 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1672 gfc_error ("The number of elements in the array constructor "
1673 "at %L requires an increase of the allowed %d "
1674 "upper limit. See %<-fmax-array-constructor%> "
1675 "option", &e
->where
, flag_max_array_constructor
);
1681 /* We now know the array is not too big so go ahead and try to expand it. */
1682 expand_save
= current_expand
;
1683 current_expand
.base
= NULL
;
1687 current_expand
.expand_work_function
= expand
;
1689 if (!expand_constructor (e
->value
.constructor
))
1691 gfc_constructor_free (current_expand
.base
);
1696 gfc_constructor_free (e
->value
.constructor
);
1697 e
->value
.constructor
= current_expand
.base
;
1702 current_expand
= expand_save
;
1708 /* Work function for checking that an element of a constructor is a
1709 constant, after removal of any iteration variables. We return
1713 is_constant_element (gfc_expr
*e
)
1717 rv
= gfc_is_constant_expr (e
);
1720 return rv
? true : false;
1724 /* Given an array constructor, determine if the constructor is
1725 constant or not by expanding it and making sure that all elements
1726 are constants. This is a bit of a hack since something like (/ (i,
1727 i=1,100000000) /) will take a while as* opposed to a more clever
1728 function that traverses the expression tree. FIXME. */
1731 gfc_constant_ac (gfc_expr
*e
)
1733 expand_info expand_save
;
1737 expand_save
= current_expand
;
1738 current_expand
.expand_work_function
= is_constant_element
;
1740 rc
= expand_constructor (e
->value
.constructor
);
1742 current_expand
= expand_save
;
1750 /* Returns nonzero if an array constructor has been completely
1751 expanded (no iterators) and zero if iterators are present. */
1754 gfc_expanded_ac (gfc_expr
*e
)
1758 if (e
->expr_type
== EXPR_ARRAY
)
1759 for (c
= gfc_constructor_first (e
->value
.constructor
);
1760 c
; c
= gfc_constructor_next (c
))
1761 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1768 /*************** Type resolution of array constructors ***************/
1771 /* The symbol expr_is_sought_symbol_ref will try to find. */
1772 static const gfc_symbol
*sought_symbol
= NULL
;
1775 /* Tells whether the expression E is a variable reference to the symbol
1776 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1778 To be used with gfc_expr_walker: if a reference is found we don't need
1779 to look further so we return 1 to skip any further walk. */
1782 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1785 gfc_expr
*expr
= *e
;
1786 locus
*sym_loc
= (locus
*)where
;
1788 if (expr
->expr_type
== EXPR_VARIABLE
1789 && expr
->symtree
->n
.sym
== sought_symbol
)
1791 *sym_loc
= expr
->where
;
1799 /* Tells whether the expression EXPR contains a reference to the symbol
1800 SYM and in that case sets the position SYM_LOC where the reference is. */
1803 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1807 sought_symbol
= sym
;
1808 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1809 sought_symbol
= NULL
;
1814 /* Recursive array list resolution function. All of the elements must
1815 be of the same type. */
1818 resolve_array_list (gfc_constructor_base base
)
1826 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1831 gfc_symbol
*iter_var
;
1834 if (!gfc_resolve_iterator (iter
, false, true))
1837 /* Check for bounds referencing the iterator variable. */
1838 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1839 iter_var
= iter
->var
->symtree
->n
.sym
;
1840 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1842 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1843 "expression references control variable "
1844 "at %L", &iter_var_loc
))
1847 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1849 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1850 "expression references control variable "
1851 "at %L", &iter_var_loc
))
1854 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1856 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1857 "expression references control variable "
1858 "at %L", &iter_var_loc
))
1863 if (!gfc_resolve_expr (c
->expr
))
1866 if (UNLIMITED_POLY (c
->expr
))
1868 gfc_error ("Array constructor value at %L shall not be unlimited "
1869 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1877 /* Resolve character array constructor. If it has a specified constant character
1878 length, pad/truncate the elements here; if the length is not specified and
1879 all elements are of compile-time known length, emit an error as this is
1883 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1888 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1889 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1891 if (expr
->ts
.u
.cl
== NULL
)
1893 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1894 p
; p
= gfc_constructor_next (p
))
1895 if (p
->expr
->ts
.u
.cl
!= NULL
)
1897 /* Ensure that if there is a char_len around that it is
1898 used; otherwise the middle-end confuses them! */
1899 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1903 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1910 if (expr
->ts
.u
.cl
->length
== NULL
)
1912 /* Check that all constant string elements have the same length until
1913 we reach the end or find a variable-length one. */
1915 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1916 p
; p
= gfc_constructor_next (p
))
1918 int current_length
= -1;
1920 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1921 if (ref
->type
== REF_SUBSTRING
1922 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1923 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1926 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1927 current_length
= p
->expr
->value
.character
.length
;
1931 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1932 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1933 current_length
= (int) j
;
1935 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1936 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1939 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
1940 current_length
= (int) j
;
1945 gcc_assert (current_length
!= -1);
1947 if (found_length
== -1)
1948 found_length
= current_length
;
1949 else if (found_length
!= current_length
)
1951 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1952 " constructor at %L", found_length
, current_length
,
1957 gcc_assert (found_length
== current_length
);
1960 gcc_assert (found_length
!= -1);
1962 /* Update the character length of the array constructor. */
1963 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1964 NULL
, found_length
);
1968 /* We've got a character length specified. It should be an integer,
1969 otherwise an error is signalled elsewhere. */
1970 gcc_assert (expr
->ts
.u
.cl
->length
);
1972 /* If we've got a constant character length, pad according to this.
1973 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1974 max_length only if they pass. */
1975 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
1977 /* Now pad/truncate the elements accordingly to the specified character
1978 length. This is ok inside this conditional, as in the case above
1979 (without typespec) all elements are verified to have the same length
1981 if (found_length
!= -1)
1982 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1983 p
; p
= gfc_constructor_next (p
))
1984 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1986 gfc_expr
*cl
= NULL
;
1987 int current_length
= -1;
1990 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
1992 cl
= p
->expr
->ts
.u
.cl
->length
;
1993 gfc_extract_int (cl
, ¤t_length
);
1996 /* If gfc_extract_int above set current_length, we implicitly
1997 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
1999 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2002 || (current_length
!= -1 && current_length
!= found_length
))
2003 gfc_set_constant_character_len (found_length
, p
->expr
,
2004 has_ts
? -1 : found_length
);
2012 /* Resolve all of the expressions in an array list. */
2015 gfc_resolve_array_constructor (gfc_expr
*expr
)
2019 t
= resolve_array_list (expr
->value
.constructor
);
2021 t
= gfc_check_constructor_type (expr
);
2023 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2024 the call to this function, so we don't need to call it here; if it was
2025 called twice, an error message there would be duplicated. */
2031 /* Copy an iterator structure. */
2034 gfc_copy_iterator (gfc_iterator
*src
)
2041 dest
= gfc_get_iterator ();
2043 dest
->var
= gfc_copy_expr (src
->var
);
2044 dest
->start
= gfc_copy_expr (src
->start
);
2045 dest
->end
= gfc_copy_expr (src
->end
);
2046 dest
->step
= gfc_copy_expr (src
->step
);
2052 /********* Subroutines for determining the size of an array *********/
2054 /* These are needed just to accommodate RESHAPE(). There are no
2055 diagnostics here, we just return a negative number if something
2059 /* Get the size of single dimension of an array specification. The
2060 array is guaranteed to be one dimensional. */
2063 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2068 if (dimen
< 0 || dimen
> as
->rank
- 1)
2069 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2071 if (as
->type
!= AS_EXPLICIT
2072 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2073 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2074 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2075 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2080 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2081 as
->lower
[dimen
]->value
.integer
);
2083 mpz_add_ui (*result
, *result
, 1);
2090 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2095 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2098 mpz_init_set_ui (*result
, 1);
2100 for (d
= 0; d
< as
->rank
; d
++)
2102 if (!spec_dimen_size (as
, d
, &size
))
2104 mpz_clear (*result
);
2108 mpz_mul (*result
, *result
, size
);
2116 /* Get the number of elements in an array section. Optionally, also supply
2120 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2122 mpz_t upper
, lower
, stride
;
2126 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2127 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2129 switch (ar
->dimen_type
[dimen
])
2133 mpz_set_ui (*result
, 1);
2138 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2145 if (ar
->stride
[dimen
] == NULL
)
2146 mpz_set_ui (stride
, 1);
2149 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2154 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2157 /* Calculate the number of elements via gfc_dep_differce, but only if
2158 start and end are both supplied in the reference or the array spec.
2159 This is to guard against strange but valid code like
2164 print *,size(a(n-1:))
2166 where the user changes the value of a variable. If we have to
2167 determine end as well, we cannot do this using gfc_dep_difference.
2168 Fall back to the constants-only code then. */
2174 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2176 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2177 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2178 ar
->as
->lower
[dimen
], &diff
);
2183 mpz_add (*result
, diff
, stride
);
2184 mpz_div (*result
, *result
, stride
);
2185 if (mpz_cmp_ui (*result
, 0) < 0)
2186 mpz_set_ui (*result
, 0);
2195 /* Constant-only code here, which covers more cases
2201 if (ar
->start
[dimen
] == NULL
)
2203 if (ar
->as
->lower
[dimen
] == NULL
2204 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2206 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2210 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2212 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2215 if (ar
->end
[dimen
] == NULL
)
2217 if (ar
->as
->upper
[dimen
] == NULL
2218 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2220 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2224 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2226 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2230 mpz_sub (*result
, upper
, lower
);
2231 mpz_add (*result
, *result
, stride
);
2232 mpz_div (*result
, *result
, stride
);
2234 /* Zero stride caught earlier. */
2235 if (mpz_cmp_ui (*result
, 0) < 0)
2236 mpz_set_ui (*result
, 0);
2243 mpz_sub_ui (*end
, *result
, 1UL);
2244 mpz_mul (*end
, *end
, stride
);
2245 mpz_add (*end
, *end
, lower
);
2255 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2263 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2268 mpz_init_set_ui (*result
, 1);
2270 for (d
= 0; d
< ar
->dimen
; d
++)
2272 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2274 mpz_clear (*result
);
2278 mpz_mul (*result
, *result
, size
);
2286 /* Given an array expression and a dimension, figure out how many
2287 elements it has along that dimension. Returns true if we were
2288 able to return a result in the 'result' variable, false
2292 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2297 gcc_assert (array
!= NULL
);
2299 if (array
->ts
.type
== BT_CLASS
)
2302 if (array
->rank
== -1)
2305 if (dimen
< 0 || dimen
> array
->rank
- 1)
2306 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2308 switch (array
->expr_type
)
2312 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2314 if (ref
->type
!= REF_ARRAY
)
2317 if (ref
->u
.ar
.type
== AR_FULL
)
2318 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2320 if (ref
->u
.ar
.type
== AR_SECTION
)
2322 for (i
= 0; dimen
>= 0; i
++)
2323 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2326 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2330 if (array
->shape
&& array
->shape
[dimen
])
2332 mpz_init_set (*result
, array
->shape
[dimen
]);
2336 if (array
->symtree
->n
.sym
->attr
.generic
2337 && array
->value
.function
.esym
!= NULL
)
2339 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2342 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2348 if (array
->shape
== NULL
) {
2349 /* Expressions with rank > 1 should have "shape" properly set */
2350 if ( array
->rank
!= 1 )
2351 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2352 return gfc_array_size(array
, result
);
2357 if (array
->shape
== NULL
)
2360 mpz_init_set (*result
, array
->shape
[dimen
]);
2369 /* Given an array expression, figure out how many elements are in the
2370 array. Returns true if this is possible, and sets the 'result'
2371 variable. Otherwise returns false. */
2374 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2376 expand_info expand_save
;
2381 if (array
->ts
.type
== BT_CLASS
)
2384 switch (array
->expr_type
)
2387 gfc_push_suppress_errors ();
2389 expand_save
= current_expand
;
2391 current_expand
.count
= result
;
2392 mpz_init_set_ui (*result
, 0);
2394 current_expand
.expand_work_function
= count_elements
;
2397 t
= expand_constructor (array
->value
.constructor
);
2399 gfc_pop_suppress_errors ();
2402 mpz_clear (*result
);
2403 current_expand
= expand_save
;
2407 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2409 if (ref
->type
!= REF_ARRAY
)
2412 if (ref
->u
.ar
.type
== AR_FULL
)
2413 return spec_size (ref
->u
.ar
.as
, result
);
2415 if (ref
->u
.ar
.type
== AR_SECTION
)
2416 return ref_size (&ref
->u
.ar
, result
);
2419 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2423 if (array
->rank
== 0 || array
->shape
== NULL
)
2426 mpz_init_set_ui (*result
, 1);
2428 for (i
= 0; i
< array
->rank
; i
++)
2429 mpz_mul (*result
, *result
, array
->shape
[i
]);
2438 /* Given an array reference, return the shape of the reference in an
2439 array of mpz_t integers. */
2442 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2452 for (; d
< ar
->as
->rank
; d
++)
2453 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2459 for (i
= 0; i
< ar
->dimen
; i
++)
2461 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2463 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2476 gfc_clear_shape (shape
, d
);
2481 /* Given an array expression, find the array reference structure that
2482 characterizes the reference. */
2485 gfc_find_array_ref (gfc_expr
*e
)
2489 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2490 if (ref
->type
== REF_ARRAY
2491 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2495 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2501 /* Find out if an array shape is known at compile time. */
2504 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2508 if (as
->type
!= AS_EXPLICIT
)
2511 for (i
= 0; i
< as
->rank
; i
++)
2512 if (!gfc_is_constant_expr (as
->lower
[i
])
2513 || !gfc_is_constant_expr (as
->upper
[i
]))