2 Copyright (C) 2000-2018 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 bool stat_just_seen
= false;
161 bool team_just_seen
= false;
163 memset (ar
, '\0', sizeof (*ar
));
165 ar
->where
= gfc_current_locus
;
167 ar
->type
= AR_UNKNOWN
;
169 if (gfc_match_char ('[') == MATCH_YES
)
171 matched_bracket
= true;
175 if (gfc_match_char ('(') != MATCH_YES
)
182 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
184 m
= match_subscript (ar
, init
, false);
185 if (m
== MATCH_ERROR
)
188 if (gfc_match_char (')') == MATCH_YES
)
194 if (gfc_match_char (',') != MATCH_YES
)
196 gfc_error ("Invalid form of array reference at %C");
202 && !gfc_notify_std (GFC_STD_F2008
,
203 "Array reference at %C has more than 7 dimensions"))
206 gfc_error ("Array reference at %C cannot have more than %d dimensions",
211 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
219 if (flag_coarray
== GFC_FCOARRAY_NONE
)
221 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
227 gfc_error ("Unexpected coarray designator at %C");
233 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
235 m
= match_subscript (ar
, init
, true);
236 if (m
== MATCH_ERROR
)
239 team_just_seen
= false;
240 stat_just_seen
= false;
241 if (gfc_match (" , team = %e", &tmp
) == MATCH_YES
&& ar
->team
== NULL
)
244 team_just_seen
= true;
247 if (ar
->team
&& !team_just_seen
)
249 gfc_error ("TEAM= attribute in %C misplaced");
253 if (gfc_match (" , stat = %e",&tmp
) == MATCH_YES
&& ar
->stat
== NULL
)
256 stat_just_seen
= true;
259 if (ar
->stat
&& !stat_just_seen
)
261 gfc_error ("STAT= attribute in %C misplaced");
265 if (gfc_match_char (']') == MATCH_YES
)
268 if (ar
->codimen
< corank
)
270 gfc_error ("Too few codimensions at %C, expected %d not %d",
271 corank
, ar
->codimen
);
274 if (ar
->codimen
> corank
)
276 gfc_error ("Too many codimensions at %C, expected %d not %d",
277 corank
, ar
->codimen
);
283 if (gfc_match_char (',') != MATCH_YES
)
285 if (gfc_match_char ('*') == MATCH_YES
)
286 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
287 ar
->codimen
+ 1, corank
);
289 gfc_error ("Invalid form of coarray reference at %C");
292 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
294 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
295 ar
->codimen
+ 1, corank
);
299 if (ar
->codimen
>= corank
)
301 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
302 ar
->codimen
+ 1, corank
);
307 gfc_error ("Array reference at %C cannot have more than %d dimensions",
314 /************** Array specification matching subroutines ***************/
316 /* Free all of the expressions associated with array bounds
320 gfc_free_array_spec (gfc_array_spec
*as
)
327 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
329 gfc_free_expr (as
->lower
[i
]);
330 gfc_free_expr (as
->upper
[i
]);
337 /* Take an array bound, resolves the expression, that make up the
338 shape and check associated constraints. */
341 resolve_array_bound (gfc_expr
*e
, int check_constant
)
346 if (!gfc_resolve_expr (e
)
347 || !gfc_specification_expr (e
))
350 if (check_constant
&& !gfc_is_constant_expr (e
))
352 if (e
->expr_type
== EXPR_VARIABLE
)
353 gfc_error ("Variable %qs at %L in this context must be constant",
354 e
->symtree
->n
.sym
->name
, &e
->where
);
356 gfc_error ("Expression at %L in this context must be constant",
365 /* Takes an array specification, resolves the expressions that make up
366 the shape and make sure everything is integral. */
369 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
380 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
383 if (!resolve_array_bound (e
, check_constant
))
387 if (!resolve_array_bound (e
, check_constant
))
390 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
393 /* If the size is negative in this dimension, set it to zero. */
394 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
395 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
396 && mpz_cmp (as
->upper
[i
]->value
.integer
,
397 as
->lower
[i
]->value
.integer
) < 0)
399 gfc_free_expr (as
->upper
[i
]);
400 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
401 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
402 as
->upper
[i
]->value
.integer
, 1);
412 /* Match a single array element specification. The return values as
413 well as the upper and lower bounds of the array spec are filled
414 in according to what we see on the input. The caller makes sure
415 individual specifications make sense as a whole.
418 Parsed Lower Upper Returned
419 ------------------------------------
420 : NULL NULL AS_DEFERRED (*)
422 x: x NULL AS_ASSUMED_SHAPE
424 x:* x NULL AS_ASSUMED_SIZE
425 * 1 NULL AS_ASSUMED_SIZE
427 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
428 is fixed during the resolution of formal interfaces.
430 Anything else AS_UNKNOWN. */
433 match_array_element_spec (gfc_array_spec
*as
)
435 gfc_expr
**upper
, **lower
;
439 rank
= as
->rank
== -1 ? 0 : as
->rank
;
440 lower
= &as
->lower
[rank
+ as
->corank
- 1];
441 upper
= &as
->upper
[rank
+ as
->corank
- 1];
443 if (gfc_match_char ('*') == MATCH_YES
)
445 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
446 return AS_ASSUMED_SIZE
;
449 if (gfc_match_char (':') == MATCH_YES
)
452 m
= gfc_match_expr (upper
);
454 gfc_error ("Expected expression in array specification at %C");
457 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
460 if (((*upper
)->expr_type
== EXPR_CONSTANT
461 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
462 ((*upper
)->expr_type
== EXPR_FUNCTION
463 && (*upper
)->ts
.type
== BT_UNKNOWN
465 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
467 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
468 gfc_basic_typename ((*upper
)->ts
.type
));
472 if (gfc_match_char (':') == MATCH_NO
)
474 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
481 if (gfc_match_char ('*') == MATCH_YES
)
482 return AS_ASSUMED_SIZE
;
484 m
= gfc_match_expr (upper
);
485 if (m
== MATCH_ERROR
)
488 return AS_ASSUMED_SHAPE
;
489 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
492 if (((*upper
)->expr_type
== EXPR_CONSTANT
493 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
494 ((*upper
)->expr_type
== EXPR_FUNCTION
495 && (*upper
)->ts
.type
== BT_UNKNOWN
497 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
499 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
500 gfc_basic_typename ((*upper
)->ts
.type
));
508 /* Matches an array specification, incidentally figuring out what sort
509 it is. Match either a normal array specification, or a coarray spec
510 or both. Optionally allow [:] for coarrays. */
513 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
515 array_type current_type
;
519 as
= gfc_get_array_spec ();
524 if (gfc_match_char ('(') != MATCH_YES
)
531 if (gfc_match (" .. )") == MATCH_YES
)
533 as
->type
= AS_ASSUMED_RANK
;
536 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-rank array at %C"))
547 current_type
= match_array_element_spec (as
);
549 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
550 and implied-shape specifications. If the rank is at least 2, we can
551 distinguish between them. But for rank 1, we currently return
552 ASSUMED_SIZE; this gets adjusted later when we know for sure
553 whether the symbol parsed is a PARAMETER or not. */
557 if (current_type
== AS_UNKNOWN
)
559 as
->type
= current_type
;
563 { /* See how current spec meshes with the existing. */
567 case AS_IMPLIED_SHAPE
:
568 if (current_type
!= AS_ASSUMED_SHAPE
)
570 gfc_error ("Bad array specification for implied-shape"
577 if (current_type
== AS_ASSUMED_SIZE
)
579 as
->type
= AS_ASSUMED_SIZE
;
583 if (current_type
== AS_EXPLICIT
)
586 gfc_error ("Bad array specification for an explicitly shaped "
591 case AS_ASSUMED_SHAPE
:
592 if ((current_type
== AS_ASSUMED_SHAPE
)
593 || (current_type
== AS_DEFERRED
))
596 gfc_error ("Bad array specification for assumed shape "
601 if (current_type
== AS_DEFERRED
)
604 if (current_type
== AS_ASSUMED_SHAPE
)
606 as
->type
= AS_ASSUMED_SHAPE
;
610 gfc_error ("Bad specification for deferred shape array at %C");
613 case AS_ASSUMED_SIZE
:
614 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
616 as
->type
= AS_IMPLIED_SHAPE
;
620 gfc_error ("Bad specification for assumed size array at %C");
623 case AS_ASSUMED_RANK
:
627 if (gfc_match_char (')') == MATCH_YES
)
630 if (gfc_match_char (',') != MATCH_YES
)
632 gfc_error ("Expected another dimension in array declaration at %C");
636 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
638 gfc_error ("Array specification at %C has more than %d dimensions",
643 if (as
->corank
+ as
->rank
>= 7
644 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
645 "with more than 7 dimensions"))
653 if (gfc_match_char ('[') != MATCH_YES
)
656 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
659 if (flag_coarray
== GFC_FCOARRAY_NONE
)
661 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
665 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
667 gfc_error ("Array specification at %C has more than %d "
668 "dimensions", GFC_MAX_DIMENSIONS
);
675 current_type
= match_array_element_spec (as
);
677 if (current_type
== AS_UNKNOWN
)
681 as
->cotype
= current_type
;
684 { /* See how current spec meshes with the existing. */
685 case AS_IMPLIED_SHAPE
:
690 if (current_type
== AS_ASSUMED_SIZE
)
692 as
->cotype
= AS_ASSUMED_SIZE
;
696 if (current_type
== AS_EXPLICIT
)
699 gfc_error ("Bad array specification for an explicitly "
700 "shaped array at %C");
704 case AS_ASSUMED_SHAPE
:
705 if ((current_type
== AS_ASSUMED_SHAPE
)
706 || (current_type
== AS_DEFERRED
))
709 gfc_error ("Bad array specification for assumed shape "
714 if (current_type
== AS_DEFERRED
)
717 if (current_type
== AS_ASSUMED_SHAPE
)
719 as
->cotype
= AS_ASSUMED_SHAPE
;
723 gfc_error ("Bad specification for deferred shape array at %C");
726 case AS_ASSUMED_SIZE
:
727 gfc_error ("Bad specification for assumed size array at %C");
730 case AS_ASSUMED_RANK
:
734 if (gfc_match_char (']') == MATCH_YES
)
737 if (gfc_match_char (',') != MATCH_YES
)
739 gfc_error ("Expected another dimension in array declaration at %C");
743 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
745 gfc_error ("Array specification at %C has more than %d "
746 "dimensions", GFC_MAX_DIMENSIONS
);
751 if (current_type
== AS_EXPLICIT
)
753 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
757 if (as
->cotype
== AS_ASSUMED_SIZE
)
758 as
->cotype
= AS_EXPLICIT
;
761 as
->type
= as
->cotype
;
764 if (as
->rank
== 0 && as
->corank
== 0)
767 gfc_free_array_spec (as
);
771 /* If a lower bounds of an assumed shape array is blank, put in one. */
772 if (as
->type
== AS_ASSUMED_SHAPE
)
774 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
776 if (as
->lower
[i
] == NULL
)
777 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
786 /* Something went wrong. */
787 gfc_free_array_spec (as
);
792 /* Given a symbol and an array specification, modify the symbol to
793 have that array specification. The error locus is needed in case
794 something goes wrong. On failure, the caller must free the spec. */
797 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
805 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
809 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
818 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
819 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
821 gfc_error ("The assumed-rank array %qs at %L shall not have a "
822 "codimension", sym
->name
, error_loc
);
828 /* The "sym" has no corank (checked via gfc_add_codimension). Thus
829 the codimension is simply added. */
830 gcc_assert (as
->rank
== 0 && sym
->as
->corank
== 0);
832 sym
->as
->cotype
= as
->cotype
;
833 sym
->as
->corank
= as
->corank
;
834 for (i
= 0; i
< as
->corank
; i
++)
836 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
837 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
842 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
843 the dimension is added - but first the codimensions (if existing
844 need to be shifted to make space for the dimension. */
845 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
847 sym
->as
->rank
= as
->rank
;
848 sym
->as
->type
= as
->type
;
849 sym
->as
->cray_pointee
= as
->cray_pointee
;
850 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
852 for (i
= 0; i
< sym
->as
->corank
; i
++)
854 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
855 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
857 for (i
= 0; i
< as
->rank
; i
++)
859 sym
->as
->lower
[i
] = as
->lower
[i
];
860 sym
->as
->upper
[i
] = as
->upper
[i
];
869 /* Copy an array specification. */
872 gfc_copy_array_spec (gfc_array_spec
*src
)
874 gfc_array_spec
*dest
;
880 dest
= gfc_get_array_spec ();
884 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
886 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
887 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
894 /* Returns nonzero if the two expressions are equal. Only handles integer
898 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
900 if (bound1
== NULL
|| bound2
== NULL
901 || bound1
->expr_type
!= EXPR_CONSTANT
902 || bound2
->expr_type
!= EXPR_CONSTANT
903 || bound1
->ts
.type
!= BT_INTEGER
904 || bound2
->ts
.type
!= BT_INTEGER
)
905 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
907 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
914 /* Compares two array specifications. They must be constant or deferred
918 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
922 if (as1
== NULL
&& as2
== NULL
)
925 if (as1
== NULL
|| as2
== NULL
)
928 if (as1
->rank
!= as2
->rank
)
931 if (as1
->corank
!= as2
->corank
)
937 if (as1
->type
!= as2
->type
)
940 if (as1
->type
== AS_EXPLICIT
)
941 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
943 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
946 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
954 /****************** Array constructor functions ******************/
957 /* Given an expression node that might be an array constructor and a
958 symbol, make sure that no iterators in this or child constructors
959 use the symbol as an implied-DO iterator. Returns nonzero if a
960 duplicate was found. */
963 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
968 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
972 if (e
->expr_type
== EXPR_ARRAY
973 && check_duplicate_iterator (e
->value
.constructor
, master
))
976 if (c
->iterator
== NULL
)
979 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
981 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
982 "same name", master
->name
, &c
->where
);
992 /* Forward declaration because these functions are mutually recursive. */
993 static match
match_array_cons_element (gfc_constructor_base
*);
995 /* Match a list of array elements. */
998 match_array_list (gfc_constructor_base
*result
)
1000 gfc_constructor_base head
;
1008 old_loc
= gfc_current_locus
;
1010 if (gfc_match_char ('(') == MATCH_NO
)
1013 memset (&iter
, '\0', sizeof (gfc_iterator
));
1016 m
= match_array_cons_element (&head
);
1020 if (gfc_match_char (',') != MATCH_YES
)
1028 m
= gfc_match_iterator (&iter
, 0);
1031 if (m
== MATCH_ERROR
)
1034 m
= match_array_cons_element (&head
);
1035 if (m
== MATCH_ERROR
)
1042 goto cleanup
; /* Could be a complex constant */
1045 if (gfc_match_char (',') != MATCH_YES
)
1054 if (gfc_match_char (')') != MATCH_YES
)
1057 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1063 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1064 e
->value
.constructor
= head
;
1066 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1067 p
->iterator
= gfc_get_iterator ();
1068 *p
->iterator
= iter
;
1073 gfc_error ("Syntax error in array constructor at %C");
1077 gfc_constructor_free (head
);
1078 gfc_free_iterator (&iter
, 0);
1079 gfc_current_locus
= old_loc
;
1084 /* Match a single element of an array constructor, which can be a
1085 single expression or a list of elements. */
1088 match_array_cons_element (gfc_constructor_base
*result
)
1093 m
= match_array_list (result
);
1097 m
= gfc_match_expr (&expr
);
1101 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1106 /* Match an array constructor. */
1109 gfc_match_array_constructor (gfc_expr
**result
)
1112 gfc_constructor_base head
;
1117 const char *end_delim
;
1123 if (gfc_match (" (/") == MATCH_NO
)
1125 if (gfc_match (" [") == MATCH_NO
)
1129 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1130 "style array constructors at %C"))
1138 where
= gfc_current_locus
;
1140 /* Try to match an optional "type-spec ::" */
1142 m
= gfc_match_type_spec (&ts
);
1145 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1149 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1150 "including type specification at %C"))
1155 gfc_error ("Type-spec at %L cannot contain a deferred "
1156 "type parameter", &where
);
1160 if (ts
.type
== BT_CHARACTER
1161 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1163 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1164 "type parameter", &where
);
1169 else if (m
== MATCH_ERROR
)
1173 gfc_current_locus
= where
;
1175 if (gfc_match (end_delim
) == MATCH_YES
)
1181 gfc_error ("Empty array constructor at %C is not allowed");
1188 m
= match_array_cons_element (&head
);
1189 if (m
== MATCH_ERROR
)
1194 if (gfc_match_char (',') == MATCH_NO
)
1198 if (gfc_match (end_delim
) == MATCH_NO
)
1202 /* Size must be calculated at resolution time. */
1205 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1208 /* If the typespec is CHARACTER, check that array elements can
1209 be converted. See PR fortran/67803. */
1210 if (ts
.type
== BT_CHARACTER
)
1212 c
= gfc_constructor_first (head
);
1213 for (; c
; c
= gfc_constructor_next (c
))
1215 if (gfc_numeric_ts (&c
->expr
->ts
)
1216 || c
->expr
->ts
.type
== BT_LOGICAL
)
1218 gfc_error ("Incompatible typespec for array element at %L",
1223 /* Special case null(). */
1224 if (c
->expr
->expr_type
== EXPR_FUNCTION
1225 && c
->expr
->ts
.type
== BT_UNKNOWN
1226 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1228 gfc_error ("Incompatible typespec for array element at %L",
1235 /* Walk the constructor and ensure type conversion for numeric types. */
1236 if (gfc_numeric_ts (&ts
))
1238 c
= gfc_constructor_first (head
);
1239 for (; c
; c
= gfc_constructor_next (c
))
1240 gfc_convert_type (c
->expr
, &ts
, 1);
1244 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1246 expr
->value
.constructor
= head
;
1248 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1255 gfc_error ("Syntax error in array constructor at %C");
1258 gfc_constructor_free (head
);
1264 /************** Check array constructors for correctness **************/
1266 /* Given an expression, compare it's type with the type of the current
1267 constructor. Returns nonzero if an error was issued. The
1268 cons_state variable keeps track of whether the type of the
1269 constructor being read or resolved is known to be good, bad or just
1272 static gfc_typespec constructor_ts
;
1274 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1278 check_element_type (gfc_expr
*expr
, bool convert
)
1280 if (cons_state
== CONS_BAD
)
1281 return 0; /* Suppress further errors */
1283 if (cons_state
== CONS_START
)
1285 if (expr
->ts
.type
== BT_UNKNOWN
)
1286 cons_state
= CONS_BAD
;
1289 cons_state
= CONS_GOOD
;
1290 constructor_ts
= expr
->ts
;
1296 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1300 return gfc_convert_type(expr
, &constructor_ts
, 1) ? 0 : 1;
1302 gfc_error ("Element in %s array constructor at %L is %s",
1303 gfc_typename (&constructor_ts
), &expr
->where
,
1304 gfc_typename (&expr
->ts
));
1306 cons_state
= CONS_BAD
;
1311 /* Recursive work function for gfc_check_constructor_type(). */
1314 check_constructor_type (gfc_constructor_base base
, bool convert
)
1319 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1323 if (e
->expr_type
== EXPR_ARRAY
)
1325 if (!check_constructor_type (e
->value
.constructor
, convert
))
1331 if (check_element_type (e
, convert
))
1339 /* Check that all elements of an array constructor are the same type.
1340 On false, an error has been generated. */
1343 gfc_check_constructor_type (gfc_expr
*e
)
1347 if (e
->ts
.type
!= BT_UNKNOWN
)
1349 cons_state
= CONS_GOOD
;
1350 constructor_ts
= e
->ts
;
1354 cons_state
= CONS_START
;
1355 gfc_clear_ts (&constructor_ts
);
1358 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1359 typespec, and we will now convert the values on the fly. */
1360 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1361 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1362 e
->ts
= constructor_ts
;
1369 typedef struct cons_stack
1371 gfc_iterator
*iterator
;
1372 struct cons_stack
*previous
;
1376 static cons_stack
*base
;
1378 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1380 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1381 that that variable is an iteration variables. */
1384 gfc_check_iter_variable (gfc_expr
*expr
)
1389 sym
= expr
->symtree
->n
.sym
;
1391 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1392 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1399 /* Recursive work function for gfc_check_constructor(). This amounts
1400 to calling the check function for each expression in the
1401 constructor, giving variables with the names of iterators a pass. */
1404 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1411 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1418 if (e
->expr_type
!= EXPR_ARRAY
)
1420 if (!(*check_function
)(e
))
1425 element
.previous
= base
;
1426 element
.iterator
= c
->iterator
;
1429 t
= check_constructor (e
->value
.constructor
, check_function
);
1430 base
= element
.previous
;
1436 /* Nothing went wrong, so all OK. */
1441 /* Checks a constructor to see if it is a particular kind of
1442 expression -- specification, restricted, or initialization as
1443 determined by the check_function. */
1446 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1448 cons_stack
*base_save
;
1454 t
= check_constructor (expr
->value
.constructor
, check_function
);
1462 /**************** Simplification of array constructors ****************/
1464 iterator_stack
*iter_stack
;
1468 gfc_constructor_base base
;
1469 int extract_count
, extract_n
;
1470 gfc_expr
*extracted
;
1474 gfc_component
*component
;
1477 bool (*expand_work_function
) (gfc_expr
*);
1481 static expand_info current_expand
;
1483 static bool expand_constructor (gfc_constructor_base
);
1486 /* Work function that counts the number of elements present in a
1490 count_elements (gfc_expr
*e
)
1495 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1498 if (!gfc_array_size (e
, &result
))
1504 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1513 /* Work function that extracts a particular element from an array
1514 constructor, freeing the rest. */
1517 extract_element (gfc_expr
*e
)
1520 { /* Something unextractable */
1525 if (current_expand
.extract_count
== current_expand
.extract_n
)
1526 current_expand
.extracted
= e
;
1530 current_expand
.extract_count
++;
1536 /* Work function that constructs a new constructor out of the old one,
1537 stringing new elements together. */
1540 expand (gfc_expr
*e
)
1542 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1545 c
->n
.component
= current_expand
.component
;
1550 /* Given an initialization expression that is a variable reference,
1551 substitute the current value of the iteration variable. */
1554 gfc_simplify_iterator_var (gfc_expr
*e
)
1558 for (p
= iter_stack
; p
; p
= p
->prev
)
1559 if (e
->symtree
== p
->variable
)
1563 return; /* Variable not found */
1565 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1567 mpz_set (e
->value
.integer
, p
->value
);
1573 /* Expand an expression with that is inside of a constructor,
1574 recursing into other constructors if present. */
1577 expand_expr (gfc_expr
*e
)
1579 if (e
->expr_type
== EXPR_ARRAY
)
1580 return expand_constructor (e
->value
.constructor
);
1582 e
= gfc_copy_expr (e
);
1584 if (!gfc_simplify_expr (e
, 1))
1590 return current_expand
.expand_work_function (e
);
1595 expand_iterator (gfc_constructor
*c
)
1597 gfc_expr
*start
, *end
, *step
;
1598 iterator_stack frame
;
1607 mpz_init (frame
.value
);
1610 start
= gfc_copy_expr (c
->iterator
->start
);
1611 if (!gfc_simplify_expr (start
, 1))
1614 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1617 end
= gfc_copy_expr (c
->iterator
->end
);
1618 if (!gfc_simplify_expr (end
, 1))
1621 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1624 step
= gfc_copy_expr (c
->iterator
->step
);
1625 if (!gfc_simplify_expr (step
, 1))
1628 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1631 if (mpz_sgn (step
->value
.integer
) == 0)
1633 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1637 /* Calculate the trip count of the loop. */
1638 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1639 mpz_add (trip
, trip
, step
->value
.integer
);
1640 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1642 mpz_set (frame
.value
, start
->value
.integer
);
1644 frame
.prev
= iter_stack
;
1645 frame
.variable
= c
->iterator
->var
->symtree
;
1646 iter_stack
= &frame
;
1648 while (mpz_sgn (trip
) > 0)
1650 if (!expand_expr (c
->expr
))
1653 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1654 mpz_sub_ui (trip
, trip
, 1);
1660 gfc_free_expr (start
);
1661 gfc_free_expr (end
);
1662 gfc_free_expr (step
);
1665 mpz_clear (frame
.value
);
1667 iter_stack
= frame
.prev
;
1673 /* Expand a constructor into constant constructors without any
1674 iterators, calling the work function for each of the expanded
1675 expressions. The work function needs to either save or free the
1676 passed expression. */
1679 expand_constructor (gfc_constructor_base base
)
1684 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1686 if (c
->iterator
!= NULL
)
1688 if (!expand_iterator (c
))
1695 if (e
->expr_type
== EXPR_ARRAY
)
1697 if (!expand_constructor (e
->value
.constructor
))
1703 e
= gfc_copy_expr (e
);
1704 if (!gfc_simplify_expr (e
, 1))
1709 current_expand
.offset
= &c
->offset
;
1710 current_expand
.repeat
= &c
->repeat
;
1711 current_expand
.component
= c
->n
.component
;
1712 if (!current_expand
.expand_work_function(e
))
1719 /* Given an array expression and an element number (starting at zero),
1720 return a pointer to the array element. NULL is returned if the
1721 size of the array has been exceeded. The expression node returned
1722 remains a part of the array and should not be freed. Access is not
1723 efficient at all, but this is another place where things do not
1724 have to be particularly fast. */
1727 gfc_get_array_element (gfc_expr
*array
, int element
)
1729 expand_info expand_save
;
1733 expand_save
= current_expand
;
1734 current_expand
.extract_n
= element
;
1735 current_expand
.expand_work_function
= extract_element
;
1736 current_expand
.extracted
= NULL
;
1737 current_expand
.extract_count
= 0;
1741 rc
= expand_constructor (array
->value
.constructor
);
1742 e
= current_expand
.extracted
;
1743 current_expand
= expand_save
;
1752 /* Top level subroutine for expanding constructors. We only expand
1753 constructor if they are small enough. */
1756 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1758 expand_info expand_save
;
1762 /* If we can successfully get an array element at the max array size then
1763 the array is too big to expand, so we just return. */
1764 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1770 gfc_error ("The number of elements in the array constructor "
1771 "at %L requires an increase of the allowed %d "
1772 "upper limit. See %<-fmax-array-constructor%> "
1773 "option", &e
->where
, flag_max_array_constructor
);
1779 /* We now know the array is not too big so go ahead and try to expand it. */
1780 expand_save
= current_expand
;
1781 current_expand
.base
= NULL
;
1785 current_expand
.expand_work_function
= expand
;
1787 if (!expand_constructor (e
->value
.constructor
))
1789 gfc_constructor_free (current_expand
.base
);
1794 gfc_constructor_free (e
->value
.constructor
);
1795 e
->value
.constructor
= current_expand
.base
;
1800 current_expand
= expand_save
;
1806 /* Work function for checking that an element of a constructor is a
1807 constant, after removal of any iteration variables. We return
1811 is_constant_element (gfc_expr
*e
)
1815 rv
= gfc_is_constant_expr (e
);
1818 return rv
? true : false;
1822 /* Given an array constructor, determine if the constructor is
1823 constant or not by expanding it and making sure that all elements
1824 are constants. This is a bit of a hack since something like (/ (i,
1825 i=1,100000000) /) will take a while as* opposed to a more clever
1826 function that traverses the expression tree. FIXME. */
1829 gfc_constant_ac (gfc_expr
*e
)
1831 expand_info expand_save
;
1835 expand_save
= current_expand
;
1836 current_expand
.expand_work_function
= is_constant_element
;
1838 rc
= expand_constructor (e
->value
.constructor
);
1840 current_expand
= expand_save
;
1848 /* Returns nonzero if an array constructor has been completely
1849 expanded (no iterators) and zero if iterators are present. */
1852 gfc_expanded_ac (gfc_expr
*e
)
1856 if (e
->expr_type
== EXPR_ARRAY
)
1857 for (c
= gfc_constructor_first (e
->value
.constructor
);
1858 c
; c
= gfc_constructor_next (c
))
1859 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1866 /*************** Type resolution of array constructors ***************/
1869 /* The symbol expr_is_sought_symbol_ref will try to find. */
1870 static const gfc_symbol
*sought_symbol
= NULL
;
1873 /* Tells whether the expression E is a variable reference to the symbol
1874 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1876 To be used with gfc_expr_walker: if a reference is found we don't need
1877 to look further so we return 1 to skip any further walk. */
1880 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1883 gfc_expr
*expr
= *e
;
1884 locus
*sym_loc
= (locus
*)where
;
1886 if (expr
->expr_type
== EXPR_VARIABLE
1887 && expr
->symtree
->n
.sym
== sought_symbol
)
1889 *sym_loc
= expr
->where
;
1897 /* Tells whether the expression EXPR contains a reference to the symbol
1898 SYM and in that case sets the position SYM_LOC where the reference is. */
1901 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
1905 sought_symbol
= sym
;
1906 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
1907 sought_symbol
= NULL
;
1912 /* Recursive array list resolution function. All of the elements must
1913 be of the same type. */
1916 resolve_array_list (gfc_constructor_base base
)
1924 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1929 gfc_symbol
*iter_var
;
1932 if (!gfc_resolve_iterator (iter
, false, true))
1935 /* Check for bounds referencing the iterator variable. */
1936 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
1937 iter_var
= iter
->var
->symtree
->n
.sym
;
1938 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
1940 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
1941 "expression references control variable "
1942 "at %L", &iter_var_loc
))
1945 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
1947 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
1948 "expression references control variable "
1949 "at %L", &iter_var_loc
))
1952 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
1954 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
1955 "expression references control variable "
1956 "at %L", &iter_var_loc
))
1961 if (!gfc_resolve_expr (c
->expr
))
1964 if (UNLIMITED_POLY (c
->expr
))
1966 gfc_error ("Array constructor value at %L shall not be unlimited "
1967 "polymorphic [F2008: C4106]", &c
->expr
->where
);
1975 /* Resolve character array constructor. If it has a specified constant character
1976 length, pad/truncate the elements here; if the length is not specified and
1977 all elements are of compile-time known length, emit an error as this is
1981 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
1984 HOST_WIDE_INT found_length
;
1986 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
1987 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
1989 if (expr
->ts
.u
.cl
== NULL
)
1991 for (p
= gfc_constructor_first (expr
->value
.constructor
);
1992 p
; p
= gfc_constructor_next (p
))
1993 if (p
->expr
->ts
.u
.cl
!= NULL
)
1995 /* Ensure that if there is a char_len around that it is
1996 used; otherwise the middle-end confuses them! */
1997 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2001 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2006 /* Early exit for zero size arrays. */
2010 HOST_WIDE_INT arraysize
;
2012 gfc_array_size (expr
, &size
);
2013 arraysize
= mpz_get_ui (size
);
2022 if (expr
->ts
.u
.cl
->length
== NULL
)
2024 /* Check that all constant string elements have the same length until
2025 we reach the end or find a variable-length one. */
2027 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2028 p
; p
= gfc_constructor_next (p
))
2030 HOST_WIDE_INT current_length
= -1;
2032 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2033 if (ref
->type
== REF_SUBSTRING
2034 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2035 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2038 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2039 current_length
= p
->expr
->value
.character
.length
;
2041 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2042 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2043 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2044 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2045 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2049 if (current_length
< 0)
2052 if (found_length
== -1)
2053 found_length
= current_length
;
2054 else if (found_length
!= current_length
)
2056 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2057 " constructor at %L", (long) found_length
,
2058 (long) current_length
, &p
->expr
->where
);
2062 gcc_assert (found_length
== current_length
);
2065 gcc_assert (found_length
!= -1);
2067 /* Update the character length of the array constructor. */
2068 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2069 NULL
, found_length
);
2073 /* We've got a character length specified. It should be an integer,
2074 otherwise an error is signalled elsewhere. */
2075 gcc_assert (expr
->ts
.u
.cl
->length
);
2077 /* If we've got a constant character length, pad according to this.
2078 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2079 max_length only if they pass. */
2080 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2082 /* Now pad/truncate the elements accordingly to the specified character
2083 length. This is ok inside this conditional, as in the case above
2084 (without typespec) all elements are verified to have the same length
2086 if (found_length
!= -1)
2087 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2088 p
; p
= gfc_constructor_next (p
))
2089 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2091 gfc_expr
*cl
= NULL
;
2092 HOST_WIDE_INT current_length
= -1;
2095 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2097 cl
= p
->expr
->ts
.u
.cl
->length
;
2098 gfc_extract_hwi (cl
, ¤t_length
);
2101 /* If gfc_extract_int above set current_length, we implicitly
2102 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2104 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2107 || (current_length
!= -1 && current_length
!= found_length
))
2108 gfc_set_constant_character_len (found_length
, p
->expr
,
2109 has_ts
? -1 : found_length
);
2117 /* Resolve all of the expressions in an array list. */
2120 gfc_resolve_array_constructor (gfc_expr
*expr
)
2124 t
= resolve_array_list (expr
->value
.constructor
);
2126 t
= gfc_check_constructor_type (expr
);
2128 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2129 the call to this function, so we don't need to call it here; if it was
2130 called twice, an error message there would be duplicated. */
2136 /* Copy an iterator structure. */
2139 gfc_copy_iterator (gfc_iterator
*src
)
2146 dest
= gfc_get_iterator ();
2148 dest
->var
= gfc_copy_expr (src
->var
);
2149 dest
->start
= gfc_copy_expr (src
->start
);
2150 dest
->end
= gfc_copy_expr (src
->end
);
2151 dest
->step
= gfc_copy_expr (src
->step
);
2152 dest
->unroll
= src
->unroll
;
2158 /********* Subroutines for determining the size of an array *********/
2160 /* These are needed just to accommodate RESHAPE(). There are no
2161 diagnostics here, we just return a negative number if something
2165 /* Get the size of single dimension of an array specification. The
2166 array is guaranteed to be one dimensional. */
2169 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2174 if (dimen
< 0 || dimen
> as
->rank
- 1)
2175 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2177 if (as
->type
!= AS_EXPLICIT
2178 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2179 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2180 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2181 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2186 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2187 as
->lower
[dimen
]->value
.integer
);
2189 mpz_add_ui (*result
, *result
, 1);
2196 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2201 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2204 mpz_init_set_ui (*result
, 1);
2206 for (d
= 0; d
< as
->rank
; d
++)
2208 if (!spec_dimen_size (as
, d
, &size
))
2210 mpz_clear (*result
);
2214 mpz_mul (*result
, *result
, size
);
2222 /* Get the number of elements in an array section. Optionally, also supply
2226 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2228 mpz_t upper
, lower
, stride
;
2231 gfc_expr
*stride_expr
= NULL
;
2233 if (dimen
< 0 || ar
== NULL
)
2234 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2236 if (dimen
> ar
->dimen
- 1)
2238 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2242 switch (ar
->dimen_type
[dimen
])
2246 mpz_set_ui (*result
, 1);
2251 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2258 if (ar
->stride
[dimen
] == NULL
)
2259 mpz_set_ui (stride
, 1);
2262 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2264 if(!gfc_simplify_expr(stride_expr
, 1))
2265 gfc_internal_error("Simplification error");
2267 if (stride_expr
->expr_type
!= EXPR_CONSTANT
2268 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2273 mpz_set (stride
, stride_expr
->value
.integer
);
2274 gfc_free_expr(stride_expr
);
2277 /* Calculate the number of elements via gfc_dep_differce, but only if
2278 start and end are both supplied in the reference or the array spec.
2279 This is to guard against strange but valid code like
2284 print *,size(a(n-1:))
2286 where the user changes the value of a variable. If we have to
2287 determine end as well, we cannot do this using gfc_dep_difference.
2288 Fall back to the constants-only code then. */
2294 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2296 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2297 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2298 ar
->as
->lower
[dimen
], &diff
);
2303 mpz_add (*result
, diff
, stride
);
2304 mpz_div (*result
, *result
, stride
);
2305 if (mpz_cmp_ui (*result
, 0) < 0)
2306 mpz_set_ui (*result
, 0);
2315 /* Constant-only code here, which covers more cases
2321 if (ar
->start
[dimen
] == NULL
)
2323 if (ar
->as
->lower
[dimen
] == NULL
2324 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2325 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2327 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2331 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2333 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2336 if (ar
->end
[dimen
] == NULL
)
2338 if (ar
->as
->upper
[dimen
] == NULL
2339 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2340 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2342 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2346 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2348 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2352 mpz_sub (*result
, upper
, lower
);
2353 mpz_add (*result
, *result
, stride
);
2354 mpz_div (*result
, *result
, stride
);
2356 /* Zero stride caught earlier. */
2357 if (mpz_cmp_ui (*result
, 0) < 0)
2358 mpz_set_ui (*result
, 0);
2365 mpz_sub_ui (*end
, *result
, 1UL);
2366 mpz_mul (*end
, *end
, stride
);
2367 mpz_add (*end
, *end
, lower
);
2377 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2385 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2390 mpz_init_set_ui (*result
, 1);
2392 for (d
= 0; d
< ar
->dimen
; d
++)
2394 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2396 mpz_clear (*result
);
2400 mpz_mul (*result
, *result
, size
);
2408 /* Given an array expression and a dimension, figure out how many
2409 elements it has along that dimension. Returns true if we were
2410 able to return a result in the 'result' variable, false
2414 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2419 gcc_assert (array
!= NULL
);
2421 if (array
->ts
.type
== BT_CLASS
)
2424 if (array
->rank
== -1)
2427 if (dimen
< 0 || dimen
> array
->rank
- 1)
2428 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2430 switch (array
->expr_type
)
2434 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2436 if (ref
->type
!= REF_ARRAY
)
2439 if (ref
->u
.ar
.type
== AR_FULL
)
2440 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2442 if (ref
->u
.ar
.type
== AR_SECTION
)
2444 for (i
= 0; dimen
>= 0; i
++)
2445 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2448 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2452 if (array
->shape
&& array
->shape
[dimen
])
2454 mpz_init_set (*result
, array
->shape
[dimen
]);
2458 if (array
->symtree
->n
.sym
->attr
.generic
2459 && array
->value
.function
.esym
!= NULL
)
2461 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2464 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2470 if (array
->shape
== NULL
) {
2471 /* Expressions with rank > 1 should have "shape" properly set */
2472 if ( array
->rank
!= 1 )
2473 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2474 return gfc_array_size(array
, result
);
2479 if (array
->shape
== NULL
)
2482 mpz_init_set (*result
, array
->shape
[dimen
]);
2491 /* Given an array expression, figure out how many elements are in the
2492 array. Returns true if this is possible, and sets the 'result'
2493 variable. Otherwise returns false. */
2496 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2498 expand_info expand_save
;
2503 if (array
->ts
.type
== BT_CLASS
)
2506 switch (array
->expr_type
)
2509 gfc_push_suppress_errors ();
2511 expand_save
= current_expand
;
2513 current_expand
.count
= result
;
2514 mpz_init_set_ui (*result
, 0);
2516 current_expand
.expand_work_function
= count_elements
;
2519 t
= expand_constructor (array
->value
.constructor
);
2521 gfc_pop_suppress_errors ();
2524 mpz_clear (*result
);
2525 current_expand
= expand_save
;
2529 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2531 if (ref
->type
!= REF_ARRAY
)
2534 if (ref
->u
.ar
.type
== AR_FULL
)
2535 return spec_size (ref
->u
.ar
.as
, result
);
2537 if (ref
->u
.ar
.type
== AR_SECTION
)
2538 return ref_size (&ref
->u
.ar
, result
);
2541 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2545 if (array
->rank
== 0 || array
->shape
== NULL
)
2548 mpz_init_set_ui (*result
, 1);
2550 for (i
= 0; i
< array
->rank
; i
++)
2551 mpz_mul (*result
, *result
, array
->shape
[i
]);
2560 /* Given an array reference, return the shape of the reference in an
2561 array of mpz_t integers. */
2564 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2574 for (; d
< ar
->as
->rank
; d
++)
2575 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2581 for (i
= 0; i
< ar
->dimen
; i
++)
2583 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2585 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2598 gfc_clear_shape (shape
, d
);
2603 /* Given an array expression, find the array reference structure that
2604 characterizes the reference. */
2607 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2611 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2612 if (ref
->type
== REF_ARRAY
2613 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2621 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2628 /* Find out if an array shape is known at compile time. */
2631 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2633 if (as
->type
!= AS_EXPLICIT
)
2636 for (int i
= 0; i
< as
->rank
; i
++)
2637 if (!gfc_is_constant_expr (as
->lower
[i
])
2638 || !gfc_is_constant_expr (as
->upper
[i
]))