2 Copyright (C) 2000-2021 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 if (((*upper
)->expr_type
== EXPR_CONSTANT
496 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
497 ((*upper
)->expr_type
== EXPR_FUNCTION
498 && (*upper
)->ts
.type
== BT_UNKNOWN
500 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
502 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
503 gfc_basic_typename ((*upper
)->ts
.type
));
507 if (gfc_match_char (':') == MATCH_NO
)
509 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
516 if (gfc_match_char ('*') == MATCH_YES
)
517 return AS_ASSUMED_SIZE
;
519 m
= gfc_match_expr (upper
);
520 if (m
== MATCH_ERROR
)
523 return AS_ASSUMED_SHAPE
;
524 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
527 if (((*upper
)->expr_type
== EXPR_CONSTANT
528 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
529 ((*upper
)->expr_type
== EXPR_FUNCTION
530 && (*upper
)->ts
.type
== BT_UNKNOWN
532 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
534 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
535 gfc_basic_typename ((*upper
)->ts
.type
));
543 /* Matches an array specification, incidentally figuring out what sort
544 it is. Match either a normal array specification, or a coarray spec
545 or both. Optionally allow [:] for coarrays. */
548 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
550 array_type current_type
;
554 as
= gfc_get_array_spec ();
559 if (gfc_match_char ('(') != MATCH_YES
)
566 if (gfc_match (" .. )") == MATCH_YES
)
568 as
->type
= AS_ASSUMED_RANK
;
571 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed-rank array at %C"))
582 current_type
= match_array_element_spec (as
);
584 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
585 and implied-shape specifications. If the rank is at least 2, we can
586 distinguish between them. But for rank 1, we currently return
587 ASSUMED_SIZE; this gets adjusted later when we know for sure
588 whether the symbol parsed is a PARAMETER or not. */
592 if (current_type
== AS_UNKNOWN
)
594 as
->type
= current_type
;
598 { /* See how current spec meshes with the existing. */
602 case AS_IMPLIED_SHAPE
:
603 if (current_type
!= AS_ASSUMED_SIZE
)
605 gfc_error ("Bad array specification for implied-shape"
612 if (current_type
== AS_ASSUMED_SIZE
)
614 as
->type
= AS_ASSUMED_SIZE
;
618 if (current_type
== AS_EXPLICIT
)
621 gfc_error ("Bad array specification for an explicitly shaped "
626 case AS_ASSUMED_SHAPE
:
627 if ((current_type
== AS_ASSUMED_SHAPE
)
628 || (current_type
== AS_DEFERRED
))
631 gfc_error ("Bad array specification for assumed shape "
636 if (current_type
== AS_DEFERRED
)
639 if (current_type
== AS_ASSUMED_SHAPE
)
641 as
->type
= AS_ASSUMED_SHAPE
;
645 gfc_error ("Bad specification for deferred shape array at %C");
648 case AS_ASSUMED_SIZE
:
649 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
651 as
->type
= AS_IMPLIED_SHAPE
;
655 gfc_error ("Bad specification for assumed size array at %C");
658 case AS_ASSUMED_RANK
:
662 if (gfc_match_char (')') == MATCH_YES
)
665 if (gfc_match_char (',') != MATCH_YES
)
667 gfc_error ("Expected another dimension in array declaration at %C");
671 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
673 gfc_error ("Array specification at %C has more than %d dimensions",
678 if (as
->corank
+ as
->rank
>= 7
679 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
680 "with more than 7 dimensions"))
688 if (gfc_match_char ('[') != MATCH_YES
)
691 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
694 if (flag_coarray
== GFC_FCOARRAY_NONE
)
696 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
700 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
702 gfc_error ("Array specification at %C has more than %d "
703 "dimensions", GFC_MAX_DIMENSIONS
);
710 current_type
= match_array_element_spec (as
);
712 if (current_type
== AS_UNKNOWN
)
716 as
->cotype
= current_type
;
719 { /* See how current spec meshes with the existing. */
720 case AS_IMPLIED_SHAPE
:
725 if (current_type
== AS_ASSUMED_SIZE
)
727 as
->cotype
= AS_ASSUMED_SIZE
;
731 if (current_type
== AS_EXPLICIT
)
734 gfc_error ("Bad array specification for an explicitly "
735 "shaped array at %C");
739 case AS_ASSUMED_SHAPE
:
740 if ((current_type
== AS_ASSUMED_SHAPE
)
741 || (current_type
== AS_DEFERRED
))
744 gfc_error ("Bad array specification for assumed shape "
749 if (current_type
== AS_DEFERRED
)
752 if (current_type
== AS_ASSUMED_SHAPE
)
754 as
->cotype
= AS_ASSUMED_SHAPE
;
758 gfc_error ("Bad specification for deferred shape array at %C");
761 case AS_ASSUMED_SIZE
:
762 gfc_error ("Bad specification for assumed size array at %C");
765 case AS_ASSUMED_RANK
:
769 if (gfc_match_char (']') == MATCH_YES
)
772 if (gfc_match_char (',') != MATCH_YES
)
774 gfc_error ("Expected another dimension in array declaration at %C");
778 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
780 gfc_error ("Array specification at %C has more than %d "
781 "dimensions", GFC_MAX_DIMENSIONS
);
786 if (current_type
== AS_EXPLICIT
)
788 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
792 if (as
->cotype
== AS_ASSUMED_SIZE
)
793 as
->cotype
= AS_EXPLICIT
;
796 as
->type
= as
->cotype
;
799 if (as
->rank
== 0 && as
->corank
== 0)
802 gfc_free_array_spec (as
);
806 /* If a lower bounds of an assumed shape array is blank, put in one. */
807 if (as
->type
== AS_ASSUMED_SHAPE
)
809 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
811 if (as
->lower
[i
] == NULL
)
812 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
821 /* Something went wrong. */
822 gfc_free_array_spec (as
);
826 /* Given a symbol and an array specification, modify the symbol to
827 have that array specification. The error locus is needed in case
828 something goes wrong. On failure, the caller must free the spec. */
831 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
834 symbol_attribute
*attr
;
839 /* If the symbol corresponds to a submodule module procedure the array spec is
840 already set, so do not attempt to set it again here. */
842 if (gfc_submodule_procedure(attr
))
846 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
850 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
859 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
860 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
862 gfc_error ("The assumed-rank array %qs at %L shall not have a "
863 "codimension", sym
->name
, error_loc
);
867 /* Check F2018:C822. */
868 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
873 sym
->as
->cotype
= as
->cotype
;
874 sym
->as
->corank
= as
->corank
;
875 /* Check F2018:C822. */
876 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
879 for (i
= 0; i
< as
->corank
; i
++)
881 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
882 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
887 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
888 the dimension is added - but first the codimensions (if existing
889 need to be shifted to make space for the dimension. */
890 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
892 sym
->as
->rank
= as
->rank
;
893 sym
->as
->type
= as
->type
;
894 sym
->as
->cray_pointee
= as
->cray_pointee
;
895 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
897 /* Check F2018:C822. */
898 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
901 for (i
= sym
->as
->corank
- 1; i
>= 0; i
--)
903 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
904 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
906 for (i
= 0; i
< as
->rank
; i
++)
908 sym
->as
->lower
[i
] = as
->lower
[i
];
909 sym
->as
->upper
[i
] = as
->upper
[i
];
918 gfc_error ("rank + corank of %qs exceeds %d at %C", sym
->name
,
924 /* Copy an array specification. */
927 gfc_copy_array_spec (gfc_array_spec
*src
)
929 gfc_array_spec
*dest
;
935 dest
= gfc_get_array_spec ();
939 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
941 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
942 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
949 /* Returns nonzero if the two expressions are equal. Only handles integer
953 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
955 if (bound1
== NULL
|| bound2
== NULL
956 || bound1
->expr_type
!= EXPR_CONSTANT
957 || bound2
->expr_type
!= EXPR_CONSTANT
958 || bound1
->ts
.type
!= BT_INTEGER
959 || bound2
->ts
.type
!= BT_INTEGER
)
960 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
962 if (mpz_cmp (bound1
->value
.integer
, bound2
->value
.integer
) == 0)
969 /* Compares two array specifications. They must be constant or deferred
973 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
977 if (as1
== NULL
&& as2
== NULL
)
980 if (as1
== NULL
|| as2
== NULL
)
983 if (as1
->rank
!= as2
->rank
)
986 if (as1
->corank
!= as2
->corank
)
992 if (as1
->type
!= as2
->type
)
995 if (as1
->type
== AS_EXPLICIT
)
996 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
998 if (compare_bounds (as1
->lower
[i
], as2
->lower
[i
]) == 0)
1001 if (compare_bounds (as1
->upper
[i
], as2
->upper
[i
]) == 0)
1009 /****************** Array constructor functions ******************/
1012 /* Given an expression node that might be an array constructor and a
1013 symbol, make sure that no iterators in this or child constructors
1014 use the symbol as an implied-DO iterator. Returns nonzero if a
1015 duplicate was found. */
1018 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
1023 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1027 if (e
->expr_type
== EXPR_ARRAY
1028 && check_duplicate_iterator (e
->value
.constructor
, master
))
1031 if (c
->iterator
== NULL
)
1034 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
1036 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1037 "same name", master
->name
, &c
->where
);
1047 /* Forward declaration because these functions are mutually recursive. */
1048 static match
match_array_cons_element (gfc_constructor_base
*);
1050 /* Match a list of array elements. */
1053 match_array_list (gfc_constructor_base
*result
)
1055 gfc_constructor_base head
;
1063 old_loc
= gfc_current_locus
;
1065 if (gfc_match_char ('(') == MATCH_NO
)
1068 memset (&iter
, '\0', sizeof (gfc_iterator
));
1071 m
= match_array_cons_element (&head
);
1075 if (gfc_match_char (',') != MATCH_YES
)
1083 m
= gfc_match_iterator (&iter
, 0);
1086 if (m
== MATCH_ERROR
)
1089 m
= match_array_cons_element (&head
);
1090 if (m
== MATCH_ERROR
)
1097 goto cleanup
; /* Could be a complex constant */
1100 if (gfc_match_char (',') != MATCH_YES
)
1109 if (gfc_match_char (')') != MATCH_YES
)
1112 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1118 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1119 e
->value
.constructor
= head
;
1121 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1122 p
->iterator
= gfc_get_iterator ();
1123 *p
->iterator
= iter
;
1128 gfc_error ("Syntax error in array constructor at %C");
1132 gfc_constructor_free (head
);
1133 gfc_free_iterator (&iter
, 0);
1134 gfc_current_locus
= old_loc
;
1139 /* Match a single element of an array constructor, which can be a
1140 single expression or a list of elements. */
1143 match_array_cons_element (gfc_constructor_base
*result
)
1148 m
= match_array_list (result
);
1152 m
= gfc_match_expr (&expr
);
1156 if (expr
->ts
.type
== BT_BOZ
)
1158 gfc_error ("BOZ literal constant at %L cannot appear in an "
1159 "array constructor", &expr
->where
);
1163 if (expr
->expr_type
== EXPR_FUNCTION
1164 && expr
->ts
.type
== BT_UNKNOWN
1165 && strcmp(expr
->symtree
->name
, "null") == 0)
1167 gfc_error ("NULL() at %C cannot appear in an array constructor");
1171 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1175 gfc_free_expr (expr
);
1180 /* Convert components of an array constructor to the type in ts. */
1183 walk_array_constructor (gfc_typespec
*ts
, gfc_constructor_base head
)
1189 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1192 if (e
->expr_type
== EXPR_ARRAY
&& e
->ts
.type
== BT_UNKNOWN
1193 && !e
->ref
&& e
->value
.constructor
)
1195 m
= walk_array_constructor (ts
, e
->value
.constructor
);
1196 if (m
== MATCH_ERROR
)
1199 else if (!gfc_convert_type_warn (e
, ts
, 1, 1, true)
1200 && e
->ts
.type
!= BT_UNKNOWN
)
1206 /* Match an array constructor. */
1209 gfc_match_array_constructor (gfc_expr
**result
)
1212 gfc_constructor_base head
;
1217 const char *end_delim
;
1223 if (gfc_match (" (/") == MATCH_NO
)
1225 if (gfc_match (" [") == MATCH_NO
)
1229 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1230 "style array constructors at %C"))
1238 where
= gfc_current_locus
;
1240 /* Try to match an optional "type-spec ::" */
1242 m
= gfc_match_type_spec (&ts
);
1245 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1249 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1250 "including type specification at %C"))
1255 gfc_error ("Type-spec at %L cannot contain a deferred "
1256 "type parameter", &where
);
1260 if (ts
.type
== BT_CHARACTER
1261 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1263 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1264 "type parameter", &where
);
1269 else if (m
== MATCH_ERROR
)
1273 gfc_current_locus
= where
;
1275 if (gfc_match (end_delim
) == MATCH_YES
)
1281 gfc_error ("Empty array constructor at %C is not allowed");
1288 m
= match_array_cons_element (&head
);
1289 if (m
== MATCH_ERROR
)
1294 if (gfc_match_char (',') == MATCH_NO
)
1298 if (gfc_match (end_delim
) == MATCH_NO
)
1302 /* Size must be calculated at resolution time. */
1305 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1308 /* If the typespec is CHARACTER, check that array elements can
1309 be converted. See PR fortran/67803. */
1310 if (ts
.type
== BT_CHARACTER
)
1312 c
= gfc_constructor_first (head
);
1313 for (; c
; c
= gfc_constructor_next (c
))
1315 if (gfc_numeric_ts (&c
->expr
->ts
)
1316 || c
->expr
->ts
.type
== BT_LOGICAL
)
1318 gfc_error ("Incompatible typespec for array element at %L",
1323 /* Special case null(). */
1324 if (c
->expr
->expr_type
== EXPR_FUNCTION
1325 && c
->expr
->ts
.type
== BT_UNKNOWN
1326 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1328 gfc_error ("Incompatible typespec for array element at %L",
1335 /* Walk the constructor, and if possible, do type conversion for
1337 if (gfc_numeric_ts (&ts
))
1339 m
= walk_array_constructor (&ts
, head
);
1340 if (m
== MATCH_ERROR
)
1345 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1347 expr
->value
.constructor
= head
;
1349 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1356 gfc_error ("Syntax error in array constructor at %C");
1359 gfc_constructor_free (head
);
1365 /************** Check array constructors for correctness **************/
1367 /* Given an expression, compare it's type with the type of the current
1368 constructor. Returns nonzero if an error was issued. The
1369 cons_state variable keeps track of whether the type of the
1370 constructor being read or resolved is known to be good, bad or just
1373 static gfc_typespec constructor_ts
;
1375 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1379 check_element_type (gfc_expr
*expr
, bool convert
)
1381 if (cons_state
== CONS_BAD
)
1382 return 0; /* Suppress further errors */
1384 if (cons_state
== CONS_START
)
1386 if (expr
->ts
.type
== BT_UNKNOWN
)
1387 cons_state
= CONS_BAD
;
1390 cons_state
= CONS_GOOD
;
1391 constructor_ts
= expr
->ts
;
1397 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1401 return gfc_convert_type_warn (expr
, &constructor_ts
, 1, 1, true) ? 0 : 1;
1403 gfc_error ("Element in %s array constructor at %L is %s",
1404 gfc_typename (&constructor_ts
), &expr
->where
,
1405 gfc_typename (expr
));
1407 cons_state
= CONS_BAD
;
1412 /* Recursive work function for gfc_check_constructor_type(). */
1415 check_constructor_type (gfc_constructor_base base
, bool convert
)
1420 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1424 if (e
->expr_type
== EXPR_ARRAY
)
1426 if (!check_constructor_type (e
->value
.constructor
, convert
))
1432 if (check_element_type (e
, convert
))
1440 /* Check that all elements of an array constructor are the same type.
1441 On false, an error has been generated. */
1444 gfc_check_constructor_type (gfc_expr
*e
)
1448 if (e
->ts
.type
!= BT_UNKNOWN
)
1450 cons_state
= CONS_GOOD
;
1451 constructor_ts
= e
->ts
;
1455 cons_state
= CONS_START
;
1456 gfc_clear_ts (&constructor_ts
);
1459 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1460 typespec, and we will now convert the values on the fly. */
1461 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1462 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1463 e
->ts
= constructor_ts
;
1470 typedef struct cons_stack
1472 gfc_iterator
*iterator
;
1473 struct cons_stack
*previous
;
1477 static cons_stack
*base
;
1479 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1481 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1482 that that variable is an iteration variable. */
1485 gfc_check_iter_variable (gfc_expr
*expr
)
1490 sym
= expr
->symtree
->n
.sym
;
1492 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1493 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1500 /* Recursive work function for gfc_check_constructor(). This amounts
1501 to calling the check function for each expression in the
1502 constructor, giving variables with the names of iterators a pass. */
1505 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1512 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1519 if (e
->expr_type
!= EXPR_ARRAY
)
1521 if (!(*check_function
)(e
))
1526 element
.previous
= base
;
1527 element
.iterator
= c
->iterator
;
1530 t
= check_constructor (e
->value
.constructor
, check_function
);
1531 base
= element
.previous
;
1537 /* Nothing went wrong, so all OK. */
1542 /* Checks a constructor to see if it is a particular kind of
1543 expression -- specification, restricted, or initialization as
1544 determined by the check_function. */
1547 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1549 cons_stack
*base_save
;
1555 t
= check_constructor (expr
->value
.constructor
, check_function
);
1563 /**************** Simplification of array constructors ****************/
1565 iterator_stack
*iter_stack
;
1569 gfc_constructor_base base
;
1570 int extract_count
, extract_n
;
1571 gfc_expr
*extracted
;
1575 gfc_component
*component
;
1578 bool (*expand_work_function
) (gfc_expr
*);
1582 static expand_info current_expand
;
1584 static bool expand_constructor (gfc_constructor_base
);
1587 /* Work function that counts the number of elements present in a
1591 count_elements (gfc_expr
*e
)
1596 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1599 if (!gfc_array_size (e
, &result
))
1605 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1614 /* Work function that extracts a particular element from an array
1615 constructor, freeing the rest. */
1618 extract_element (gfc_expr
*e
)
1621 { /* Something unextractable */
1626 if (current_expand
.extract_count
== current_expand
.extract_n
)
1627 current_expand
.extracted
= e
;
1631 current_expand
.extract_count
++;
1637 /* Work function that constructs a new constructor out of the old one,
1638 stringing new elements together. */
1641 expand (gfc_expr
*e
)
1643 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1646 c
->n
.component
= current_expand
.component
;
1651 /* Given an initialization expression that is a variable reference,
1652 substitute the current value of the iteration variable. */
1655 gfc_simplify_iterator_var (gfc_expr
*e
)
1659 for (p
= iter_stack
; p
; p
= p
->prev
)
1660 if (e
->symtree
== p
->variable
)
1664 return; /* Variable not found */
1666 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1668 mpz_set (e
->value
.integer
, p
->value
);
1674 /* Expand an expression with that is inside of a constructor,
1675 recursing into other constructors if present. */
1678 expand_expr (gfc_expr
*e
)
1680 if (e
->expr_type
== EXPR_ARRAY
)
1681 return expand_constructor (e
->value
.constructor
);
1683 e
= gfc_copy_expr (e
);
1685 if (!gfc_simplify_expr (e
, 1))
1691 return current_expand
.expand_work_function (e
);
1696 expand_iterator (gfc_constructor
*c
)
1698 gfc_expr
*start
, *end
, *step
;
1699 iterator_stack frame
;
1708 mpz_init (frame
.value
);
1711 start
= gfc_copy_expr (c
->iterator
->start
);
1712 if (!gfc_simplify_expr (start
, 1))
1715 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1718 end
= gfc_copy_expr (c
->iterator
->end
);
1719 if (!gfc_simplify_expr (end
, 1))
1722 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1725 step
= gfc_copy_expr (c
->iterator
->step
);
1726 if (!gfc_simplify_expr (step
, 1))
1729 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1732 if (mpz_sgn (step
->value
.integer
) == 0)
1734 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1738 /* Calculate the trip count of the loop. */
1739 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1740 mpz_add (trip
, trip
, step
->value
.integer
);
1741 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1743 mpz_set (frame
.value
, start
->value
.integer
);
1745 frame
.prev
= iter_stack
;
1746 frame
.variable
= c
->iterator
->var
->symtree
;
1747 iter_stack
= &frame
;
1749 while (mpz_sgn (trip
) > 0)
1751 if (!expand_expr (c
->expr
))
1754 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1755 mpz_sub_ui (trip
, trip
, 1);
1761 gfc_free_expr (start
);
1762 gfc_free_expr (end
);
1763 gfc_free_expr (step
);
1766 mpz_clear (frame
.value
);
1768 iter_stack
= frame
.prev
;
1773 /* Variables for noticing if all constructors are empty, and
1774 if any of them had a type. */
1776 static bool empty_constructor
;
1777 static gfc_typespec empty_ts
;
1779 /* Expand a constructor into constant constructors without any
1780 iterators, calling the work function for each of the expanded
1781 expressions. The work function needs to either save or free the
1782 passed expression. */
1785 expand_constructor (gfc_constructor_base base
)
1790 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1792 if (c
->iterator
!= NULL
)
1794 if (!expand_iterator (c
))
1804 if (empty_constructor
)
1807 if (e
->expr_type
== EXPR_ARRAY
)
1809 if (!expand_constructor (e
->value
.constructor
))
1815 empty_constructor
= false;
1816 e
= gfc_copy_expr (e
);
1817 if (!gfc_simplify_expr (e
, 1))
1822 e
->from_constructor
= 1;
1823 current_expand
.offset
= &c
->offset
;
1824 current_expand
.repeat
= &c
->repeat
;
1825 current_expand
.component
= c
->n
.component
;
1826 if (!current_expand
.expand_work_function(e
))
1833 /* Given an array expression and an element number (starting at zero),
1834 return a pointer to the array element. NULL is returned if the
1835 size of the array has been exceeded. The expression node returned
1836 remains a part of the array and should not be freed. Access is not
1837 efficient at all, but this is another place where things do not
1838 have to be particularly fast. */
1841 gfc_get_array_element (gfc_expr
*array
, int element
)
1843 expand_info expand_save
;
1847 expand_save
= current_expand
;
1848 current_expand
.extract_n
= element
;
1849 current_expand
.expand_work_function
= extract_element
;
1850 current_expand
.extracted
= NULL
;
1851 current_expand
.extract_count
= 0;
1855 rc
= expand_constructor (array
->value
.constructor
);
1856 e
= current_expand
.extracted
;
1857 current_expand
= expand_save
;
1866 /* Top level subroutine for expanding constructors. We only expand
1867 constructor if they are small enough. */
1870 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1872 expand_info expand_save
;
1876 /* If we can successfully get an array element at the max array size then
1877 the array is too big to expand, so we just return. */
1878 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1884 gfc_error ("The number of elements in the array constructor "
1885 "at %L requires an increase of the allowed %d "
1886 "upper limit. See %<-fmax-array-constructor%> "
1887 "option", &e
->where
, flag_max_array_constructor
);
1893 /* We now know the array is not too big so go ahead and try to expand it. */
1894 expand_save
= current_expand
;
1895 current_expand
.base
= NULL
;
1899 empty_constructor
= true;
1900 gfc_clear_ts (&empty_ts
);
1901 current_expand
.expand_work_function
= expand
;
1903 if (!expand_constructor (e
->value
.constructor
))
1905 gfc_constructor_free (current_expand
.base
);
1910 /* If we don't have an explicit constructor type, and there
1911 were only empty constructors, then take the type from
1914 if (constructor_ts
.type
== BT_UNKNOWN
&& empty_constructor
)
1917 gfc_constructor_free (e
->value
.constructor
);
1918 e
->value
.constructor
= current_expand
.base
;
1923 current_expand
= expand_save
;
1929 /* Work function for checking that an element of a constructor is a
1930 constant, after removal of any iteration variables. We return
1934 is_constant_element (gfc_expr
*e
)
1938 rv
= gfc_is_constant_expr (e
);
1941 return rv
? true : false;
1945 /* Given an array constructor, determine if the constructor is
1946 constant or not by expanding it and making sure that all elements
1947 are constants. This is a bit of a hack since something like (/ (i,
1948 i=1,100000000) /) will take a while as* opposed to a more clever
1949 function that traverses the expression tree. FIXME. */
1952 gfc_constant_ac (gfc_expr
*e
)
1954 expand_info expand_save
;
1958 expand_save
= current_expand
;
1959 current_expand
.expand_work_function
= is_constant_element
;
1961 rc
= expand_constructor (e
->value
.constructor
);
1963 current_expand
= expand_save
;
1971 /* Returns nonzero if an array constructor has been completely
1972 expanded (no iterators) and zero if iterators are present. */
1975 gfc_expanded_ac (gfc_expr
*e
)
1979 if (e
->expr_type
== EXPR_ARRAY
)
1980 for (c
= gfc_constructor_first (e
->value
.constructor
);
1981 c
; c
= gfc_constructor_next (c
))
1982 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
1989 /*************** Type resolution of array constructors ***************/
1992 /* The symbol expr_is_sought_symbol_ref will try to find. */
1993 static const gfc_symbol
*sought_symbol
= NULL
;
1996 /* Tells whether the expression E is a variable reference to the symbol
1997 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
1999 To be used with gfc_expr_walker: if a reference is found we don't need
2000 to look further so we return 1 to skip any further walk. */
2003 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2006 gfc_expr
*expr
= *e
;
2007 locus
*sym_loc
= (locus
*)where
;
2009 if (expr
->expr_type
== EXPR_VARIABLE
2010 && expr
->symtree
->n
.sym
== sought_symbol
)
2012 *sym_loc
= expr
->where
;
2020 /* Tells whether the expression EXPR contains a reference to the symbol
2021 SYM and in that case sets the position SYM_LOC where the reference is. */
2024 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
2028 sought_symbol
= sym
;
2029 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
2030 sought_symbol
= NULL
;
2035 /* Recursive array list resolution function. All of the elements must
2036 be of the same type. */
2039 resolve_array_list (gfc_constructor_base base
)
2047 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2052 gfc_symbol
*iter_var
;
2055 if (!gfc_resolve_iterator (iter
, false, true))
2058 /* Check for bounds referencing the iterator variable. */
2059 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
2060 iter_var
= iter
->var
->symtree
->n
.sym
;
2061 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
2063 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
2064 "expression references control variable "
2065 "at %L", &iter_var_loc
))
2068 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
2070 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
2071 "expression references control variable "
2072 "at %L", &iter_var_loc
))
2075 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
2077 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
2078 "expression references control variable "
2079 "at %L", &iter_var_loc
))
2084 if (!gfc_resolve_expr (c
->expr
))
2087 if (UNLIMITED_POLY (c
->expr
))
2089 gfc_error ("Array constructor value at %L shall not be unlimited "
2090 "polymorphic [F2008: C4106]", &c
->expr
->where
);
2098 /* Resolve character array constructor. If it has a specified constant character
2099 length, pad/truncate the elements here; if the length is not specified and
2100 all elements are of compile-time known length, emit an error as this is
2104 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
2107 HOST_WIDE_INT found_length
;
2109 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
2110 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2112 if (expr
->ts
.u
.cl
== NULL
)
2114 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2115 p
; p
= gfc_constructor_next (p
))
2116 if (p
->expr
->ts
.u
.cl
!= NULL
)
2118 /* Ensure that if there is a char_len around that it is
2119 used; otherwise the middle-end confuses them! */
2120 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2124 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2129 /* Early exit for zero size arrays. */
2133 HOST_WIDE_INT arraysize
;
2135 gfc_array_size (expr
, &size
);
2136 arraysize
= mpz_get_ui (size
);
2145 if (expr
->ts
.u
.cl
->length
== NULL
)
2147 /* Check that all constant string elements have the same length until
2148 we reach the end or find a variable-length one. */
2150 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2151 p
; p
= gfc_constructor_next (p
))
2153 HOST_WIDE_INT current_length
= -1;
2155 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2156 if (ref
->type
== REF_SUBSTRING
2158 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2160 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2163 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2164 current_length
= p
->expr
->value
.character
.length
;
2166 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2167 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2168 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2169 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2170 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2174 if (current_length
< 0)
2177 if (found_length
== -1)
2178 found_length
= current_length
;
2179 else if (found_length
!= current_length
)
2181 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2182 " constructor at %L", (long) found_length
,
2183 (long) current_length
, &p
->expr
->where
);
2187 gcc_assert (found_length
== current_length
);
2190 gcc_assert (found_length
!= -1);
2192 /* Update the character length of the array constructor. */
2193 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2194 NULL
, found_length
);
2198 /* We've got a character length specified. It should be an integer,
2199 otherwise an error is signalled elsewhere. */
2200 gcc_assert (expr
->ts
.u
.cl
->length
);
2202 /* If we've got a constant character length, pad according to this.
2203 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2204 max_length only if they pass. */
2205 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2207 /* Now pad/truncate the elements accordingly to the specified character
2208 length. This is ok inside this conditional, as in the case above
2209 (without typespec) all elements are verified to have the same length
2211 if (found_length
!= -1)
2212 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2213 p
; p
= gfc_constructor_next (p
))
2214 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2216 gfc_expr
*cl
= NULL
;
2217 HOST_WIDE_INT current_length
= -1;
2220 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2222 cl
= p
->expr
->ts
.u
.cl
->length
;
2223 gfc_extract_hwi (cl
, ¤t_length
);
2226 /* If gfc_extract_int above set current_length, we implicitly
2227 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2229 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2232 || (current_length
!= -1 && current_length
!= found_length
))
2233 gfc_set_constant_character_len (found_length
, p
->expr
,
2234 has_ts
? -1 : found_length
);
2242 /* Resolve all of the expressions in an array list. */
2245 gfc_resolve_array_constructor (gfc_expr
*expr
)
2249 t
= resolve_array_list (expr
->value
.constructor
);
2251 t
= gfc_check_constructor_type (expr
);
2253 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2254 the call to this function, so we don't need to call it here; if it was
2255 called twice, an error message there would be duplicated. */
2261 /* Copy an iterator structure. */
2264 gfc_copy_iterator (gfc_iterator
*src
)
2271 dest
= gfc_get_iterator ();
2273 dest
->var
= gfc_copy_expr (src
->var
);
2274 dest
->start
= gfc_copy_expr (src
->start
);
2275 dest
->end
= gfc_copy_expr (src
->end
);
2276 dest
->step
= gfc_copy_expr (src
->step
);
2277 dest
->unroll
= src
->unroll
;
2278 dest
->ivdep
= src
->ivdep
;
2279 dest
->vector
= src
->vector
;
2280 dest
->novector
= src
->novector
;
2286 /********* Subroutines for determining the size of an array *********/
2288 /* These are needed just to accommodate RESHAPE(). There are no
2289 diagnostics here, we just return a negative number if something
2293 /* Get the size of single dimension of an array specification. The
2294 array is guaranteed to be one dimensional. */
2297 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2302 if (dimen
< 0 || dimen
> as
->rank
- 1)
2303 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2305 if (as
->type
!= AS_EXPLICIT
2306 || !as
->lower
[dimen
]
2307 || !as
->upper
[dimen
])
2310 if (as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2311 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2312 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2313 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2318 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2319 as
->lower
[dimen
]->value
.integer
);
2321 mpz_add_ui (*result
, *result
, 1);
2328 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2333 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2336 mpz_init_set_ui (*result
, 1);
2338 for (d
= 0; d
< as
->rank
; d
++)
2340 if (!spec_dimen_size (as
, d
, &size
))
2342 mpz_clear (*result
);
2346 mpz_mul (*result
, *result
, size
);
2354 /* Get the number of elements in an array section. Optionally, also supply
2358 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2360 mpz_t upper
, lower
, stride
;
2363 gfc_expr
*stride_expr
= NULL
;
2365 if (dimen
< 0 || ar
== NULL
)
2366 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2368 if (dimen
> ar
->dimen
- 1)
2370 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2374 switch (ar
->dimen_type
[dimen
])
2378 mpz_set_ui (*result
, 1);
2383 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2390 if (ar
->stride
[dimen
] == NULL
)
2391 mpz_set_ui (stride
, 1);
2394 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2396 if(!gfc_simplify_expr(stride_expr
, 1))
2397 gfc_internal_error("Simplification error");
2399 if (stride_expr
->expr_type
!= EXPR_CONSTANT
2400 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2405 mpz_set (stride
, stride_expr
->value
.integer
);
2406 gfc_free_expr(stride_expr
);
2409 /* Calculate the number of elements via gfc_dep_differce, but only if
2410 start and end are both supplied in the reference or the array spec.
2411 This is to guard against strange but valid code like
2416 print *,size(a(n-1:))
2418 where the user changes the value of a variable. If we have to
2419 determine end as well, we cannot do this using gfc_dep_difference.
2420 Fall back to the constants-only code then. */
2426 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2428 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2429 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2430 ar
->as
->lower
[dimen
], &diff
);
2435 mpz_add (*result
, diff
, stride
);
2436 mpz_div (*result
, *result
, stride
);
2437 if (mpz_cmp_ui (*result
, 0) < 0)
2438 mpz_set_ui (*result
, 0);
2447 /* Constant-only code here, which covers more cases
2453 if (ar
->start
[dimen
] == NULL
)
2455 if (ar
->as
->lower
[dimen
] == NULL
2456 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2457 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2459 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2463 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2465 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2468 if (ar
->end
[dimen
] == NULL
)
2470 if (ar
->as
->upper
[dimen
] == NULL
2471 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2472 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2474 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2478 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2480 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2484 mpz_sub (*result
, upper
, lower
);
2485 mpz_add (*result
, *result
, stride
);
2486 mpz_div (*result
, *result
, stride
);
2488 /* Zero stride caught earlier. */
2489 if (mpz_cmp_ui (*result
, 0) < 0)
2490 mpz_set_ui (*result
, 0);
2497 mpz_sub_ui (*end
, *result
, 1UL);
2498 mpz_mul (*end
, *end
, stride
);
2499 mpz_add (*end
, *end
, lower
);
2509 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2517 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2522 mpz_init_set_ui (*result
, 1);
2524 for (d
= 0; d
< ar
->dimen
; d
++)
2526 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2528 mpz_clear (*result
);
2532 mpz_mul (*result
, *result
, size
);
2540 /* Given an array expression and a dimension, figure out how many
2541 elements it has along that dimension. Returns true if we were
2542 able to return a result in the 'result' variable, false
2546 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2551 gcc_assert (array
!= NULL
);
2553 if (array
->ts
.type
== BT_CLASS
)
2556 if (array
->rank
== -1)
2559 if (dimen
< 0 || dimen
> array
->rank
- 1)
2560 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2562 switch (array
->expr_type
)
2566 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2568 if (ref
->type
!= REF_ARRAY
)
2571 if (ref
->u
.ar
.type
== AR_FULL
)
2572 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2574 if (ref
->u
.ar
.type
== AR_SECTION
)
2576 for (i
= 0; dimen
>= 0; i
++)
2577 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2580 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2586 mpz_init_set (*result
, array
->shape
[dimen
]);
2590 if (array
->symtree
->n
.sym
->attr
.generic
2591 && array
->value
.function
.esym
!= NULL
)
2593 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2596 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2602 if (array
->shape
== NULL
) {
2603 /* Expressions with rank > 1 should have "shape" properly set */
2604 if ( array
->rank
!= 1 )
2605 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2606 return gfc_array_size(array
, result
);
2611 if (array
->shape
== NULL
)
2614 mpz_init_set (*result
, array
->shape
[dimen
]);
2623 /* Given an array expression, figure out how many elements are in the
2624 array. Returns true if this is possible, and sets the 'result'
2625 variable. Otherwise returns false. */
2628 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2630 expand_info expand_save
;
2635 if (array
->ts
.type
== BT_CLASS
)
2638 switch (array
->expr_type
)
2641 gfc_push_suppress_errors ();
2643 expand_save
= current_expand
;
2645 current_expand
.count
= result
;
2646 mpz_init_set_ui (*result
, 0);
2648 current_expand
.expand_work_function
= count_elements
;
2651 t
= expand_constructor (array
->value
.constructor
);
2653 gfc_pop_suppress_errors ();
2656 mpz_clear (*result
);
2657 current_expand
= expand_save
;
2661 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2663 if (ref
->type
!= REF_ARRAY
)
2666 if (ref
->u
.ar
.type
== AR_FULL
)
2667 return spec_size (ref
->u
.ar
.as
, result
);
2669 if (ref
->u
.ar
.type
== AR_SECTION
)
2670 return ref_size (&ref
->u
.ar
, result
);
2673 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2677 if (array
->rank
== 0 || array
->shape
== NULL
)
2680 mpz_init_set_ui (*result
, 1);
2682 for (i
= 0; i
< array
->rank
; i
++)
2683 mpz_mul (*result
, *result
, array
->shape
[i
]);
2692 /* Given an array reference, return the shape of the reference in an
2693 array of mpz_t integers. */
2696 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2706 for (; d
< ar
->as
->rank
; d
++)
2707 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2713 for (i
= 0; i
< ar
->dimen
; i
++)
2715 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2717 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2730 gfc_clear_shape (shape
, d
);
2735 /* Given an array expression, find the array reference structure that
2736 characterizes the reference. */
2739 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2743 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2744 if (ref
->type
== REF_ARRAY
2745 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2753 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2760 /* Find out if an array shape is known at compile time. */
2763 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2765 if (as
->type
!= AS_EXPLICIT
)
2768 for (int i
= 0; i
< as
->rank
; i
++)
2769 if (!gfc_is_constant_expr (as
->lower
[i
])
2770 || !gfc_is_constant_expr (as
->upper
[i
]))