2 Copyright (C) 2000-2022 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"
28 #include "constructor.h"
30 /**************** Array reference matching subroutines *****************/
32 /* Copy an array reference structure. */
35 gfc_copy_array_ref (gfc_array_ref
*src
)
43 dest
= gfc_get_array_ref ();
47 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
49 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
50 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
51 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
58 /* Match a single dimension of an array reference. This can be a
59 single element or an array section. Any modifications we've made
60 to the ar structure are cleaned up by the caller. If the init
61 is set, we require the subscript to be a valid initialization
65 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
67 match m
= MATCH_ERROR
;
72 i
= ar
->dimen
+ ar
->codimen
;
74 gfc_gobble_whitespace ();
75 ar
->c_where
[i
] = gfc_current_locus
;
76 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
78 /* We can't be sure of the difference between DIMEN_ELEMENT and
79 DIMEN_VECTOR until we know the type of the element itself at
82 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
84 if (gfc_match_char (':') == MATCH_YES
)
87 /* Get start element. */
88 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
92 m
= gfc_match_init_expr (&ar
->start
[i
]);
94 m
= gfc_match_expr (&ar
->start
[i
]);
96 if (ar
->start
[i
] && ar
->start
[i
]->ts
.type
== BT_BOZ
)
98 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
103 gfc_error ("Expected array subscript at %C");
107 if (gfc_match_char (':') == MATCH_NO
)
112 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
116 /* Get an optional end element. Because we've seen the colon, we
117 definitely have a range along this dimension. */
119 ar
->dimen_type
[i
] = DIMEN_RANGE
;
121 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
124 m
= gfc_match_init_expr (&ar
->end
[i
]);
126 m
= gfc_match_expr (&ar
->end
[i
]);
128 if (ar
->end
[i
] && ar
->end
[i
]->ts
.type
== BT_BOZ
)
130 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
134 if (m
== MATCH_ERROR
)
137 /* See if we have an optional stride. */
138 if (gfc_match_char (':') == MATCH_YES
)
142 gfc_error ("Strides not allowed in coarray subscript at %C");
146 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
147 : gfc_match_expr (&ar
->stride
[i
]);
149 if (ar
->stride
[i
] && ar
->stride
[i
]->ts
.type
== BT_BOZ
)
151 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
156 gfc_error ("Expected array subscript stride at %C");
163 ar
->dimen_type
[i
] = DIMEN_STAR
;
165 return (saw_boz
? MATCH_ERROR
: MATCH_YES
);
169 /* Match an array reference, whether it is the whole array or particular
170 elements or a section. If init is set, the reference has to consist
171 of init expressions. */
174 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
178 bool matched_bracket
= false;
180 bool stat_just_seen
= false;
181 bool team_just_seen
= false;
183 memset (ar
, '\0', sizeof (*ar
));
185 ar
->where
= gfc_current_locus
;
187 ar
->type
= AR_UNKNOWN
;
189 if (gfc_match_char ('[') == MATCH_YES
)
191 matched_bracket
= true;
195 if (gfc_match_char ('(') != MATCH_YES
)
202 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
204 m
= match_subscript (ar
, init
, false);
205 if (m
== MATCH_ERROR
)
208 if (gfc_match_char (')') == MATCH_YES
)
214 if (gfc_match_char (',') != MATCH_YES
)
216 gfc_error ("Invalid form of array reference at %C");
222 && !gfc_notify_std (GFC_STD_F2008
,
223 "Array reference at %C has more than 7 dimensions"))
226 gfc_error ("Array reference at %C cannot have more than %d dimensions",
231 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
239 if (flag_coarray
== GFC_FCOARRAY_NONE
)
241 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
247 gfc_error ("Unexpected coarray designator at %C");
253 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
255 m
= match_subscript (ar
, init
, true);
256 if (m
== MATCH_ERROR
)
259 team_just_seen
= false;
260 stat_just_seen
= false;
261 if (gfc_match (" , team = %e", &tmp
) == MATCH_YES
&& ar
->team
== NULL
)
264 team_just_seen
= true;
267 if (ar
->team
&& !team_just_seen
)
269 gfc_error ("TEAM= attribute in %C misplaced");
273 if (gfc_match (" , stat = %e",&tmp
) == MATCH_YES
&& ar
->stat
== NULL
)
276 stat_just_seen
= true;
279 if (ar
->stat
&& !stat_just_seen
)
281 gfc_error ("STAT= attribute in %C misplaced");
285 if (gfc_match_char (']') == MATCH_YES
)
288 if (ar
->codimen
< corank
)
290 gfc_error ("Too few codimensions at %C, expected %d not %d",
291 corank
, ar
->codimen
);
294 if (ar
->codimen
> corank
)
296 gfc_error ("Too many codimensions at %C, expected %d not %d",
297 corank
, ar
->codimen
);
303 if (gfc_match_char (',') != MATCH_YES
)
305 if (gfc_match_char ('*') == MATCH_YES
)
306 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
307 ar
->codimen
+ 1, corank
);
309 gfc_error ("Invalid form of coarray reference at %C");
312 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
314 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
315 ar
->codimen
+ 1, corank
);
319 if (ar
->codimen
>= corank
)
321 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
322 ar
->codimen
+ 1, corank
);
327 gfc_error ("Array reference at %C cannot have more than %d dimensions",
334 /************** Array specification matching subroutines ***************/
336 /* Free all of the expressions associated with array bounds
340 gfc_free_array_spec (gfc_array_spec
*as
)
349 for (i
= 0; i
< as
->rank
; i
++)
351 gfc_free_expr (as
->lower
[i
]);
352 gfc_free_expr (as
->upper
[i
]);
357 int n
= as
->rank
+ as
->corank
- (as
->cotype
== AS_EXPLICIT
? 1 : 0);
358 for (i
= 0; i
< n
; i
++)
360 gfc_free_expr (as
->lower
[i
]);
361 gfc_free_expr (as
->upper
[i
]);
369 /* Take an array bound, resolves the expression, that make up the
370 shape and check associated constraints. */
373 resolve_array_bound (gfc_expr
*e
, int check_constant
)
378 if (!gfc_resolve_expr (e
)
379 || !gfc_specification_expr (e
))
382 if (check_constant
&& !gfc_is_constant_expr (e
))
384 if (e
->expr_type
== EXPR_VARIABLE
)
385 gfc_error ("Variable %qs at %L in this context must be constant",
386 e
->symtree
->n
.sym
->name
, &e
->where
);
388 gfc_error ("Expression at %L in this context must be constant",
397 /* Takes an array specification, resolves the expressions that make up
398 the shape and make sure everything is integral. */
401 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
412 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
414 if (i
== GFC_MAX_DIMENSIONS
)
418 if (!resolve_array_bound (e
, check_constant
))
422 if (!resolve_array_bound (e
, check_constant
))
425 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
428 /* If the size is negative in this dimension, set it to zero. */
429 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
430 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
431 && mpz_cmp (as
->upper
[i
]->value
.integer
,
432 as
->lower
[i
]->value
.integer
) < 0)
434 gfc_free_expr (as
->upper
[i
]);
435 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
436 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
437 as
->upper
[i
]->value
.integer
, 1);
447 /* Match a single array element specification. The return values as
448 well as the upper and lower bounds of the array spec are filled
449 in according to what we see on the input. The caller makes sure
450 individual specifications make sense as a whole.
453 Parsed Lower Upper Returned
454 ------------------------------------
455 : NULL NULL AS_DEFERRED (*)
457 x: x NULL AS_ASSUMED_SHAPE
459 x:* x NULL AS_ASSUMED_SIZE
460 * 1 NULL AS_ASSUMED_SIZE
462 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
463 is fixed during the resolution of formal interfaces.
465 Anything else AS_UNKNOWN. */
468 match_array_element_spec (gfc_array_spec
*as
)
470 gfc_expr
**upper
, **lower
;
474 rank
= as
->rank
== -1 ? 0 : as
->rank
;
475 lower
= &as
->lower
[rank
+ as
->corank
- 1];
476 upper
= &as
->upper
[rank
+ as
->corank
- 1];
478 if (gfc_match_char ('*') == MATCH_YES
)
480 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
481 return AS_ASSUMED_SIZE
;
484 if (gfc_match_char (':') == MATCH_YES
)
487 m
= gfc_match_expr (upper
);
489 gfc_error ("Expected expression in array specification at %C");
492 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
495 gfc_try_simplify_expr (*upper
, 0);
497 if (((*upper
)->expr_type
== EXPR_CONSTANT
498 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
499 ((*upper
)->expr_type
== EXPR_FUNCTION
500 && (*upper
)->ts
.type
== BT_UNKNOWN
502 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
504 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
505 gfc_basic_typename ((*upper
)->ts
.type
));
509 if (gfc_match_char (':') == MATCH_NO
)
511 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
518 if (gfc_match_char ('*') == MATCH_YES
)
519 return AS_ASSUMED_SIZE
;
521 m
= gfc_match_expr (upper
);
522 if (m
== MATCH_ERROR
)
525 return AS_ASSUMED_SHAPE
;
526 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
529 gfc_try_simplify_expr (*upper
, 0);
531 if (((*upper
)->expr_type
== EXPR_CONSTANT
532 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
533 ((*upper
)->expr_type
== EXPR_FUNCTION
534 && (*upper
)->ts
.type
== BT_UNKNOWN
536 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
538 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
539 gfc_basic_typename ((*upper
)->ts
.type
));
547 /* Matches an array specification, incidentally figuring out what sort
548 it is. Match either a normal array specification, or a coarray spec
549 or both. Optionally allow [:] for coarrays. */
552 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
554 array_type current_type
;
558 as
= gfc_get_array_spec ();
563 if (gfc_match_char ('(') != MATCH_YES
)
570 if (gfc_match (" .. )") == MATCH_YES
)
572 as
->type
= AS_ASSUMED_RANK
;
575 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed-rank array at %C"))
586 current_type
= match_array_element_spec (as
);
588 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
589 and implied-shape specifications. If the rank is at least 2, we can
590 distinguish between them. But for rank 1, we currently return
591 ASSUMED_SIZE; this gets adjusted later when we know for sure
592 whether the symbol parsed is a PARAMETER or not. */
596 if (current_type
== AS_UNKNOWN
)
598 as
->type
= current_type
;
602 { /* See how current spec meshes with the existing. */
606 case AS_IMPLIED_SHAPE
:
607 if (current_type
!= AS_ASSUMED_SIZE
)
609 gfc_error ("Bad array specification for implied-shape"
616 if (current_type
== AS_ASSUMED_SIZE
)
618 as
->type
= AS_ASSUMED_SIZE
;
622 if (current_type
== AS_EXPLICIT
)
625 gfc_error ("Bad array specification for an explicitly shaped "
630 case AS_ASSUMED_SHAPE
:
631 if ((current_type
== AS_ASSUMED_SHAPE
)
632 || (current_type
== AS_DEFERRED
))
635 gfc_error ("Bad array specification for assumed shape "
640 if (current_type
== AS_DEFERRED
)
643 if (current_type
== AS_ASSUMED_SHAPE
)
645 as
->type
= AS_ASSUMED_SHAPE
;
649 gfc_error ("Bad specification for deferred shape array at %C");
652 case AS_ASSUMED_SIZE
:
653 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
655 as
->type
= AS_IMPLIED_SHAPE
;
659 gfc_error ("Bad specification for assumed size array at %C");
662 case AS_ASSUMED_RANK
:
666 if (gfc_match_char (')') == MATCH_YES
)
669 if (gfc_match_char (',') != MATCH_YES
)
671 gfc_error ("Expected another dimension in array declaration at %C");
675 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
677 gfc_error ("Array specification at %C has more than %d dimensions",
682 if (as
->corank
+ as
->rank
>= 7
683 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
684 "with more than 7 dimensions"))
692 if (gfc_match_char ('[') != MATCH_YES
)
695 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
698 if (flag_coarray
== GFC_FCOARRAY_NONE
)
700 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
704 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
706 gfc_error ("Array specification at %C has more than %d "
707 "dimensions", GFC_MAX_DIMENSIONS
);
714 current_type
= match_array_element_spec (as
);
716 if (current_type
== AS_UNKNOWN
)
720 as
->cotype
= current_type
;
723 { /* See how current spec meshes with the existing. */
724 case AS_IMPLIED_SHAPE
:
729 if (current_type
== AS_ASSUMED_SIZE
)
731 as
->cotype
= AS_ASSUMED_SIZE
;
735 if (current_type
== AS_EXPLICIT
)
738 gfc_error ("Bad array specification for an explicitly "
739 "shaped array at %C");
743 case AS_ASSUMED_SHAPE
:
744 if ((current_type
== AS_ASSUMED_SHAPE
)
745 || (current_type
== AS_DEFERRED
))
748 gfc_error ("Bad array specification for assumed shape "
753 if (current_type
== AS_DEFERRED
)
756 if (current_type
== AS_ASSUMED_SHAPE
)
758 as
->cotype
= AS_ASSUMED_SHAPE
;
762 gfc_error ("Bad specification for deferred shape array at %C");
765 case AS_ASSUMED_SIZE
:
766 gfc_error ("Bad specification for assumed size array at %C");
769 case AS_ASSUMED_RANK
:
773 if (gfc_match_char (']') == MATCH_YES
)
776 if (gfc_match_char (',') != MATCH_YES
)
778 gfc_error ("Expected another dimension in array declaration at %C");
782 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
784 gfc_error ("Array specification at %C has more than %d "
785 "dimensions", GFC_MAX_DIMENSIONS
);
790 if (current_type
== AS_EXPLICIT
)
792 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
796 if (as
->cotype
== AS_ASSUMED_SIZE
)
797 as
->cotype
= AS_EXPLICIT
;
800 as
->type
= as
->cotype
;
803 if (as
->rank
== 0 && as
->corank
== 0)
806 gfc_free_array_spec (as
);
810 /* If a lower bounds of an assumed shape array is blank, put in one. */
811 if (as
->type
== AS_ASSUMED_SHAPE
)
813 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
815 if (as
->lower
[i
] == NULL
)
816 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
825 /* Something went wrong. */
826 gfc_free_array_spec (as
);
830 /* Given a symbol and an array specification, modify the symbol to
831 have that array specification. The error locus is needed in case
832 something goes wrong. On failure, the caller must free the spec. */
835 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
838 symbol_attribute
*attr
;
843 /* If the symbol corresponds to a submodule module procedure the array spec is
844 already set, so do not attempt to set it again here. */
846 if (gfc_submodule_procedure(attr
))
850 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
854 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
863 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
864 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
866 gfc_error ("The assumed-rank array %qs at %L shall not have a "
867 "codimension", sym
->name
, error_loc
);
871 /* Check F2018:C822. */
872 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
877 sym
->as
->cotype
= as
->cotype
;
878 sym
->as
->corank
= as
->corank
;
879 /* Check F2018:C822. */
880 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
883 for (i
= 0; i
< as
->corank
; i
++)
885 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
886 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
891 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
892 the dimension is added - but first the codimensions (if existing
893 need to be shifted to make space for the dimension. */
894 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
896 sym
->as
->rank
= as
->rank
;
897 sym
->as
->type
= as
->type
;
898 sym
->as
->cray_pointee
= as
->cray_pointee
;
899 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
901 /* Check F2018:C822. */
902 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
905 for (i
= sym
->as
->corank
- 1; i
>= 0; i
--)
907 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
908 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
910 for (i
= 0; i
< as
->rank
; i
++)
912 sym
->as
->lower
[i
] = as
->lower
[i
];
913 sym
->as
->upper
[i
] = as
->upper
[i
];
922 gfc_error ("rank + corank of %qs exceeds %d at %C", sym
->name
,
928 /* Copy an array specification. */
931 gfc_copy_array_spec (gfc_array_spec
*src
)
933 gfc_array_spec
*dest
;
939 dest
= gfc_get_array_spec ();
943 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
945 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
946 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
953 /* Returns nonzero if the two expressions are equal. Only handles integer
957 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
959 if (bound1
== NULL
|| bound2
== NULL
960 || bound1
->expr_type
!= EXPR_CONSTANT
961 || bound2
->expr_type
!= EXPR_CONSTANT
962 || bound1
->ts
.type
!= BT_INTEGER
963 || bound2
->ts
.type
!= BT_INTEGER
)
964 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
966 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
973 /* Compares two array specifications. They must be constant or deferred
977 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
981 if (as1
== NULL
&& as2
== NULL
)
984 if (as1
== NULL
|| as2
== NULL
)
987 if (as1
->rank
!= as2
->rank
)
990 if (as1
->corank
!= as2
->corank
)
996 if (as1
->type
!= as2
->type
)
999 if (as1
->type
== AS_EXPLICIT
)
1000 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
1002 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
1005 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
1013 /****************** Array constructor functions ******************/
1016 /* Given an expression node that might be an array constructor and a
1017 symbol, make sure that no iterators in this or child constructors
1018 use the symbol as an implied-DO iterator. Returns nonzero if a
1019 duplicate was found. */
1022 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
1027 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1031 if (e
->expr_type
== EXPR_ARRAY
1032 && check_duplicate_iterator (e
->value
.constructor
, master
))
1035 if (c
->iterator
== NULL
)
1038 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
1040 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1041 "same name", master
->name
, &c
->where
);
1051 /* Forward declaration because these functions are mutually recursive. */
1052 static match
match_array_cons_element (gfc_constructor_base
*);
1054 /* Match a list of array elements. */
1057 match_array_list (gfc_constructor_base
*result
)
1059 gfc_constructor_base head
;
1067 old_loc
= gfc_current_locus
;
1069 if (gfc_match_char ('(') == MATCH_NO
)
1072 memset (&iter
, '\0', sizeof (gfc_iterator
));
1075 m
= match_array_cons_element (&head
);
1079 if (gfc_match_char (',') != MATCH_YES
)
1087 m
= gfc_match_iterator (&iter
, 0);
1090 if (m
== MATCH_ERROR
)
1093 m
= match_array_cons_element (&head
);
1094 if (m
== MATCH_ERROR
)
1101 goto cleanup
; /* Could be a complex constant */
1104 if (gfc_match_char (',') != MATCH_YES
)
1113 if (gfc_match_char (')') != MATCH_YES
)
1116 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1122 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1123 e
->value
.constructor
= head
;
1125 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1126 p
->iterator
= gfc_get_iterator ();
1127 *p
->iterator
= iter
;
1132 gfc_error ("Syntax error in array constructor at %C");
1136 gfc_constructor_free (head
);
1137 gfc_free_iterator (&iter
, 0);
1138 gfc_current_locus
= old_loc
;
1143 /* Match a single element of an array constructor, which can be a
1144 single expression or a list of elements. */
1147 match_array_cons_element (gfc_constructor_base
*result
)
1152 m
= match_array_list (result
);
1156 m
= gfc_match_expr (&expr
);
1160 if (expr
->ts
.type
== BT_BOZ
)
1162 gfc_error ("BOZ literal constant at %L cannot appear in an "
1163 "array constructor", &expr
->where
);
1167 if (expr
->expr_type
== EXPR_FUNCTION
1168 && expr
->ts
.type
== BT_UNKNOWN
1169 && strcmp(expr
->symtree
->name
, "null") == 0)
1171 gfc_error ("NULL() at %C cannot appear in an array constructor");
1175 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1179 gfc_free_expr (expr
);
1184 /* Convert components of an array constructor to the type in ts. */
1187 walk_array_constructor (gfc_typespec
*ts
, gfc_constructor_base head
)
1193 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1196 if (e
->expr_type
== EXPR_ARRAY
&& e
->ts
.type
== BT_UNKNOWN
1197 && !e
->ref
&& e
->value
.constructor
)
1199 m
= walk_array_constructor (ts
, e
->value
.constructor
);
1200 if (m
== MATCH_ERROR
)
1203 else if (!gfc_convert_type_warn (e
, ts
, 1, 1, true)
1204 && e
->ts
.type
!= BT_UNKNOWN
)
1210 /* Match an array constructor. */
1213 gfc_match_array_constructor (gfc_expr
**result
)
1216 gfc_constructor_base head
;
1221 const char *end_delim
;
1227 if (gfc_match (" (/") == MATCH_NO
)
1229 if (gfc_match (" [") == MATCH_NO
)
1233 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1234 "style array constructors at %C"))
1242 where
= gfc_current_locus
;
1244 /* Try to match an optional "type-spec ::" */
1246 m
= gfc_match_type_spec (&ts
);
1249 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1253 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1254 "including type specification at %C"))
1259 gfc_error ("Type-spec at %L cannot contain a deferred "
1260 "type parameter", &where
);
1264 if (ts
.type
== BT_CHARACTER
1265 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1267 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1268 "type parameter", &where
);
1273 else if (m
== MATCH_ERROR
)
1277 gfc_current_locus
= where
;
1279 if (gfc_match (end_delim
) == MATCH_YES
)
1285 gfc_error ("Empty array constructor at %C is not allowed");
1292 m
= match_array_cons_element (&head
);
1293 if (m
== MATCH_ERROR
)
1298 if (gfc_match_char (',') == MATCH_NO
)
1302 if (gfc_match (end_delim
) == MATCH_NO
)
1306 /* Size must be calculated at resolution time. */
1309 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1312 /* If the typespec is CHARACTER, check that array elements can
1313 be converted. See PR fortran/67803. */
1314 if (ts
.type
== BT_CHARACTER
)
1316 c
= gfc_constructor_first (head
);
1317 for (; c
; c
= gfc_constructor_next (c
))
1319 if (gfc_numeric_ts (&c
->expr
->ts
)
1320 || c
->expr
->ts
.type
== BT_LOGICAL
)
1322 gfc_error ("Incompatible typespec for array element at %L",
1327 /* Special case null(). */
1328 if (c
->expr
->expr_type
== EXPR_FUNCTION
1329 && c
->expr
->ts
.type
== BT_UNKNOWN
1330 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1332 gfc_error ("Incompatible typespec for array element at %L",
1339 /* Walk the constructor, and if possible, do type conversion for
1341 if (gfc_numeric_ts (&ts
))
1343 m
= walk_array_constructor (&ts
, head
);
1344 if (m
== MATCH_ERROR
)
1349 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1351 expr
->value
.constructor
= head
;
1353 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1360 gfc_error ("Syntax error in array constructor at %C");
1363 gfc_constructor_free (head
);
1369 /************** Check array constructors for correctness **************/
1371 /* Given an expression, compare it's type with the type of the current
1372 constructor. Returns nonzero if an error was issued. The
1373 cons_state variable keeps track of whether the type of the
1374 constructor being read or resolved is known to be good, bad or just
1377 static gfc_typespec constructor_ts
;
1379 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1383 check_element_type (gfc_expr
*expr
, bool convert
)
1385 if (cons_state
== CONS_BAD
)
1386 return 0; /* Suppress further errors */
1388 if (cons_state
== CONS_START
)
1390 if (expr
->ts
.type
== BT_UNKNOWN
)
1391 cons_state
= CONS_BAD
;
1394 cons_state
= CONS_GOOD
;
1395 constructor_ts
= expr
->ts
;
1401 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1405 return gfc_convert_type_warn (expr
, &constructor_ts
, 1, 1, true) ? 0 : 1;
1407 gfc_error ("Element in %s array constructor at %L is %s",
1408 gfc_typename (&constructor_ts
), &expr
->where
,
1409 gfc_typename (expr
));
1411 cons_state
= CONS_BAD
;
1416 /* Recursive work function for gfc_check_constructor_type(). */
1419 check_constructor_type (gfc_constructor_base base
, bool convert
)
1424 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1428 if (e
->expr_type
== EXPR_ARRAY
)
1430 if (!check_constructor_type (e
->value
.constructor
, convert
))
1436 if (check_element_type (e
, convert
))
1444 /* Check that all elements of an array constructor are the same type.
1445 On false, an error has been generated. */
1448 gfc_check_constructor_type (gfc_expr
*e
)
1452 if (e
->ts
.type
!= BT_UNKNOWN
)
1454 cons_state
= CONS_GOOD
;
1455 constructor_ts
= e
->ts
;
1459 cons_state
= CONS_START
;
1460 gfc_clear_ts (&constructor_ts
);
1463 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1464 typespec, and we will now convert the values on the fly. */
1465 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1466 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1467 e
->ts
= constructor_ts
;
1474 typedef struct cons_stack
1476 gfc_iterator
*iterator
;
1477 struct cons_stack
*previous
;
1481 static cons_stack
*base
;
1483 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1485 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1486 that that variable is an iteration variable. */
1489 gfc_check_iter_variable (gfc_expr
*expr
)
1494 sym
= expr
->symtree
->n
.sym
;
1496 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1497 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1504 /* Recursive work function for gfc_check_constructor(). This amounts
1505 to calling the check function for each expression in the
1506 constructor, giving variables with the names of iterators a pass. */
1509 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1516 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1523 if (e
->expr_type
!= EXPR_ARRAY
)
1525 if (!(*check_function
)(e
))
1530 element
.previous
= base
;
1531 element
.iterator
= c
->iterator
;
1534 t
= check_constructor (e
->value
.constructor
, check_function
);
1535 base
= element
.previous
;
1541 /* Nothing went wrong, so all OK. */
1546 /* Checks a constructor to see if it is a particular kind of
1547 expression -- specification, restricted, or initialization as
1548 determined by the check_function. */
1551 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1553 cons_stack
*base_save
;
1559 t
= check_constructor (expr
->value
.constructor
, check_function
);
1567 /**************** Simplification of array constructors ****************/
1569 iterator_stack
*iter_stack
;
1573 gfc_constructor_base base
;
1574 int extract_count
, extract_n
;
1575 gfc_expr
*extracted
;
1579 gfc_component
*component
;
1582 bool (*expand_work_function
) (gfc_expr
*);
1586 static expand_info current_expand
;
1588 static bool expand_constructor (gfc_constructor_base
);
1591 /* Work function that counts the number of elements present in a
1595 count_elements (gfc_expr
*e
)
1600 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1603 if (!gfc_array_size (e
, &result
))
1609 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1618 /* Work function that extracts a particular element from an array
1619 constructor, freeing the rest. */
1622 extract_element (gfc_expr
*e
)
1625 { /* Something unextractable */
1630 if (current_expand
.extract_count
== current_expand
.extract_n
)
1631 current_expand
.extracted
= e
;
1635 current_expand
.extract_count
++;
1641 /* Work function that constructs a new constructor out of the old one,
1642 stringing new elements together. */
1645 expand (gfc_expr
*e
)
1647 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1650 c
->n
.component
= current_expand
.component
;
1655 /* Given an initialization expression that is a variable reference,
1656 substitute the current value of the iteration variable. */
1659 gfc_simplify_iterator_var (gfc_expr
*e
)
1663 for (p
= iter_stack
; p
; p
= p
->prev
)
1664 if (e
->symtree
== p
->variable
)
1668 return; /* Variable not found */
1670 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1672 mpz_set (e
->value
.integer
, p
->value
);
1678 /* Expand an expression with that is inside of a constructor,
1679 recursing into other constructors if present. */
1682 expand_expr (gfc_expr
*e
)
1684 if (e
->expr_type
== EXPR_ARRAY
)
1685 return expand_constructor (e
->value
.constructor
);
1687 e
= gfc_copy_expr (e
);
1689 if (!gfc_simplify_expr (e
, 1))
1695 return current_expand
.expand_work_function (e
);
1700 expand_iterator (gfc_constructor
*c
)
1702 gfc_expr
*start
, *end
, *step
;
1703 iterator_stack frame
;
1712 mpz_init (frame
.value
);
1715 start
= gfc_copy_expr (c
->iterator
->start
);
1716 if (!gfc_simplify_expr (start
, 1))
1719 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1722 end
= gfc_copy_expr (c
->iterator
->end
);
1723 if (!gfc_simplify_expr (end
, 1))
1726 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1729 step
= gfc_copy_expr (c
->iterator
->step
);
1730 if (!gfc_simplify_expr (step
, 1))
1733 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1736 if (mpz_sgn (step
->value
.integer
) == 0)
1738 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1742 /* Calculate the trip count of the loop. */
1743 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1744 mpz_add (trip
, trip
, step
->value
.integer
);
1745 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1747 mpz_set (frame
.value
, start
->value
.integer
);
1749 frame
.prev
= iter_stack
;
1750 frame
.variable
= c
->iterator
->var
->symtree
;
1751 iter_stack
= &frame
;
1753 while (mpz_sgn (trip
) > 0)
1755 if (!expand_expr (c
->expr
))
1758 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1759 mpz_sub_ui (trip
, trip
, 1);
1765 gfc_free_expr (start
);
1766 gfc_free_expr (end
);
1767 gfc_free_expr (step
);
1770 mpz_clear (frame
.value
);
1772 iter_stack
= frame
.prev
;
1777 /* Variables for noticing if all constructors are empty, and
1778 if any of them had a type. */
1780 static bool empty_constructor
;
1781 static gfc_typespec empty_ts
;
1783 /* Expand a constructor into constant constructors without any
1784 iterators, calling the work function for each of the expanded
1785 expressions. The work function needs to either save or free the
1786 passed expression. */
1789 expand_constructor (gfc_constructor_base base
)
1794 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1796 if (c
->iterator
!= NULL
)
1798 if (!expand_iterator (c
))
1808 if (empty_constructor
)
1811 /* Simplify constant array expression/section within constructor. */
1812 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0 && e
->ref
1813 && e
->symtree
&& e
->symtree
->n
.sym
1814 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1815 gfc_simplify_expr (e
, 0);
1817 if (e
->expr_type
== EXPR_ARRAY
)
1819 if (!expand_constructor (e
->value
.constructor
))
1825 empty_constructor
= false;
1826 e
= gfc_copy_expr (e
);
1827 if (!gfc_simplify_expr (e
, 1))
1832 e
->from_constructor
= 1;
1833 current_expand
.offset
= &c
->offset
;
1834 current_expand
.repeat
= &c
->repeat
;
1835 current_expand
.component
= c
->n
.component
;
1836 if (!current_expand
.expand_work_function(e
))
1843 /* Given an array expression and an element number (starting at zero),
1844 return a pointer to the array element. NULL is returned if the
1845 size of the array has been exceeded. The expression node returned
1846 remains a part of the array and should not be freed. Access is not
1847 efficient at all, but this is another place where things do not
1848 have to be particularly fast. */
1851 gfc_get_array_element (gfc_expr
*array
, int element
)
1853 expand_info expand_save
;
1857 expand_save
= current_expand
;
1858 current_expand
.extract_n
= element
;
1859 current_expand
.expand_work_function
= extract_element
;
1860 current_expand
.extracted
= NULL
;
1861 current_expand
.extract_count
= 0;
1865 rc
= expand_constructor (array
->value
.constructor
);
1866 e
= current_expand
.extracted
;
1867 current_expand
= expand_save
;
1876 /* Top level subroutine for expanding constructors. We only expand
1877 constructor if they are small enough. */
1880 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1882 expand_info expand_save
;
1886 /* If we can successfully get an array element at the max array size then
1887 the array is too big to expand, so we just return. */
1888 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1894 gfc_error ("The number of elements in the array constructor "
1895 "at %L requires an increase of the allowed %d "
1896 "upper limit. See %<-fmax-array-constructor%> "
1897 "option", &e
->where
, flag_max_array_constructor
);
1903 /* We now know the array is not too big so go ahead and try to expand it. */
1904 expand_save
= current_expand
;
1905 current_expand
.base
= NULL
;
1909 empty_constructor
= true;
1910 gfc_clear_ts (&empty_ts
);
1911 current_expand
.expand_work_function
= expand
;
1913 if (!expand_constructor (e
->value
.constructor
))
1915 gfc_constructor_free (current_expand
.base
);
1920 /* If we don't have an explicit constructor type, and there
1921 were only empty constructors, then take the type from
1924 if (constructor_ts
.type
== BT_UNKNOWN
&& empty_constructor
)
1927 gfc_constructor_free (e
->value
.constructor
);
1928 e
->value
.constructor
= current_expand
.base
;
1933 current_expand
= expand_save
;
1939 /* Work function for checking that an element of a constructor is a
1940 constant, after removal of any iteration variables. We return
1944 is_constant_element (gfc_expr
*e
)
1948 rv
= gfc_is_constant_expr (e
);
1951 return rv
? true : false;
1955 /* Given an array constructor, determine if the constructor is
1956 constant or not by expanding it and making sure that all elements
1957 are constants. This is a bit of a hack since something like (/ (i,
1958 i=1,100000000) /) will take a while as* opposed to a more clever
1959 function that traverses the expression tree. FIXME. */
1962 gfc_constant_ac (gfc_expr
*e
)
1964 expand_info expand_save
;
1968 expand_save
= current_expand
;
1969 current_expand
.expand_work_function
= is_constant_element
;
1971 rc
= expand_constructor (e
->value
.constructor
);
1973 current_expand
= expand_save
;
1981 /* Returns nonzero if an array constructor has been completely
1982 expanded (no iterators) and zero if iterators are present. */
1985 gfc_expanded_ac (gfc_expr
*e
)
1989 if (e
->expr_type
== EXPR_ARRAY
)
1990 for (c
= gfc_constructor_first (e
->value
.constructor
);
1991 c
; c
= gfc_constructor_next (c
))
1992 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1999 /*************** Type resolution of array constructors ***************/
2002 /* The symbol expr_is_sought_symbol_ref will try to find. */
2003 static const gfc_symbol
*sought_symbol
= NULL
;
2006 /* Tells whether the expression E is a variable reference to the symbol
2007 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
2009 To be used with gfc_expr_walker: if a reference is found we don't need
2010 to look further so we return 1 to skip any further walk. */
2013 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2016 gfc_expr
*expr
= *e
;
2017 locus
*sym_loc
= (locus
*)where
;
2019 if (expr
->expr_type
== EXPR_VARIABLE
2020 && expr
->symtree
->n
.sym
== sought_symbol
)
2022 *sym_loc
= expr
->where
;
2030 /* Tells whether the expression EXPR contains a reference to the symbol
2031 SYM and in that case sets the position SYM_LOC where the reference is. */
2034 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
2038 sought_symbol
= sym
;
2039 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
2040 sought_symbol
= NULL
;
2045 /* Recursive array list resolution function. All of the elements must
2046 be of the same type. */
2049 resolve_array_list (gfc_constructor_base base
)
2057 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2062 gfc_symbol
*iter_var
;
2065 if (!gfc_resolve_iterator (iter
, false, true))
2068 /* Check for bounds referencing the iterator variable. */
2069 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
2070 iter_var
= iter
->var
->symtree
->n
.sym
;
2071 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
2073 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
2074 "expression references control variable "
2075 "at %L", &iter_var_loc
))
2078 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
2080 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
2081 "expression references control variable "
2082 "at %L", &iter_var_loc
))
2085 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
2087 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
2088 "expression references control variable "
2089 "at %L", &iter_var_loc
))
2094 if (!gfc_resolve_expr (c
->expr
))
2097 if (UNLIMITED_POLY (c
->expr
))
2099 gfc_error ("Array constructor value at %L shall not be unlimited "
2100 "polymorphic [F2008: C4106]", &c
->expr
->where
);
2108 /* Resolve character array constructor. If it has a specified constant character
2109 length, pad/truncate the elements here; if the length is not specified and
2110 all elements are of compile-time known length, emit an error as this is
2114 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
2117 HOST_WIDE_INT found_length
;
2119 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
2120 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2122 if (expr
->ts
.u
.cl
== NULL
)
2124 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2125 p
; p
= gfc_constructor_next (p
))
2126 if (p
->expr
->ts
.u
.cl
!= NULL
)
2128 /* Ensure that if there is a char_len around that it is
2129 used; otherwise the middle-end confuses them! */
2130 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2134 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2139 /* Early exit for zero size arrays. */
2143 HOST_WIDE_INT arraysize
;
2145 gfc_array_size (expr
, &size
);
2146 arraysize
= mpz_get_ui (size
);
2155 if (expr
->ts
.u
.cl
->length
== NULL
)
2157 /* Check that all constant string elements have the same length until
2158 we reach the end or find a variable-length one. */
2160 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2161 p
; p
= gfc_constructor_next (p
))
2163 HOST_WIDE_INT current_length
= -1;
2165 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2166 if (ref
->type
== REF_SUBSTRING
2168 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2170 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2173 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2174 current_length
= p
->expr
->value
.character
.length
;
2176 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2177 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2178 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2179 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2180 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2184 if (current_length
< 0)
2187 if (found_length
== -1)
2188 found_length
= current_length
;
2189 else if (found_length
!= current_length
)
2191 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2192 " constructor at %L", (long) found_length
,
2193 (long) current_length
, &p
->expr
->where
);
2197 gcc_assert (found_length
== current_length
);
2200 gcc_assert (found_length
!= -1);
2202 /* Update the character length of the array constructor. */
2203 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2204 NULL
, found_length
);
2208 /* We've got a character length specified. It should be an integer,
2209 otherwise an error is signalled elsewhere. */
2210 gcc_assert (expr
->ts
.u
.cl
->length
);
2212 /* If we've got a constant character length, pad according to this.
2213 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2214 max_length only if they pass. */
2215 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2217 /* Now pad/truncate the elements accordingly to the specified character
2218 length. This is ok inside this conditional, as in the case above
2219 (without typespec) all elements are verified to have the same length
2221 if (found_length
!= -1)
2222 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2223 p
; p
= gfc_constructor_next (p
))
2224 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2226 gfc_expr
*cl
= NULL
;
2227 HOST_WIDE_INT current_length
= -1;
2230 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2232 cl
= p
->expr
->ts
.u
.cl
->length
;
2233 gfc_extract_hwi (cl
, ¤t_length
);
2236 /* If gfc_extract_int above set current_length, we implicitly
2237 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2239 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2242 || (current_length
!= -1 && current_length
!= found_length
))
2243 gfc_set_constant_character_len (found_length
, p
->expr
,
2244 has_ts
? -1 : found_length
);
2252 /* Resolve all of the expressions in an array list. */
2255 gfc_resolve_array_constructor (gfc_expr
*expr
)
2259 t
= resolve_array_list (expr
->value
.constructor
);
2261 t
= gfc_check_constructor_type (expr
);
2263 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2264 the call to this function, so we don't need to call it here; if it was
2265 called twice, an error message there would be duplicated. */
2271 /* Copy an iterator structure. */
2274 gfc_copy_iterator (gfc_iterator
*src
)
2281 dest
= gfc_get_iterator ();
2283 dest
->var
= gfc_copy_expr (src
->var
);
2284 dest
->start
= gfc_copy_expr (src
->start
);
2285 dest
->end
= gfc_copy_expr (src
->end
);
2286 dest
->step
= gfc_copy_expr (src
->step
);
2287 dest
->unroll
= src
->unroll
;
2288 dest
->ivdep
= src
->ivdep
;
2289 dest
->vector
= src
->vector
;
2290 dest
->novector
= src
->novector
;
2296 /********* Subroutines for determining the size of an array *********/
2298 /* These are needed just to accommodate RESHAPE(). There are no
2299 diagnostics here, we just return false if something goes wrong. */
2302 /* Get the size of single dimension of an array specification. The
2303 array is guaranteed to be one dimensional. */
2306 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2311 if (dimen
< 0 || dimen
> as
->rank
- 1)
2312 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2314 if (as
->type
!= AS_EXPLICIT
2315 || !as
->lower
[dimen
]
2316 || !as
->upper
[dimen
])
2319 if (as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2320 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2321 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2322 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2327 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2328 as
->lower
[dimen
]->value
.integer
);
2330 mpz_add_ui (*result
, *result
, 1);
2332 if (mpz_cmp_si (*result
, 0) < 0)
2333 mpz_set_si (*result
, 0);
2340 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2345 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2348 mpz_init_set_ui (*result
, 1);
2350 for (d
= 0; d
< as
->rank
; d
++)
2352 if (!spec_dimen_size (as
, d
, &size
))
2354 mpz_clear (*result
);
2358 mpz_mul (*result
, *result
, size
);
2366 /* Get the number of elements in an array section. Optionally, also supply
2370 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2372 mpz_t upper
, lower
, stride
;
2375 gfc_expr
*stride_expr
= NULL
;
2377 if (dimen
< 0 || ar
== NULL
)
2378 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2380 if (dimen
> ar
->dimen
- 1)
2382 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2386 switch (ar
->dimen_type
[dimen
])
2390 mpz_set_ui (*result
, 1);
2395 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2402 if (ar
->stride
[dimen
] == NULL
)
2403 mpz_set_ui (stride
, 1);
2406 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2408 if (!gfc_simplify_expr (stride_expr
, 1)
2409 || stride_expr
->expr_type
!= EXPR_CONSTANT
2410 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2412 gfc_free_expr (stride_expr
);
2416 mpz_set (stride
, stride_expr
->value
.integer
);
2417 gfc_free_expr(stride_expr
);
2420 /* Calculate the number of elements via gfc_dep_differce, but only if
2421 start and end are both supplied in the reference or the array spec.
2422 This is to guard against strange but valid code like
2427 print *,size(a(n-1:))
2429 where the user changes the value of a variable. If we have to
2430 determine end as well, we cannot do this using gfc_dep_difference.
2431 Fall back to the constants-only code then. */
2437 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2439 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2440 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2441 ar
->as
->lower
[dimen
], &diff
);
2446 mpz_add (*result
, diff
, stride
);
2447 mpz_div (*result
, *result
, stride
);
2448 if (mpz_cmp_ui (*result
, 0) < 0)
2449 mpz_set_ui (*result
, 0);
2458 /* Constant-only code here, which covers more cases
2464 if (ar
->start
[dimen
] == NULL
)
2466 if (ar
->as
->lower
[dimen
] == NULL
2467 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2468 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2470 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2474 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2476 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2479 if (ar
->end
[dimen
] == NULL
)
2481 if (ar
->as
->upper
[dimen
] == NULL
2482 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2483 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2485 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2489 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2491 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2495 mpz_sub (*result
, upper
, lower
);
2496 mpz_add (*result
, *result
, stride
);
2497 mpz_div (*result
, *result
, stride
);
2499 /* Zero stride caught earlier. */
2500 if (mpz_cmp_ui (*result
, 0) < 0)
2501 mpz_set_ui (*result
, 0);
2508 mpz_sub_ui (*end
, *result
, 1UL);
2509 mpz_mul (*end
, *end
, stride
);
2510 mpz_add (*end
, *end
, lower
);
2520 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2528 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2533 mpz_init_set_ui (*result
, 1);
2535 for (d
= 0; d
< ar
->dimen
; d
++)
2537 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2539 mpz_clear (*result
);
2543 mpz_mul (*result
, *result
, size
);
2551 /* Given an array expression and a dimension, figure out how many
2552 elements it has along that dimension. Returns true if we were
2553 able to return a result in the 'result' variable, false
2557 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2562 gcc_assert (array
!= NULL
);
2564 if (array
->ts
.type
== BT_CLASS
)
2567 if (array
->rank
== -1)
2570 if (dimen
< 0 || dimen
> array
->rank
- 1)
2571 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2573 switch (array
->expr_type
)
2577 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2579 if (ref
->type
!= REF_ARRAY
)
2582 if (ref
->u
.ar
.type
== AR_FULL
)
2583 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2585 if (ref
->u
.ar
.type
== AR_SECTION
)
2587 for (i
= 0; dimen
>= 0; i
++)
2588 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2591 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2597 mpz_init_set (*result
, array
->shape
[dimen
]);
2601 if (array
->symtree
->n
.sym
->attr
.generic
2602 && array
->value
.function
.esym
!= NULL
)
2604 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2607 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2613 if (array
->shape
== NULL
) {
2614 /* Expressions with rank > 1 should have "shape" properly set */
2615 if ( array
->rank
!= 1 )
2616 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2617 return gfc_array_size(array
, result
);
2622 if (array
->shape
== NULL
)
2625 mpz_init_set (*result
, array
->shape
[dimen
]);
2634 /* Given an array expression, figure out how many elements are in the
2635 array. Returns true if this is possible, and sets the 'result'
2636 variable. Otherwise returns false. */
2639 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2641 expand_info expand_save
;
2646 if (array
->ts
.type
== BT_CLASS
)
2649 switch (array
->expr_type
)
2652 gfc_push_suppress_errors ();
2654 expand_save
= current_expand
;
2656 current_expand
.count
= result
;
2657 mpz_init_set_ui (*result
, 0);
2659 current_expand
.expand_work_function
= count_elements
;
2662 t
= expand_constructor (array
->value
.constructor
);
2664 gfc_pop_suppress_errors ();
2667 mpz_clear (*result
);
2668 current_expand
= expand_save
;
2672 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2674 if (ref
->type
!= REF_ARRAY
)
2677 if (ref
->u
.ar
.type
== AR_FULL
)
2678 return spec_size (ref
->u
.ar
.as
, result
);
2680 if (ref
->u
.ar
.type
== AR_SECTION
)
2681 return ref_size (&ref
->u
.ar
, result
);
2684 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2688 if (array
->rank
== 0 || array
->shape
== NULL
)
2691 mpz_init_set_ui (*result
, 1);
2693 for (i
= 0; i
< array
->rank
; i
++)
2694 mpz_mul (*result
, *result
, array
->shape
[i
]);
2703 /* Given an array reference, return the shape of the reference in an
2704 array of mpz_t integers. */
2707 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2717 for (; d
< ar
->as
->rank
; d
++)
2718 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2724 for (i
= 0; i
< ar
->dimen
; i
++)
2726 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2728 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2741 gfc_clear_shape (shape
, d
);
2746 /* Given an array expression, find the array reference structure that
2747 characterizes the reference. */
2750 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2754 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2755 if (ref
->type
== REF_ARRAY
2756 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2764 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2771 /* Find out if an array shape is known at compile time. */
2774 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2776 if (as
->type
!= AS_EXPLICIT
)
2779 for (int i
= 0; i
< as
->rank
; i
++)
2780 if (!gfc_is_constant_expr (as
->lower
[i
])
2781 || !gfc_is_constant_expr (as
->upper
[i
]))