2 Copyright (C) 2000-2016 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 particular
150 elements or a section. If init is set, the reference has to consist
151 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 (((*upper
)->expr_type
== EXPR_CONSTANT
425 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
426 ((*upper
)->expr_type
== EXPR_FUNCTION
427 && (*upper
)->ts
.type
== BT_UNKNOWN
429 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
431 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
432 gfc_basic_typename ((*upper
)->ts
.type
));
436 if (gfc_match_char (':') == MATCH_NO
)
438 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
445 if (gfc_match_char ('*') == MATCH_YES
)
446 return AS_ASSUMED_SIZE
;
448 m
= gfc_match_expr (upper
);
449 if (m
== MATCH_ERROR
)
452 return AS_ASSUMED_SHAPE
;
453 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
456 if (((*upper
)->expr_type
== EXPR_CONSTANT
457 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
458 ((*upper
)->expr_type
== EXPR_FUNCTION
459 && (*upper
)->ts
.type
== BT_UNKNOWN
461 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
463 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
464 gfc_basic_typename ((*upper
)->ts
.type
));
472 /* Matches an array specification, incidentally figuring out what sort
473 it is. Match either a normal array specification, or a coarray spec
474 or both. Optionally allow [:] for coarrays. */
477 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
479 array_type current_type
;
483 as
= gfc_get_array_spec ();
488 if (gfc_match_char ('(') != MATCH_YES
)
495 if (gfc_match (" .. )") == MATCH_YES
)
497 as
->type
= AS_ASSUMED_RANK
;
500 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C"))
511 current_type
= match_array_element_spec (as
);
513 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
514 and implied-shape specifications. If the rank is at least 2, we can
515 distinguish between them. But for rank 1, we currently return
516 ASSUMED_SIZE; this gets adjusted later when we know for sure
517 whether the symbol parsed is a PARAMETER or not. */
521 if (current_type
== AS_UNKNOWN
)
523 as
->type
= current_type
;
527 { /* See how current spec meshes with the existing. */
531 case AS_IMPLIED_SHAPE
:
532 if (current_type
!= AS_ASSUMED_SHAPE
)
534 gfc_error ("Bad array specification for implied-shape"
541 if (current_type
== AS_ASSUMED_SIZE
)
543 as
->type
= AS_ASSUMED_SIZE
;
547 if (current_type
== AS_EXPLICIT
)
550 gfc_error ("Bad array specification for an explicitly shaped "
555 case AS_ASSUMED_SHAPE
:
556 if ((current_type
== AS_ASSUMED_SHAPE
)
557 || (current_type
== AS_DEFERRED
))
560 gfc_error ("Bad array specification for assumed shape "
565 if (current_type
== AS_DEFERRED
)
568 if (current_type
== AS_ASSUMED_SHAPE
)
570 as
->type
= AS_ASSUMED_SHAPE
;
574 gfc_error ("Bad specification for deferred shape array at %C");
577 case AS_ASSUMED_SIZE
:
578 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
580 as
->type
= AS_IMPLIED_SHAPE
;
584 gfc_error ("Bad specification for assumed size array at %C");
587 case AS_ASSUMED_RANK
:
591 if (gfc_match_char (')') == MATCH_YES
)
594 if (gfc_match_char (',') != MATCH_YES
)
596 gfc_error ("Expected another dimension in array declaration at %C");
600 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
602 gfc_error ("Array specification at %C has more than %d dimensions",
607 if (as
->corank
+ as
->rank
>= 7
608 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
609 "with more than 7 dimensions"))
617 if (gfc_match_char ('[') != MATCH_YES
)
620 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
623 if (flag_coarray
== GFC_FCOARRAY_NONE
)
625 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
629 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
631 gfc_error ("Array specification at %C has more than %d "
632 "dimensions", GFC_MAX_DIMENSIONS
);
639 current_type
= match_array_element_spec (as
);
641 if (current_type
== AS_UNKNOWN
)
645 as
->cotype
= current_type
;
648 { /* See how current spec meshes with the existing. */
649 case AS_IMPLIED_SHAPE
:
654 if (current_type
== AS_ASSUMED_SIZE
)
656 as
->cotype
= AS_ASSUMED_SIZE
;
660 if (current_type
== AS_EXPLICIT
)
663 gfc_error ("Bad array specification for an explicitly "
664 "shaped array at %C");
668 case AS_ASSUMED_SHAPE
:
669 if ((current_type
== AS_ASSUMED_SHAPE
)
670 || (current_type
== AS_DEFERRED
))
673 gfc_error ("Bad array specification for assumed shape "
678 if (current_type
== AS_DEFERRED
)
681 if (current_type
== AS_ASSUMED_SHAPE
)
683 as
->cotype
= AS_ASSUMED_SHAPE
;
687 gfc_error ("Bad specification for deferred shape array at %C");
690 case AS_ASSUMED_SIZE
:
691 gfc_error ("Bad specification for assumed size array at %C");
694 case AS_ASSUMED_RANK
:
698 if (gfc_match_char (']') == MATCH_YES
)
701 if (gfc_match_char (',') != MATCH_YES
)
703 gfc_error ("Expected another dimension in array declaration at %C");
707 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
709 gfc_error ("Array specification at %C has more than %d "
710 "dimensions", GFC_MAX_DIMENSIONS
);
715 if (current_type
== AS_EXPLICIT
)
717 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
721 if (as
->cotype
== AS_ASSUMED_SIZE
)
722 as
->cotype
= AS_EXPLICIT
;
725 as
->type
= as
->cotype
;
728 if (as
->rank
== 0 && as
->corank
== 0)
731 gfc_free_array_spec (as
);
735 /* If a lower bounds of an assumed shape array is blank, put in one. */
736 if (as
->type
== AS_ASSUMED_SHAPE
)
738 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
740 if (as
->lower
[i
] == NULL
)
741 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
750 /* Something went wrong. */
751 gfc_free_array_spec (as
);
756 /* Given a symbol and an array specification, modify the symbol to
757 have that array specification. The error locus is needed in case
758 something goes wrong. On failure, the caller must free the spec. */
761 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
769 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
773 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
782 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
783 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
785 gfc_error ("The assumed-rank array %qs at %L shall not have a "
786 "codimension", sym
->name
, error_loc
);
792 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
793 the codimension is simply added. */
794 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
796 sym
->as
->cotype
= as
->cotype
;
797 sym
->as
->corank
= as
->corank
;
798 for (i
= 0; i
< as
->corank
; i
++)
800 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
801 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
806 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
807 the dimension is added - but first the codimensions (if existing
808 need to be shifted to make space for the dimension. */
809 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
811 sym
->as
->rank
= as
->rank
;
812 sym
->as
->type
= as
->type
;
813 sym
->as
->cray_pointee
= as
->cray_pointee
;
814 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
816 for (i
= 0; i
< sym
->as
->corank
; i
++)
818 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
819 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
821 for (i
= 0; i
< as
->rank
; i
++)
823 sym
->as
->lower
[i
] = as
->lower
[i
];
824 sym
->as
->upper
[i
] = as
->upper
[i
];
833 /* Copy an array specification. */
836 gfc_copy_array_spec (gfc_array_spec
*src
)
838 gfc_array_spec
*dest
;
844 dest
= gfc_get_array_spec ();
848 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
850 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
851 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
858 /* Returns nonzero if the two expressions are equal. Only handles integer
862 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
864 if (bound1
== NULL
|| bound2
== NULL
865 || bound1
->expr_type
!= EXPR_CONSTANT
866 || bound2
->expr_type
!= EXPR_CONSTANT
867 || bound1
->ts
.type
!= BT_INTEGER
868 || bound2
->ts
.type
!= BT_INTEGER
)
869 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
871 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
878 /* Compares two array specifications. They must be constant or deferred
882 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
886 if (as1
== NULL
&& as2
== NULL
)
889 if (as1
== NULL
|| as2
== NULL
)
892 if (as1
->rank
!= as2
->rank
)
895 if (as1
->corank
!= as2
->corank
)
901 if (as1
->type
!= as2
->type
)
904 if (as1
->type
== AS_EXPLICIT
)
905 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
907 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
910 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
918 /****************** Array constructor functions ******************/
921 /* Given an expression node that might be an array constructor and a
922 symbol, make sure that no iterators in this or child constructors
923 use the symbol as an implied-DO iterator. Returns nonzero if a
924 duplicate was found. */
927 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
932 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
936 if (e
->expr_type
== EXPR_ARRAY
937 && check_duplicate_iterator (e
->value
.constructor
, master
))
940 if (c
->iterator
== NULL
)
943 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
945 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
946 "same name", master
->name
, &c
->where
);
956 /* Forward declaration because these functions are mutually recursive. */
957 static match
match_array_cons_element (gfc_constructor_base
*);
959 /* Match a list of array elements. */
962 match_array_list (gfc_constructor_base
*result
)
964 gfc_constructor_base head
;
972 old_loc
= gfc_current_locus
;
974 if (gfc_match_char ('(') == MATCH_NO
)
977 memset (&iter
, '\0', sizeof (gfc_iterator
));
980 m
= match_array_cons_element (&head
);
984 if (gfc_match_char (',') != MATCH_YES
)
992 m
= gfc_match_iterator (&iter
, 0);
995 if (m
== MATCH_ERROR
)
998 m
= match_array_cons_element (&head
);
999 if (m
== MATCH_ERROR
)
1006 goto cleanup
; /* Could be a complex constant */
1009 if (gfc_match_char (',') != MATCH_YES
)
1018 if (gfc_match_char (')') != MATCH_YES
)
1021 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1027 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1028 e
->value
.constructor
= head
;
1030 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1031 p
->iterator
= gfc_get_iterator ();
1032 *p
->iterator
= iter
;
1037 gfc_error ("Syntax error in array constructor at %C");
1041 gfc_constructor_free (head
);
1042 gfc_free_iterator (&iter
, 0);
1043 gfc_current_locus
= old_loc
;
1048 /* Match a single element of an array constructor, which can be a
1049 single expression or a list of elements. */
1052 match_array_cons_element (gfc_constructor_base
*result
)
1057 m
= match_array_list (result
);
1061 m
= gfc_match_expr (&expr
);
1065 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1070 /* Match an array constructor. */
1073 gfc_match_array_constructor (gfc_expr
**result
)
1075 gfc_constructor_base head
, new_cons
;
1076 gfc_undo_change_set changed_syms
;
1081 const char *end_delim
;
1084 if (gfc_match (" (/") == MATCH_NO
)
1086 if (gfc_match (" [") == MATCH_NO
)
1090 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1091 "style array constructors at %C"))
1099 where
= gfc_current_locus
;
1100 head
= new_cons
= NULL
;
1103 /* Try to match an optional "type-spec ::" */
1105 gfc_new_undo_checkpoint (changed_syms
);
1106 m
= gfc_match_type_spec (&ts
);
1109 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1113 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1114 "including type specification at %C"))
1116 gfc_restore_last_undo_checkpoint ();
1122 gfc_error ("Type-spec at %L cannot contain a deferred "
1123 "type parameter", &where
);
1124 gfc_restore_last_undo_checkpoint ();
1129 else if (m
== MATCH_ERROR
)
1131 gfc_restore_last_undo_checkpoint ();
1136 gfc_drop_last_undo_checkpoint ();
1139 gfc_restore_last_undo_checkpoint ();
1140 gfc_current_locus
= where
;
1143 if (gfc_match (end_delim
) == MATCH_YES
)
1149 gfc_error ("Empty array constructor at %C is not allowed");
1156 m
= match_array_cons_element (&head
);
1157 if (m
== MATCH_ERROR
)
1162 if (gfc_match_char (',') == MATCH_NO
)
1166 if (gfc_match (end_delim
) == MATCH_NO
)
1170 /* Size must be calculated at resolution time. */
1173 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1176 /* If the typespec is CHARACTER, check that array elements can
1177 be converted. See PR fortran/67803. */
1178 if (ts
.type
== BT_CHARACTER
)
1182 c
= gfc_constructor_first (head
);
1183 for (; c
; c
= gfc_constructor_next (c
))
1185 if (gfc_numeric_ts (&c
->expr
->ts
)
1186 || c
->expr
->ts
.type
== BT_LOGICAL
)
1188 gfc_error ("Incompatible typespec for array element at %L",
1193 /* Special case null(). */
1194 if (c
->expr
->expr_type
== EXPR_FUNCTION
1195 && c
->expr
->ts
.type
== BT_UNKNOWN
1196 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1198 gfc_error ("Incompatible typespec for array element at %L",
1206 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1208 expr
->value
.constructor
= head
;
1210 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1217 gfc_error ("Syntax error in array constructor at %C");
1220 gfc_constructor_free (head
);
1226 /************** Check array constructors for correctness **************/
1228 /* Given an expression, compare it's type with the type of the current
1229 constructor. Returns nonzero if an error was issued. The
1230 cons_state variable keeps track of whether the type of the
1231 constructor being read or resolved is known to be good, bad or just
1234 static gfc_typespec constructor_ts
;
1236 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1240 check_element_type (gfc_expr
*expr
, bool convert
)
1242 if (cons_state
== CONS_BAD
)
1243 return 0; /* Suppress further errors */
1245 if (cons_state
== CONS_START
)
1247 if (expr
->ts
.type
== BT_UNKNOWN
)
1248 cons_state
= CONS_BAD
;
1251 cons_state
= CONS_GOOD
;
1252 constructor_ts
= expr
->ts
;
1258 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1262 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1264 gfc_error ("Element in %s array constructor at %L is %s",
1265 gfc_typename (&constructor_ts
), &expr
->where
,
1266 gfc_typename (&expr
->ts
));
1268 cons_state
= CONS_BAD
;
1273 /* Recursive work function for gfc_check_constructor_type(). */
1276 check_constructor_type (gfc_constructor_base base
, bool convert
)
1281 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1285 if (e
->expr_type
== EXPR_ARRAY
)
1287 if (!check_constructor_type (e
->value
.constructor
, convert
))
1293 if (check_element_type (e
, convert
))
1301 /* Check that all elements of an array constructor are the same type.
1302 On false, an error has been generated. */
1305 gfc_check_constructor_type (gfc_expr
*e
)
1309 if (e
->ts
.type
!= BT_UNKNOWN
)
1311 cons_state
= CONS_GOOD
;
1312 constructor_ts
= e
->ts
;
1316 cons_state
= CONS_START
;
1317 gfc_clear_ts (&constructor_ts
);
1320 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1321 typespec, and we will now convert the values on the fly. */
1322 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1323 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1324 e
->ts
= constructor_ts
;
1331 typedef struct cons_stack
1333 gfc_iterator
*iterator
;
1334 struct cons_stack
*previous
;
1338 static cons_stack
*base
;
1340 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1342 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1343 that that variable is an iteration variables. */
1346 gfc_check_iter_variable (gfc_expr
*expr
)
1351 sym
= expr
->symtree
->n
.sym
;
1353 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1354 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1361 /* Recursive work function for gfc_check_constructor(). This amounts
1362 to calling the check function for each expression in the
1363 constructor, giving variables with the names of iterators a pass. */
1366 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1373 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1380 if (e
->expr_type
!= EXPR_ARRAY
)
1382 if (!(*check_function
)(e
))
1387 element
.previous
= base
;
1388 element
.iterator
= c
->iterator
;
1391 t
= check_constructor (e
->value
.constructor
, check_function
);
1392 base
= element
.previous
;
1398 /* Nothing went wrong, so all OK. */
1403 /* Checks a constructor to see if it is a particular kind of
1404 expression -- specification, restricted, or initialization as
1405 determined by the check_function. */
1408 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1410 cons_stack
*base_save
;
1416 t
= check_constructor (expr
->value
.constructor
, check_function
);
1424 /**************** Simplification of array constructors ****************/
1426 iterator_stack
*iter_stack
;
1430 gfc_constructor_base base
;
1431 int extract_count
, extract_n
;
1432 gfc_expr
*extracted
;
1436 gfc_component
*component
;
1439 bool (*expand_work_function
) (gfc_expr
*);
1443 static expand_info current_expand
;
1445 static bool expand_constructor (gfc_constructor_base
);
1448 /* Work function that counts the number of elements present in a
1452 count_elements (gfc_expr
*e
)
1457 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1460 if (!gfc_array_size (e
, &result
))
1466 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1475 /* Work function that extracts a particular element from an array
1476 constructor, freeing the rest. */
1479 extract_element (gfc_expr
*e
)
1482 { /* Something unextractable */
1487 if (current_expand
.extract_count
== current_expand
.extract_n
)
1488 current_expand
.extracted
= e
;
1492 current_expand
.extract_count
++;
1498 /* Work function that constructs a new constructor out of the old one,
1499 stringing new elements together. */
1502 expand (gfc_expr
*e
)
1504 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1507 c
->n
.component
= current_expand
.component
;
1512 /* Given an initialization expression that is a variable reference,
1513 substitute the current value of the iteration variable. */
1516 gfc_simplify_iterator_var (gfc_expr
*e
)
1520 for (p
= iter_stack
; p
; p
= p
->prev
)
1521 if (e
->symtree
== p
->variable
)
1525 return; /* Variable not found */
1527 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1529 mpz_set (e
->value
.integer
, p
->value
);
1535 /* Expand an expression with that is inside of a constructor,
1536 recursing into other constructors if present. */
1539 expand_expr (gfc_expr
*e
)
1541 if (e
->expr_type
== EXPR_ARRAY
)
1542 return expand_constructor (e
->value
.constructor
);
1544 e
= gfc_copy_expr (e
);
1546 if (!gfc_simplify_expr (e
, 1))
1552 return current_expand
.expand_work_function (e
);
1557 expand_iterator (gfc_constructor
*c
)
1559 gfc_expr
*start
, *end
, *step
;
1560 iterator_stack frame
;
1569 mpz_init (frame
.value
);
1572 start
= gfc_copy_expr (c
->iterator
->start
);
1573 if (!gfc_simplify_expr (start
, 1))
1576 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1579 end
= gfc_copy_expr (c
->iterator
->end
);
1580 if (!gfc_simplify_expr (end
, 1))
1583 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1586 step
= gfc_copy_expr (c
->iterator
->step
);
1587 if (!gfc_simplify_expr (step
, 1))
1590 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1593 if (mpz_sgn (step
->value
.integer
) == 0)
1595 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1599 /* Calculate the trip count of the loop. */
1600 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1601 mpz_add (trip
, trip
, step
->value
.integer
);
1602 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1604 mpz_set (frame
.value
, start
->value
.integer
);
1606 frame
.prev
= iter_stack
;
1607 frame
.variable
= c
->iterator
->var
->symtree
;
1608 iter_stack
= &frame
;
1610 while (mpz_sgn (trip
) > 0)
1612 if (!expand_expr (c
->expr
))
1615 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1616 mpz_sub_ui (trip
, trip
, 1);
1622 gfc_free_expr (start
);
1623 gfc_free_expr (end
);
1624 gfc_free_expr (step
);
1627 mpz_clear (frame
.value
);
1629 iter_stack
= frame
.prev
;
1635 /* Expand a constructor into constant constructors without any
1636 iterators, calling the work function for each of the expanded
1637 expressions. The work function needs to either save or free the
1638 passed expression. */
1641 expand_constructor (gfc_constructor_base base
)
1646 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1648 if (c
->iterator
!= NULL
)
1650 if (!expand_iterator (c
))
1657 if (e
->expr_type
== EXPR_ARRAY
)
1659 if (!expand_constructor (e
->value
.constructor
))
1665 e
= gfc_copy_expr (e
);
1666 if (!gfc_simplify_expr (e
, 1))
1671 current_expand
.offset
= &c
->offset
;
1672 current_expand
.repeat
= &c
->repeat
;
1673 current_expand
.component
= c
->n
.component
;
1674 if (!current_expand
.expand_work_function(e
))
1681 /* Given an array expression and an element number (starting at zero),
1682 return a pointer to the array element. NULL is returned if the
1683 size of the array has been exceeded. The expression node returned
1684 remains a part of the array and should not be freed. Access is not
1685 efficient at all, but this is another place where things do not
1686 have to be particularly fast. */
1689 gfc_get_array_element (gfc_expr
*array
, int element
)
1691 expand_info expand_save
;
1695 expand_save
= current_expand
;
1696 current_expand
.extract_n
= element
;
1697 current_expand
.expand_work_function
= extract_element
;
1698 current_expand
.extracted
= NULL
;
1699 current_expand
.extract_count
= 0;
1703 rc
= expand_constructor (array
->value
.constructor
);
1704 e
= current_expand
.extracted
;
1705 current_expand
= expand_save
;
1714 /* Top level subroutine for expanding constructors. We only expand
1715 constructor if they are small enough. */
1718 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1720 expand_info expand_save
;
1724 /* If we can successfully get an array element at the max array size then
1725 the array is too big to expand, so we just return. */
1726 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1732 gfc_error ("The number of elements in the array constructor "
1733 "at %L requires an increase of the allowed %d "
1734 "upper limit. See %<-fmax-array-constructor%> "
1735 "option", &e
->where
, flag_max_array_constructor
);
1741 /* We now know the array is not too big so go ahead and try to expand it. */
1742 expand_save
= current_expand
;
1743 current_expand
.base
= NULL
;
1747 current_expand
.expand_work_function
= expand
;
1749 if (!expand_constructor (e
->value
.constructor
))
1751 gfc_constructor_free (current_expand
.base
);
1756 gfc_constructor_free (e
->value
.constructor
);
1757 e
->value
.constructor
= current_expand
.base
;
1762 current_expand
= expand_save
;
1768 /* Work function for checking that an element of a constructor is a
1769 constant, after removal of any iteration variables. We return
1773 is_constant_element (gfc_expr
*e
)
1777 rv
= gfc_is_constant_expr (e
);
1780 return rv
? true : false;
1784 /* Given an array constructor, determine if the constructor is
1785 constant or not by expanding it and making sure that all elements
1786 are constants. This is a bit of a hack since something like (/ (i,
1787 i=1,100000000) /) will take a while as* opposed to a more clever
1788 function that traverses the expression tree. FIXME. */
1791 gfc_constant_ac (gfc_expr
*e
)
1793 expand_info expand_save
;
1797 expand_save
= current_expand
;
1798 current_expand
.expand_work_function
= is_constant_element
;
1800 rc
= expand_constructor (e
->value
.constructor
);
1802 current_expand
= expand_save
;
1810 /* Returns nonzero if an array constructor has been completely
1811 expanded (no iterators) and zero if iterators are present. */
1814 gfc_expanded_ac (gfc_expr
*e
)
1818 if (e
->expr_type
== EXPR_ARRAY
)
1819 for (c
= gfc_constructor_first (e
->value
.constructor
);
1820 c
; c
= gfc_constructor_next (c
))
1821 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1828 /*************** Type resolution of array constructors ***************/
1831 /* The symbol expr_is_sought_symbol_ref will try to find. */
1832 static const gfc_symbol
*sought_symbol
= NULL
;
1835 /* Tells whether the expression E is a variable reference to the symbol
1836 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1838 To be used with gfc_expr_walker: if a reference is found we don't need
1839 to look further so we return 1 to skip any further walk. */
1842 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1845 gfc_expr
*expr
= *e
;
1846 locus
*sym_loc
= (locus
*)where
;
1848 if (expr
->expr_type
== EXPR_VARIABLE
1849 && expr
->symtree
->n
.sym
== sought_symbol
)
1851 *sym_loc
= expr
->where
;
1859 /* Tells whether the expression EXPR contains a reference to the symbol
1860 SYM and in that case sets the position SYM_LOC where the reference is. */
1863 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1867 sought_symbol
= sym
;
1868 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1869 sought_symbol
= NULL
;
1874 /* Recursive array list resolution function. All of the elements must
1875 be of the same type. */
1878 resolve_array_list (gfc_constructor_base base
)
1886 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1891 gfc_symbol
*iter_var
;
1894 if (!gfc_resolve_iterator (iter
, false, true))
1897 /* Check for bounds referencing the iterator variable. */
1898 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1899 iter_var
= iter
->var
->symtree
->n
.sym
;
1900 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1902 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1903 "expression references control variable "
1904 "at %L", &iter_var_loc
))
1907 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1909 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1910 "expression references control variable "
1911 "at %L", &iter_var_loc
))
1914 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1916 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1917 "expression references control variable "
1918 "at %L", &iter_var_loc
))
1923 if (!gfc_resolve_expr (c
->expr
))
1926 if (UNLIMITED_POLY (c
->expr
))
1928 gfc_error ("Array constructor value at %L shall not be unlimited "
1929 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1937 /* Resolve character array constructor. If it has a specified constant character
1938 length, pad/truncate the elements here; if the length is not specified and
1939 all elements are of compile-time known length, emit an error as this is
1943 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1948 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1949 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1951 if (expr
->ts
.u
.cl
== NULL
)
1953 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1954 p
; p
= gfc_constructor_next (p
))
1955 if (p
->expr
->ts
.u
.cl
!= NULL
)
1957 /* Ensure that if there is a char_len around that it is
1958 used; otherwise the middle-end confuses them! */
1959 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
1963 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1970 if (expr
->ts
.u
.cl
->length
== NULL
)
1972 /* Check that all constant string elements have the same length until
1973 we reach the end or find a variable-length one. */
1975 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1976 p
; p
= gfc_constructor_next (p
))
1978 int current_length
= -1;
1980 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
1981 if (ref
->type
== REF_SUBSTRING
1982 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1983 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1986 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
1987 current_length
= p
->expr
->value
.character
.length
;
1991 j
= mpz_get_ui (ref
->u
.ss
.end
->value
.integer
)
1992 - mpz_get_ui (ref
->u
.ss
.start
->value
.integer
) + 1;
1993 current_length
= (int) j
;
1995 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
1996 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1999 j
= mpz_get_si (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2000 current_length
= (int) j
;
2005 gcc_assert (current_length
!= -1);
2007 if (found_length
== -1)
2008 found_length
= current_length
;
2009 else if (found_length
!= current_length
)
2011 gfc_error ("Different CHARACTER lengths (%d/%d) in array"
2012 " constructor at %L", found_length
, current_length
,
2017 gcc_assert (found_length
== current_length
);
2020 gcc_assert (found_length
!= -1);
2022 /* Update the character length of the array constructor. */
2023 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
2024 NULL
, found_length
);
2028 /* We've got a character length specified. It should be an integer,
2029 otherwise an error is signalled elsewhere. */
2030 gcc_assert (expr
->ts
.u
.cl
->length
);
2032 /* If we've got a constant character length, pad according to this.
2033 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2034 max_length only if they pass. */
2035 gfc_extract_int (expr
->ts
.u
.cl
->length
, &found_length
);
2037 /* Now pad/truncate the elements accordingly to the specified character
2038 length. This is ok inside this conditional, as in the case above
2039 (without typespec) all elements are verified to have the same length
2041 if (found_length
!= -1)
2042 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2043 p
; p
= gfc_constructor_next (p
))
2044 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2046 gfc_expr
*cl
= NULL
;
2047 int current_length
= -1;
2050 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2052 cl
= p
->expr
->ts
.u
.cl
->length
;
2053 gfc_extract_int (cl
, ¤t_length
);
2056 /* If gfc_extract_int above set current_length, we implicitly
2057 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2059 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2062 || (current_length
!= -1 && current_length
!= found_length
))
2063 gfc_set_constant_character_len (found_length
, p
->expr
,
2064 has_ts
? -1 : found_length
);
2072 /* Resolve all of the expressions in an array list. */
2075 gfc_resolve_array_constructor (gfc_expr
*expr
)
2079 t
= resolve_array_list (expr
->value
.constructor
);
2081 t
= gfc_check_constructor_type (expr
);
2083 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2084 the call to this function, so we don't need to call it here; if it was
2085 called twice, an error message there would be duplicated. */
2091 /* Copy an iterator structure. */
2094 gfc_copy_iterator (gfc_iterator
*src
)
2101 dest
= gfc_get_iterator ();
2103 dest
->var
= gfc_copy_expr (src
->var
);
2104 dest
->start
= gfc_copy_expr (src
->start
);
2105 dest
->end
= gfc_copy_expr (src
->end
);
2106 dest
->step
= gfc_copy_expr (src
->step
);
2112 /********* Subroutines for determining the size of an array *********/
2114 /* These are needed just to accommodate RESHAPE(). There are no
2115 diagnostics here, we just return a negative number if something
2119 /* Get the size of single dimension of an array specification. The
2120 array is guaranteed to be one dimensional. */
2123 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2128 if (dimen
< 0 || dimen
> as
->rank
- 1)
2129 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2131 if (as
->type
!= AS_EXPLICIT
2132 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2133 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2134 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2135 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2140 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2141 as
->lower
[dimen
]->value
.integer
);
2143 mpz_add_ui (*result
, *result
, 1);
2150 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2155 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2158 mpz_init_set_ui (*result
, 1);
2160 for (d
= 0; d
< as
->rank
; d
++)
2162 if (!spec_dimen_size (as
, d
, &size
))
2164 mpz_clear (*result
);
2168 mpz_mul (*result
, *result
, size
);
2176 /* Get the number of elements in an array section. Optionally, also supply
2180 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2182 mpz_t upper
, lower
, stride
;
2186 if (dimen
< 0 || ar
== NULL
|| dimen
> ar
->dimen
- 1)
2187 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2189 switch (ar
->dimen_type
[dimen
])
2193 mpz_set_ui (*result
, 1);
2198 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2205 if (ar
->stride
[dimen
] == NULL
)
2206 mpz_set_ui (stride
, 1);
2209 if (ar
->stride
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2214 mpz_set (stride
, ar
->stride
[dimen
]->value
.integer
);
2217 /* Calculate the number of elements via gfc_dep_differce, but only if
2218 start and end are both supplied in the reference or the array spec.
2219 This is to guard against strange but valid code like
2224 print *,size(a(n-1:))
2226 where the user changes the value of a variable. If we have to
2227 determine end as well, we cannot do this using gfc_dep_difference.
2228 Fall back to the constants-only code then. */
2234 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2236 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2237 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2238 ar
->as
->lower
[dimen
], &diff
);
2243 mpz_add (*result
, diff
, stride
);
2244 mpz_div (*result
, *result
, stride
);
2245 if (mpz_cmp_ui (*result
, 0) < 0)
2246 mpz_set_ui (*result
, 0);
2255 /* Constant-only code here, which covers more cases
2261 if (ar
->start
[dimen
] == NULL
)
2263 if (ar
->as
->lower
[dimen
] == NULL
2264 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2265 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2267 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2271 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2273 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2276 if (ar
->end
[dimen
] == NULL
)
2278 if (ar
->as
->upper
[dimen
] == NULL
2279 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2280 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2282 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2286 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2288 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2292 mpz_sub (*result
, upper
, lower
);
2293 mpz_add (*result
, *result
, stride
);
2294 mpz_div (*result
, *result
, stride
);
2296 /* Zero stride caught earlier. */
2297 if (mpz_cmp_ui (*result
, 0) < 0)
2298 mpz_set_ui (*result
, 0);
2305 mpz_sub_ui (*end
, *result
, 1UL);
2306 mpz_mul (*end
, *end
, stride
);
2307 mpz_add (*end
, *end
, lower
);
2317 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2325 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2330 mpz_init_set_ui (*result
, 1);
2332 for (d
= 0; d
< ar
->dimen
; d
++)
2334 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2336 mpz_clear (*result
);
2340 mpz_mul (*result
, *result
, size
);
2348 /* Given an array expression and a dimension, figure out how many
2349 elements it has along that dimension. Returns true if we were
2350 able to return a result in the 'result' variable, false
2354 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2359 gcc_assert (array
!= NULL
);
2361 if (array
->ts
.type
== BT_CLASS
)
2364 if (array
->rank
== -1)
2367 if (dimen
< 0 || dimen
> array
->rank
- 1)
2368 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2370 switch (array
->expr_type
)
2374 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2376 if (ref
->type
!= REF_ARRAY
)
2379 if (ref
->u
.ar
.type
== AR_FULL
)
2380 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2382 if (ref
->u
.ar
.type
== AR_SECTION
)
2384 for (i
= 0; dimen
>= 0; i
++)
2385 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2388 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2392 if (array
->shape
&& array
->shape
[dimen
])
2394 mpz_init_set (*result
, array
->shape
[dimen
]);
2398 if (array
->symtree
->n
.sym
->attr
.generic
2399 && array
->value
.function
.esym
!= NULL
)
2401 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2404 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2410 if (array
->shape
== NULL
) {
2411 /* Expressions with rank > 1 should have "shape" properly set */
2412 if ( array
->rank
!= 1 )
2413 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2414 return gfc_array_size(array
, result
);
2419 if (array
->shape
== NULL
)
2422 mpz_init_set (*result
, array
->shape
[dimen
]);
2431 /* Given an array expression, figure out how many elements are in the
2432 array. Returns true if this is possible, and sets the 'result'
2433 variable. Otherwise returns false. */
2436 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2438 expand_info expand_save
;
2443 if (array
->ts
.type
== BT_CLASS
)
2446 switch (array
->expr_type
)
2449 gfc_push_suppress_errors ();
2451 expand_save
= current_expand
;
2453 current_expand
.count
= result
;
2454 mpz_init_set_ui (*result
, 0);
2456 current_expand
.expand_work_function
= count_elements
;
2459 t
= expand_constructor (array
->value
.constructor
);
2461 gfc_pop_suppress_errors ();
2464 mpz_clear (*result
);
2465 current_expand
= expand_save
;
2469 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2471 if (ref
->type
!= REF_ARRAY
)
2474 if (ref
->u
.ar
.type
== AR_FULL
)
2475 return spec_size (ref
->u
.ar
.as
, result
);
2477 if (ref
->u
.ar
.type
== AR_SECTION
)
2478 return ref_size (&ref
->u
.ar
, result
);
2481 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2485 if (array
->rank
== 0 || array
->shape
== NULL
)
2488 mpz_init_set_ui (*result
, 1);
2490 for (i
= 0; i
< array
->rank
; i
++)
2491 mpz_mul (*result
, *result
, array
->shape
[i
]);
2500 /* Given an array reference, return the shape of the reference in an
2501 array of mpz_t integers. */
2504 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2514 for (; d
< ar
->as
->rank
; d
++)
2515 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2521 for (i
= 0; i
< ar
->dimen
; i
++)
2523 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2525 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2538 gfc_clear_shape (shape
, d
);
2543 /* Given an array expression, find the array reference structure that
2544 characterizes the reference. */
2547 gfc_find_array_ref (gfc_expr
*e
)
2551 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2552 if (ref
->type
== REF_ARRAY
2553 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2557 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2563 /* Find out if an array shape is known at compile time. */
2566 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2570 if (as
->type
!= AS_EXPLICIT
)
2573 for (i
= 0; i
< as
->rank
; i
++)
2574 if (!gfc_is_constant_expr (as
->lower
[i
])
2575 || !gfc_is_constant_expr (as
->upper
[i
]))