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
);
2008 if (expr
->ts
.u
.cl
->length
== NULL
)
2010 /* Check that all constant string elements have the same length until
2011 we reach the end or find a variable-length one. */
2013 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2014 p
; p
= gfc_constructor_next (p
))
2016 HOST_WIDE_INT current_length
= -1;
2018 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2019 if (ref
->type
== REF_SUBSTRING
2020 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2021 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2024 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2025 current_length
= p
->expr
->value
.character
.length
;
2027 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2028 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2029 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2030 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2031 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2035 gcc_assert (current_length
!= -1);
2037 if (found_length
== -1)
2038 found_length
= current_length
;
2039 else if (found_length
!= current_length
)
2041 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2042 " constructor at %L", (long) found_length
,
2043 (long) current_length
, &p
->expr
->where
);
2047 gcc_assert (found_length
== current_length
);
2050 gcc_assert (found_length
!= -1);
2052 /* Update the character length of the array constructor. */
2053 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2054 NULL
, found_length
);
2058 /* We've got a character length specified. It should be an integer,
2059 otherwise an error is signalled elsewhere. */
2060 gcc_assert (expr
->ts
.u
.cl
->length
);
2062 /* If we've got a constant character length, pad according to this.
2063 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2064 max_length only if they pass. */
2065 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2067 /* Now pad/truncate the elements accordingly to the specified character
2068 length. This is ok inside this conditional, as in the case above
2069 (without typespec) all elements are verified to have the same length
2071 if (found_length
!= -1)
2072 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2073 p
; p
= gfc_constructor_next (p
))
2074 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2076 gfc_expr
*cl
= NULL
;
2077 HOST_WIDE_INT current_length
= -1;
2080 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2082 cl
= p
->expr
->ts
.u
.cl
->length
;
2083 gfc_extract_hwi (cl
, ¤t_length
);
2086 /* If gfc_extract_int above set current_length, we implicitly
2087 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2089 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2092 || (current_length
!= -1 && current_length
!= found_length
))
2093 gfc_set_constant_character_len (found_length
, p
->expr
,
2094 has_ts
? -1 : found_length
);
2102 /* Resolve all of the expressions in an array list. */
2105 gfc_resolve_array_constructor (gfc_expr
*expr
)
2109 t
= resolve_array_list (expr
->value
.constructor
);
2111 t
= gfc_check_constructor_type (expr
);
2113 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2114 the call to this function, so we don't need to call it here; if it was
2115 called twice, an error message there would be duplicated. */
2121 /* Copy an iterator structure. */
2124 gfc_copy_iterator (gfc_iterator
*src
)
2131 dest
= gfc_get_iterator ();
2133 dest
->var
= gfc_copy_expr (src
->var
);
2134 dest
->start
= gfc_copy_expr (src
->start
);
2135 dest
->end
= gfc_copy_expr (src
->end
);
2136 dest
->step
= gfc_copy_expr (src
->step
);
2137 dest
->unroll
= src
->unroll
;
2143 /********* Subroutines for determining the size of an array *********/
2145 /* These are needed just to accommodate RESHAPE(). There are no
2146 diagnostics here, we just return a negative number if something
2150 /* Get the size of single dimension of an array specification. The
2151 array is guaranteed to be one dimensional. */
2154 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2159 if (dimen
< 0 || dimen
> as
->rank
- 1)
2160 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2162 if (as
->type
!= AS_EXPLICIT
2163 || as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2164 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2165 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2166 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2171 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2172 as
->lower
[dimen
]->value
.integer
);
2174 mpz_add_ui (*result
, *result
, 1);
2181 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2186 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2189 mpz_init_set_ui (*result
, 1);
2191 for (d
= 0; d
< as
->rank
; d
++)
2193 if (!spec_dimen_size (as
, d
, &size
))
2195 mpz_clear (*result
);
2199 mpz_mul (*result
, *result
, size
);
2207 /* Get the number of elements in an array section. Optionally, also supply
2211 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2213 mpz_t upper
, lower
, stride
;
2216 gfc_expr
*stride_expr
= NULL
;
2218 if (dimen
< 0 || ar
== NULL
)
2219 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2221 if (dimen
> ar
->dimen
- 1)
2223 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2227 switch (ar
->dimen_type
[dimen
])
2231 mpz_set_ui (*result
, 1);
2236 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2243 if (ar
->stride
[dimen
] == NULL
)
2244 mpz_set_ui (stride
, 1);
2247 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2249 if(!gfc_simplify_expr(stride_expr
, 1))
2250 gfc_internal_error("Simplification error");
2252 if (stride_expr
->expr_type
!= EXPR_CONSTANT
2253 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2258 mpz_set (stride
, stride_expr
->value
.integer
);
2259 gfc_free_expr(stride_expr
);
2262 /* Calculate the number of elements via gfc_dep_differce, but only if
2263 start and end are both supplied in the reference or the array spec.
2264 This is to guard against strange but valid code like
2269 print *,size(a(n-1:))
2271 where the user changes the value of a variable. If we have to
2272 determine end as well, we cannot do this using gfc_dep_difference.
2273 Fall back to the constants-only code then. */
2279 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2281 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2282 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2283 ar
->as
->lower
[dimen
], &diff
);
2288 mpz_add (*result
, diff
, stride
);
2289 mpz_div (*result
, *result
, stride
);
2290 if (mpz_cmp_ui (*result
, 0) < 0)
2291 mpz_set_ui (*result
, 0);
2300 /* Constant-only code here, which covers more cases
2306 if (ar
->start
[dimen
] == NULL
)
2308 if (ar
->as
->lower
[dimen
] == NULL
2309 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2310 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2312 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2316 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2318 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2321 if (ar
->end
[dimen
] == NULL
)
2323 if (ar
->as
->upper
[dimen
] == NULL
2324 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2325 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2327 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2331 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2333 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2337 mpz_sub (*result
, upper
, lower
);
2338 mpz_add (*result
, *result
, stride
);
2339 mpz_div (*result
, *result
, stride
);
2341 /* Zero stride caught earlier. */
2342 if (mpz_cmp_ui (*result
, 0) < 0)
2343 mpz_set_ui (*result
, 0);
2350 mpz_sub_ui (*end
, *result
, 1UL);
2351 mpz_mul (*end
, *end
, stride
);
2352 mpz_add (*end
, *end
, lower
);
2362 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2370 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2375 mpz_init_set_ui (*result
, 1);
2377 for (d
= 0; d
< ar
->dimen
; d
++)
2379 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2381 mpz_clear (*result
);
2385 mpz_mul (*result
, *result
, size
);
2393 /* Given an array expression and a dimension, figure out how many
2394 elements it has along that dimension. Returns true if we were
2395 able to return a result in the 'result' variable, false
2399 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2404 gcc_assert (array
!= NULL
);
2406 if (array
->ts
.type
== BT_CLASS
)
2409 if (array
->rank
== -1)
2412 if (dimen
< 0 || dimen
> array
->rank
- 1)
2413 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2415 switch (array
->expr_type
)
2419 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2421 if (ref
->type
!= REF_ARRAY
)
2424 if (ref
->u
.ar
.type
== AR_FULL
)
2425 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2427 if (ref
->u
.ar
.type
== AR_SECTION
)
2429 for (i
= 0; dimen
>= 0; i
++)
2430 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2433 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2437 if (array
->shape
&& array
->shape
[dimen
])
2439 mpz_init_set (*result
, array
->shape
[dimen
]);
2443 if (array
->symtree
->n
.sym
->attr
.generic
2444 && array
->value
.function
.esym
!= NULL
)
2446 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2449 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2455 if (array
->shape
== NULL
) {
2456 /* Expressions with rank > 1 should have "shape" properly set */
2457 if ( array
->rank
!= 1 )
2458 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2459 return gfc_array_size(array
, result
);
2464 if (array
->shape
== NULL
)
2467 mpz_init_set (*result
, array
->shape
[dimen
]);
2476 /* Given an array expression, figure out how many elements are in the
2477 array. Returns true if this is possible, and sets the 'result'
2478 variable. Otherwise returns false. */
2481 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2483 expand_info expand_save
;
2488 if (array
->ts
.type
== BT_CLASS
)
2491 switch (array
->expr_type
)
2494 gfc_push_suppress_errors ();
2496 expand_save
= current_expand
;
2498 current_expand
.count
= result
;
2499 mpz_init_set_ui (*result
, 0);
2501 current_expand
.expand_work_function
= count_elements
;
2504 t
= expand_constructor (array
->value
.constructor
);
2506 gfc_pop_suppress_errors ();
2509 mpz_clear (*result
);
2510 current_expand
= expand_save
;
2514 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2516 if (ref
->type
!= REF_ARRAY
)
2519 if (ref
->u
.ar
.type
== AR_FULL
)
2520 return spec_size (ref
->u
.ar
.as
, result
);
2522 if (ref
->u
.ar
.type
== AR_SECTION
)
2523 return ref_size (&ref
->u
.ar
, result
);
2526 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2530 if (array
->rank
== 0 || array
->shape
== NULL
)
2533 mpz_init_set_ui (*result
, 1);
2535 for (i
= 0; i
< array
->rank
; i
++)
2536 mpz_mul (*result
, *result
, array
->shape
[i
]);
2545 /* Given an array reference, return the shape of the reference in an
2546 array of mpz_t integers. */
2549 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2559 for (; d
< ar
->as
->rank
; d
++)
2560 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2566 for (i
= 0; i
< ar
->dimen
; i
++)
2568 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2570 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2583 gfc_clear_shape (shape
, d
);
2588 /* Given an array expression, find the array reference structure that
2589 characterizes the reference. */
2592 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2596 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2597 if (ref
->type
== REF_ARRAY
2598 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2606 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2613 /* Find out if an array shape is known at compile time. */
2616 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2618 if (as
->type
!= AS_EXPLICIT
)
2621 for (int i
= 0; i
< as
->rank
; i
++)
2622 if (!gfc_is_constant_expr (as
->lower
[i
])
2623 || !gfc_is_constant_expr (as
->upper
[i
]))