2 Copyright (C) 2000-2023 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 if (star
&& ar
->start
[i
] == NULL
)
139 gfc_error ("Missing lower bound in assumed size "
140 "coarray specification at %C");
144 /* See if we have an optional stride. */
145 if (gfc_match_char (':') == MATCH_YES
)
149 gfc_error ("Strides not allowed in coarray subscript at %C");
153 m
= init
? gfc_match_init_expr (&ar
->stride
[i
])
154 : gfc_match_expr (&ar
->stride
[i
]);
156 if (ar
->stride
[i
] && ar
->stride
[i
]->ts
.type
== BT_BOZ
)
158 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
163 gfc_error ("Expected array subscript stride at %C");
170 ar
->dimen_type
[i
] = DIMEN_STAR
;
172 return (saw_boz
? MATCH_ERROR
: MATCH_YES
);
176 /* Match an array reference, whether it is the whole array or particular
177 elements or a section. If init is set, the reference has to consist
178 of init expressions. */
181 gfc_match_array_ref (gfc_array_ref
*ar
, gfc_array_spec
*as
, int init
,
185 bool matched_bracket
= false;
187 bool stat_just_seen
= false;
188 bool team_just_seen
= false;
190 memset (ar
, '\0', sizeof (*ar
));
192 ar
->where
= gfc_current_locus
;
194 ar
->type
= AR_UNKNOWN
;
196 if (gfc_match_char ('[') == MATCH_YES
)
198 matched_bracket
= true;
202 if (gfc_match_char ('(') != MATCH_YES
)
209 for (ar
->dimen
= 0; ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->dimen
++)
211 m
= match_subscript (ar
, init
, false);
212 if (m
== MATCH_ERROR
)
215 if (gfc_match_char (')') == MATCH_YES
)
221 if (gfc_match_char (',') != MATCH_YES
)
223 gfc_error ("Invalid form of array reference at %C");
229 && !gfc_notify_std (GFC_STD_F2008
,
230 "Array reference at %C has more than 7 dimensions"))
233 gfc_error ("Array reference at %C cannot have more than %d dimensions",
238 if (!matched_bracket
&& gfc_match_char ('[') != MATCH_YES
)
246 if (flag_coarray
== GFC_FCOARRAY_NONE
)
248 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
254 gfc_error ("Unexpected coarray designator at %C");
260 for (ar
->codimen
= 0; ar
->codimen
+ ar
->dimen
< GFC_MAX_DIMENSIONS
; ar
->codimen
++)
262 m
= match_subscript (ar
, init
, true);
263 if (m
== MATCH_ERROR
)
266 team_just_seen
= false;
267 stat_just_seen
= false;
268 if (gfc_match (" , team = %e", &tmp
) == MATCH_YES
&& ar
->team
== NULL
)
271 team_just_seen
= true;
274 if (ar
->team
&& !team_just_seen
)
276 gfc_error ("TEAM= attribute in %C misplaced");
280 if (gfc_match (" , stat = %e",&tmp
) == MATCH_YES
&& ar
->stat
== NULL
)
283 stat_just_seen
= true;
286 if (ar
->stat
&& !stat_just_seen
)
288 gfc_error ("STAT= attribute in %C misplaced");
292 if (gfc_match_char (']') == MATCH_YES
)
295 if (ar
->codimen
< corank
)
297 gfc_error ("Too few codimensions at %C, expected %d not %d",
298 corank
, ar
->codimen
);
301 if (ar
->codimen
> corank
)
303 gfc_error ("Too many codimensions at %C, expected %d not %d",
304 corank
, ar
->codimen
);
310 if (gfc_match_char (',') != MATCH_YES
)
312 if (gfc_match_char ('*') == MATCH_YES
)
313 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
314 ar
->codimen
+ 1, corank
);
316 gfc_error ("Invalid form of coarray reference at %C");
319 else if (ar
->dimen_type
[ar
->codimen
+ ar
->dimen
] == DIMEN_STAR
)
321 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
322 ar
->codimen
+ 1, corank
);
326 if (ar
->codimen
>= corank
)
328 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
329 ar
->codimen
+ 1, corank
);
334 gfc_error ("Array reference at %C cannot have more than %d dimensions",
341 /************** Array specification matching subroutines ***************/
343 /* Free all of the expressions associated with array bounds
347 gfc_free_array_spec (gfc_array_spec
*as
)
356 for (i
= 0; i
< as
->rank
; i
++)
358 gfc_free_expr (as
->lower
[i
]);
359 gfc_free_expr (as
->upper
[i
]);
364 int n
= as
->rank
+ as
->corank
- (as
->cotype
== AS_EXPLICIT
? 1 : 0);
365 for (i
= 0; i
< n
; i
++)
367 gfc_free_expr (as
->lower
[i
]);
368 gfc_free_expr (as
->upper
[i
]);
376 /* Take an array bound, resolves the expression, that make up the
377 shape and check associated constraints. */
380 resolve_array_bound (gfc_expr
*e
, int check_constant
)
385 if (!gfc_resolve_expr (e
)
386 || !gfc_specification_expr (e
))
389 if (check_constant
&& !gfc_is_constant_expr (e
))
391 if (e
->expr_type
== EXPR_VARIABLE
)
392 gfc_error ("Variable %qs at %L in this context must be constant",
393 e
->symtree
->n
.sym
->name
, &e
->where
);
395 gfc_error ("Expression at %L in this context must be constant",
404 /* Takes an array specification, resolves the expressions that make up
405 the shape and make sure everything is integral. */
408 gfc_resolve_array_spec (gfc_array_spec
*as
, int check_constant
)
419 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
421 if (i
== GFC_MAX_DIMENSIONS
)
425 if (!resolve_array_bound (e
, check_constant
))
429 if (!resolve_array_bound (e
, check_constant
))
432 if ((as
->lower
[i
] == NULL
) || (as
->upper
[i
] == NULL
))
435 /* If the size is negative in this dimension, set it to zero. */
436 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
437 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
438 && mpz_cmp (as
->upper
[i
]->value
.integer
,
439 as
->lower
[i
]->value
.integer
) < 0)
441 gfc_free_expr (as
->upper
[i
]);
442 as
->upper
[i
] = gfc_copy_expr (as
->lower
[i
]);
443 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
444 as
->upper
[i
]->value
.integer
, 1);
454 /* Match a single array element specification. The return values as
455 well as the upper and lower bounds of the array spec are filled
456 in according to what we see on the input. The caller makes sure
457 individual specifications make sense as a whole.
460 Parsed Lower Upper Returned
461 ------------------------------------
462 : NULL NULL AS_DEFERRED (*)
464 x: x NULL AS_ASSUMED_SHAPE
466 x:* x NULL AS_ASSUMED_SIZE
467 * 1 NULL AS_ASSUMED_SIZE
469 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
470 is fixed during the resolution of formal interfaces.
472 Anything else AS_UNKNOWN. */
475 match_array_element_spec (gfc_array_spec
*as
)
477 gfc_expr
**upper
, **lower
;
481 rank
= as
->rank
== -1 ? 0 : as
->rank
;
482 lower
= &as
->lower
[rank
+ as
->corank
- 1];
483 upper
= &as
->upper
[rank
+ as
->corank
- 1];
485 if (gfc_match_char ('*') == MATCH_YES
)
487 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
488 return AS_ASSUMED_SIZE
;
491 if (gfc_match_char (':') == MATCH_YES
)
493 locus old_loc
= gfc_current_locus
;
494 if (gfc_match_char ('*') == MATCH_YES
)
496 /* F2018:R821: "assumed-implied-spec is [ lower-bound : ] *". */
497 gfc_error ("A lower bound must precede colon in "
498 "assumed-size array specification at %L", &old_loc
);
507 m
= gfc_match_expr (upper
);
509 gfc_error ("Expected expression in array specification at %C");
512 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
515 if (((*upper
)->expr_type
== EXPR_CONSTANT
516 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
517 ((*upper
)->expr_type
== EXPR_FUNCTION
518 && (*upper
)->ts
.type
== BT_UNKNOWN
520 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
522 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
523 gfc_basic_typename ((*upper
)->ts
.type
));
527 if (gfc_match_char (':') == MATCH_NO
)
529 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
536 if (gfc_match_char ('*') == MATCH_YES
)
537 return AS_ASSUMED_SIZE
;
539 m
= gfc_match_expr (upper
);
540 if (m
== MATCH_ERROR
)
543 return AS_ASSUMED_SHAPE
;
544 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
547 if (((*upper
)->expr_type
== EXPR_CONSTANT
548 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
549 ((*upper
)->expr_type
== EXPR_FUNCTION
550 && (*upper
)->ts
.type
== BT_UNKNOWN
552 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
554 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
555 gfc_basic_typename ((*upper
)->ts
.type
));
563 /* Matches an array specification, incidentally figuring out what sort
564 it is. Match either a normal array specification, or a coarray spec
565 or both. Optionally allow [:] for coarrays. */
568 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
570 array_type current_type
;
574 as
= gfc_get_array_spec ();
579 if (gfc_match_char ('(') != MATCH_YES
)
586 if (gfc_match (" .. )") == MATCH_YES
)
588 as
->type
= AS_ASSUMED_RANK
;
591 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed-rank array at %C"))
602 current_type
= match_array_element_spec (as
);
603 if (current_type
== AS_UNKNOWN
)
606 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
607 and implied-shape specifications. If the rank is at least 2, we can
608 distinguish between them. But for rank 1, we currently return
609 ASSUMED_SIZE; this gets adjusted later when we know for sure
610 whether the symbol parsed is a PARAMETER or not. */
614 as
->type
= current_type
;
618 { /* See how current spec meshes with the existing. */
622 case AS_IMPLIED_SHAPE
:
623 if (current_type
!= AS_ASSUMED_SIZE
)
625 gfc_error ("Bad array specification for implied-shape"
632 if (current_type
== AS_ASSUMED_SIZE
)
634 as
->type
= AS_ASSUMED_SIZE
;
638 if (current_type
== AS_EXPLICIT
)
641 gfc_error ("Bad array specification for an explicitly shaped "
646 case AS_ASSUMED_SHAPE
:
647 if ((current_type
== AS_ASSUMED_SHAPE
)
648 || (current_type
== AS_DEFERRED
))
651 gfc_error ("Bad array specification for assumed shape "
656 if (current_type
== AS_DEFERRED
)
659 if (current_type
== AS_ASSUMED_SHAPE
)
661 as
->type
= AS_ASSUMED_SHAPE
;
665 gfc_error ("Bad specification for deferred shape array at %C");
668 case AS_ASSUMED_SIZE
:
669 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
671 as
->type
= AS_IMPLIED_SHAPE
;
675 gfc_error ("Bad specification for assumed size array at %C");
678 case AS_ASSUMED_RANK
:
682 if (gfc_match_char (')') == MATCH_YES
)
685 if (gfc_match_char (',') != MATCH_YES
)
687 gfc_error ("Expected another dimension in array declaration at %C");
691 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
693 gfc_error ("Array specification at %C has more than %d dimensions",
698 if (as
->corank
+ as
->rank
>= 7
699 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
700 "with more than 7 dimensions"))
708 if (gfc_match_char ('[') != MATCH_YES
)
711 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
714 if (flag_coarray
== GFC_FCOARRAY_NONE
)
716 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
720 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
722 gfc_error ("Array specification at %C has more than %d "
723 "dimensions", GFC_MAX_DIMENSIONS
);
730 current_type
= match_array_element_spec (as
);
732 if (current_type
== AS_UNKNOWN
)
736 as
->cotype
= current_type
;
739 { /* See how current spec meshes with the existing. */
740 case AS_IMPLIED_SHAPE
:
745 if (current_type
== AS_ASSUMED_SIZE
)
747 as
->cotype
= AS_ASSUMED_SIZE
;
751 if (current_type
== AS_EXPLICIT
)
754 gfc_error ("Bad array specification for an explicitly "
755 "shaped array at %C");
759 case AS_ASSUMED_SHAPE
:
760 if ((current_type
== AS_ASSUMED_SHAPE
)
761 || (current_type
== AS_DEFERRED
))
764 gfc_error ("Bad array specification for assumed shape "
769 if (current_type
== AS_DEFERRED
)
772 if (current_type
== AS_ASSUMED_SHAPE
)
774 as
->cotype
= AS_ASSUMED_SHAPE
;
778 gfc_error ("Bad specification for deferred shape array at %C");
781 case AS_ASSUMED_SIZE
:
782 gfc_error ("Bad specification for assumed size array at %C");
785 case AS_ASSUMED_RANK
:
789 if (gfc_match_char (']') == MATCH_YES
)
792 if (gfc_match_char (',') != MATCH_YES
)
794 gfc_error ("Expected another dimension in array declaration at %C");
798 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
800 gfc_error ("Array specification at %C has more than %d "
801 "dimensions", GFC_MAX_DIMENSIONS
);
806 if (current_type
== AS_EXPLICIT
)
808 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
812 if (as
->cotype
== AS_ASSUMED_SIZE
)
813 as
->cotype
= AS_EXPLICIT
;
816 as
->type
= as
->cotype
;
819 if (as
->rank
== 0 && as
->corank
== 0)
822 gfc_free_array_spec (as
);
826 /* If a lower bounds of an assumed shape array is blank, put in one. */
827 if (as
->type
== AS_ASSUMED_SHAPE
)
829 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
831 if (as
->lower
[i
] == NULL
)
832 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
841 /* Something went wrong. */
842 gfc_free_array_spec (as
);
846 /* Given a symbol and an array specification, modify the symbol to
847 have that array specification. The error locus is needed in case
848 something goes wrong. On failure, the caller must free the spec. */
851 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
854 symbol_attribute
*attr
;
859 /* If the symbol corresponds to a submodule module procedure the array spec is
860 already set, so do not attempt to set it again here. */
862 if (gfc_submodule_procedure(attr
))
866 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
870 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
879 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
880 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
882 gfc_error ("The assumed-rank array %qs at %L shall not have a "
883 "codimension", sym
->name
, error_loc
);
887 /* Check F2018:C822. */
888 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
893 sym
->as
->cotype
= as
->cotype
;
894 sym
->as
->corank
= as
->corank
;
895 /* Check F2018:C822. */
896 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
899 for (i
= 0; i
< as
->corank
; i
++)
901 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
902 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
907 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
908 the dimension is added - but first the codimensions (if existing
909 need to be shifted to make space for the dimension. */
910 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
912 sym
->as
->rank
= as
->rank
;
913 sym
->as
->type
= as
->type
;
914 sym
->as
->cray_pointee
= as
->cray_pointee
;
915 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
917 /* Check F2018:C822. */
918 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
921 for (i
= sym
->as
->corank
- 1; i
>= 0; i
--)
923 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
924 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
926 for (i
= 0; i
< as
->rank
; i
++)
928 sym
->as
->lower
[i
] = as
->lower
[i
];
929 sym
->as
->upper
[i
] = as
->upper
[i
];
938 gfc_error ("rank + corank of %qs exceeds %d at %C", sym
->name
,
944 /* Copy an array specification. */
947 gfc_copy_array_spec (gfc_array_spec
*src
)
949 gfc_array_spec
*dest
;
955 dest
= gfc_get_array_spec ();
959 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
961 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
962 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
969 /* Returns nonzero if the two expressions are equal.
970 We should not need to support more than constant values, as that's what is
971 allowed in derived type component array spec. However, we may create types
972 with non-constant array spec for dummy variable class container types, for
973 which the _data component holds the array spec of the variable declaration.
974 So we have to support non-constant bounds as well. */
977 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
979 if (bound1
== NULL
|| bound2
== NULL
980 || bound1
->ts
.type
!= BT_INTEGER
981 || bound2
->ts
.type
!= BT_INTEGER
)
984 /* What qualifies as identical bounds? We could probably just check that the
985 expressions are exact clones. We avoid rewriting a specific comparison
986 function and re-use instead the rather involved gfc_dep_compare_expr which
987 is just a bit more permissive, as it can also detect identical values for
988 some mismatching expressions (extra parenthesis, swapped operands, unary
989 plus, etc). It probably only makes a difference in corner cases. */
990 return gfc_dep_compare_expr (bound1
, bound2
) == 0;
994 /* Compares two array specifications. They must be constant or deferred
998 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
1002 if (as1
== NULL
&& as2
== NULL
)
1005 if (as1
== NULL
|| as2
== NULL
)
1008 if (as1
->rank
!= as2
->rank
)
1011 if (as1
->corank
!= as2
->corank
)
1017 if (as1
->type
!= as2
->type
)
1020 if (as1
->type
== AS_EXPLICIT
)
1021 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
1023 if (!compare_bounds (as1
->lower
[i
], as2
->lower
[i
]))
1026 if (!compare_bounds (as1
->upper
[i
], as2
->upper
[i
]))
1034 /****************** Array constructor functions ******************/
1037 /* Given an expression node that might be an array constructor and a
1038 symbol, make sure that no iterators in this or child constructors
1039 use the symbol as an implied-DO iterator. Returns nonzero if a
1040 duplicate was found. */
1043 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
1048 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1052 if (e
->expr_type
== EXPR_ARRAY
1053 && check_duplicate_iterator (e
->value
.constructor
, master
))
1056 if (c
->iterator
== NULL
)
1059 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
1061 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1062 "same name", master
->name
, &c
->where
);
1072 /* Forward declaration because these functions are mutually recursive. */
1073 static match
match_array_cons_element (gfc_constructor_base
*);
1075 /* Match a list of array elements. */
1078 match_array_list (gfc_constructor_base
*result
)
1080 gfc_constructor_base head
;
1088 old_loc
= gfc_current_locus
;
1090 if (gfc_match_char ('(') == MATCH_NO
)
1093 memset (&iter
, '\0', sizeof (gfc_iterator
));
1096 m
= match_array_cons_element (&head
);
1100 if (gfc_match_char (',') != MATCH_YES
)
1108 m
= gfc_match_iterator (&iter
, 0);
1111 if (m
== MATCH_ERROR
)
1114 m
= match_array_cons_element (&head
);
1115 if (m
== MATCH_ERROR
)
1122 goto cleanup
; /* Could be a complex constant */
1125 if (gfc_match_char (',') != MATCH_YES
)
1134 if (gfc_match_char (')') != MATCH_YES
)
1137 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1143 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1144 e
->value
.constructor
= head
;
1146 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1147 p
->iterator
= gfc_get_iterator ();
1148 *p
->iterator
= iter
;
1153 gfc_error ("Syntax error in array constructor at %C");
1157 gfc_constructor_free (head
);
1158 gfc_free_iterator (&iter
, 0);
1159 gfc_current_locus
= old_loc
;
1164 /* Match a single element of an array constructor, which can be a
1165 single expression or a list of elements. */
1168 match_array_cons_element (gfc_constructor_base
*result
)
1173 m
= match_array_list (result
);
1177 m
= gfc_match_expr (&expr
);
1181 if (expr
->ts
.type
== BT_BOZ
)
1183 gfc_error ("BOZ literal constant at %L cannot appear in an "
1184 "array constructor", &expr
->where
);
1188 if (expr
->expr_type
== EXPR_FUNCTION
1189 && expr
->ts
.type
== BT_UNKNOWN
1190 && strcmp(expr
->symtree
->name
, "null") == 0)
1192 gfc_error ("NULL() at %C cannot appear in an array constructor");
1196 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1200 gfc_free_expr (expr
);
1205 /* Convert components of an array constructor to the type in ts. */
1208 walk_array_constructor (gfc_typespec
*ts
, gfc_constructor_base head
)
1214 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1217 if (e
->expr_type
== EXPR_ARRAY
&& e
->ts
.type
== BT_UNKNOWN
1218 && !e
->ref
&& e
->value
.constructor
)
1220 m
= walk_array_constructor (ts
, e
->value
.constructor
);
1221 if (m
== MATCH_ERROR
)
1224 else if (!gfc_convert_type_warn (e
, ts
, 1, 1, true)
1225 && e
->ts
.type
!= BT_UNKNOWN
)
1231 /* Match an array constructor. */
1234 gfc_match_array_constructor (gfc_expr
**result
)
1237 gfc_constructor_base head
;
1242 const char *end_delim
;
1248 if (gfc_match (" (/") == MATCH_NO
)
1250 if (gfc_match (" [") == MATCH_NO
)
1254 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1255 "style array constructors at %C"))
1263 where
= gfc_current_locus
;
1265 /* Try to match an optional "type-spec ::" */
1267 m
= gfc_match_type_spec (&ts
);
1270 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1274 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1275 "including type specification at %C"))
1280 gfc_error ("Type-spec at %L cannot contain a deferred "
1281 "type parameter", &where
);
1285 if (ts
.type
== BT_CHARACTER
1286 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1288 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1289 "type parameter", &where
);
1294 else if (m
== MATCH_ERROR
)
1298 gfc_current_locus
= where
;
1300 if (gfc_match (end_delim
) == MATCH_YES
)
1306 gfc_error ("Empty array constructor at %C is not allowed");
1313 m
= match_array_cons_element (&head
);
1314 if (m
== MATCH_ERROR
)
1319 if (gfc_match_char (',') == MATCH_NO
)
1323 if (gfc_match (end_delim
) == MATCH_NO
)
1327 /* Size must be calculated at resolution time. */
1330 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1333 /* If the typespec is CHARACTER, check that array elements can
1334 be converted. See PR fortran/67803. */
1335 if (ts
.type
== BT_CHARACTER
)
1337 c
= gfc_constructor_first (head
);
1338 for (; c
; c
= gfc_constructor_next (c
))
1340 if (gfc_numeric_ts (&c
->expr
->ts
)
1341 || c
->expr
->ts
.type
== BT_LOGICAL
)
1343 gfc_error ("Incompatible typespec for array element at %L",
1348 /* Special case null(). */
1349 if (c
->expr
->expr_type
== EXPR_FUNCTION
1350 && c
->expr
->ts
.type
== BT_UNKNOWN
1351 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1353 gfc_error ("Incompatible typespec for array element at %L",
1360 /* Walk the constructor, and if possible, do type conversion for
1362 if (gfc_numeric_ts (&ts
))
1364 m
= walk_array_constructor (&ts
, head
);
1365 if (m
== MATCH_ERROR
)
1370 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1372 expr
->value
.constructor
= head
;
1374 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1381 gfc_error ("Syntax error in array constructor at %C");
1384 gfc_constructor_free (head
);
1390 /************** Check array constructors for correctness **************/
1392 /* Given an expression, compare it's type with the type of the current
1393 constructor. Returns nonzero if an error was issued. The
1394 cons_state variable keeps track of whether the type of the
1395 constructor being read or resolved is known to be good, bad or just
1398 static gfc_typespec constructor_ts
;
1400 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1404 check_element_type (gfc_expr
*expr
, bool convert
)
1406 if (cons_state
== CONS_BAD
)
1407 return 0; /* Suppress further errors */
1409 if (cons_state
== CONS_START
)
1411 if (expr
->ts
.type
== BT_UNKNOWN
)
1412 cons_state
= CONS_BAD
;
1415 cons_state
= CONS_GOOD
;
1416 constructor_ts
= expr
->ts
;
1422 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1426 return gfc_convert_type_warn (expr
, &constructor_ts
, 1, 1, true) ? 0 : 1;
1428 gfc_error ("Element in %s array constructor at %L is %s",
1429 gfc_typename (&constructor_ts
), &expr
->where
,
1430 gfc_typename (expr
));
1432 cons_state
= CONS_BAD
;
1437 /* Recursive work function for gfc_check_constructor_type(). */
1440 check_constructor_type (gfc_constructor_base base
, bool convert
)
1445 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1449 if (e
->expr_type
== EXPR_ARRAY
)
1451 if (!check_constructor_type (e
->value
.constructor
, convert
))
1457 if (check_element_type (e
, convert
))
1465 /* Check that all elements of an array constructor are the same type.
1466 On false, an error has been generated. */
1469 gfc_check_constructor_type (gfc_expr
*e
)
1473 if (e
->ts
.type
!= BT_UNKNOWN
)
1475 cons_state
= CONS_GOOD
;
1476 constructor_ts
= e
->ts
;
1480 cons_state
= CONS_START
;
1481 gfc_clear_ts (&constructor_ts
);
1484 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1485 typespec, and we will now convert the values on the fly. */
1486 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1487 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1488 e
->ts
= constructor_ts
;
1495 typedef struct cons_stack
1497 gfc_iterator
*iterator
;
1498 struct cons_stack
*previous
;
1502 static cons_stack
*base
;
1504 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1506 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1507 that that variable is an iteration variable. */
1510 gfc_check_iter_variable (gfc_expr
*expr
)
1515 sym
= expr
->symtree
->n
.sym
;
1517 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1518 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1525 /* Recursive work function for gfc_check_constructor(). This amounts
1526 to calling the check function for each expression in the
1527 constructor, giving variables with the names of iterators a pass. */
1530 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1537 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1544 if (e
->expr_type
!= EXPR_ARRAY
)
1546 if (!(*check_function
)(e
))
1551 element
.previous
= base
;
1552 element
.iterator
= c
->iterator
;
1555 t
= check_constructor (e
->value
.constructor
, check_function
);
1556 base
= element
.previous
;
1562 /* Nothing went wrong, so all OK. */
1567 /* Checks a constructor to see if it is a particular kind of
1568 expression -- specification, restricted, or initialization as
1569 determined by the check_function. */
1572 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1574 cons_stack
*base_save
;
1580 t
= check_constructor (expr
->value
.constructor
, check_function
);
1588 /**************** Simplification of array constructors ****************/
1590 iterator_stack
*iter_stack
;
1594 gfc_constructor_base base
;
1595 int extract_count
, extract_n
;
1596 gfc_expr
*extracted
;
1600 gfc_component
*component
;
1603 bool (*expand_work_function
) (gfc_expr
*);
1607 static expand_info current_expand
;
1609 static bool expand_constructor (gfc_constructor_base
);
1612 /* Work function that counts the number of elements present in a
1616 count_elements (gfc_expr
*e
)
1621 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1624 if (!gfc_array_size (e
, &result
))
1630 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1639 /* Work function that extracts a particular element from an array
1640 constructor, freeing the rest. */
1643 extract_element (gfc_expr
*e
)
1646 { /* Something unextractable */
1651 if (current_expand
.extract_count
== current_expand
.extract_n
)
1652 current_expand
.extracted
= e
;
1656 current_expand
.extract_count
++;
1662 /* Work function that constructs a new constructor out of the old one,
1663 stringing new elements together. */
1666 expand (gfc_expr
*e
)
1668 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1671 c
->n
.component
= current_expand
.component
;
1676 /* Given an initialization expression that is a variable reference,
1677 substitute the current value of the iteration variable. */
1680 gfc_simplify_iterator_var (gfc_expr
*e
)
1684 for (p
= iter_stack
; p
; p
= p
->prev
)
1685 if (e
->symtree
== p
->variable
)
1689 return; /* Variable not found */
1691 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1693 mpz_set (e
->value
.integer
, p
->value
);
1699 /* Expand an expression with that is inside of a constructor,
1700 recursing into other constructors if present. */
1703 expand_expr (gfc_expr
*e
)
1705 if (e
->expr_type
== EXPR_ARRAY
)
1706 return expand_constructor (e
->value
.constructor
);
1708 e
= gfc_copy_expr (e
);
1710 if (!gfc_simplify_expr (e
, 1))
1716 return current_expand
.expand_work_function (e
);
1721 expand_iterator (gfc_constructor
*c
)
1723 gfc_expr
*start
, *end
, *step
;
1724 iterator_stack frame
;
1733 mpz_init (frame
.value
);
1736 start
= gfc_copy_expr (c
->iterator
->start
);
1737 if (!gfc_simplify_expr (start
, 1))
1740 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1743 end
= gfc_copy_expr (c
->iterator
->end
);
1744 if (!gfc_simplify_expr (end
, 1))
1747 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1750 step
= gfc_copy_expr (c
->iterator
->step
);
1751 if (!gfc_simplify_expr (step
, 1))
1754 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1757 if (mpz_sgn (step
->value
.integer
) == 0)
1759 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1763 /* Calculate the trip count of the loop. */
1764 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1765 mpz_add (trip
, trip
, step
->value
.integer
);
1766 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1768 mpz_set (frame
.value
, start
->value
.integer
);
1770 frame
.prev
= iter_stack
;
1771 frame
.variable
= c
->iterator
->var
->symtree
;
1772 iter_stack
= &frame
;
1774 while (mpz_sgn (trip
) > 0)
1776 if (!expand_expr (c
->expr
))
1779 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1780 mpz_sub_ui (trip
, trip
, 1);
1786 gfc_free_expr (start
);
1787 gfc_free_expr (end
);
1788 gfc_free_expr (step
);
1791 mpz_clear (frame
.value
);
1793 iter_stack
= frame
.prev
;
1798 /* Variables for noticing if all constructors are empty, and
1799 if any of them had a type. */
1801 static bool empty_constructor
;
1802 static gfc_typespec empty_ts
;
1804 /* Expand a constructor into constant constructors without any
1805 iterators, calling the work function for each of the expanded
1806 expressions. The work function needs to either save or free the
1807 passed expression. */
1810 expand_constructor (gfc_constructor_base base
)
1815 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1817 if (c
->iterator
!= NULL
)
1819 if (!expand_iterator (c
))
1829 if (empty_constructor
)
1832 /* Simplify constant array expression/section within constructor. */
1833 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0 && e
->ref
1834 && e
->symtree
&& e
->symtree
->n
.sym
1835 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1836 gfc_simplify_expr (e
, 0);
1838 if (e
->expr_type
== EXPR_ARRAY
)
1840 if (!expand_constructor (e
->value
.constructor
))
1846 empty_constructor
= false;
1847 e
= gfc_copy_expr (e
);
1848 if (!gfc_simplify_expr (e
, 1))
1853 e
->from_constructor
= 1;
1854 current_expand
.offset
= &c
->offset
;
1855 current_expand
.repeat
= &c
->repeat
;
1856 current_expand
.component
= c
->n
.component
;
1857 if (!current_expand
.expand_work_function(e
))
1864 /* Given an array expression and an element number (starting at zero),
1865 return a pointer to the array element. NULL is returned if the
1866 size of the array has been exceeded. The expression node returned
1867 remains a part of the array and should not be freed. Access is not
1868 efficient at all, but this is another place where things do not
1869 have to be particularly fast. */
1872 gfc_get_array_element (gfc_expr
*array
, int element
)
1874 expand_info expand_save
;
1878 expand_save
= current_expand
;
1879 current_expand
.extract_n
= element
;
1880 current_expand
.expand_work_function
= extract_element
;
1881 current_expand
.extracted
= NULL
;
1882 current_expand
.extract_count
= 0;
1886 rc
= expand_constructor (array
->value
.constructor
);
1887 e
= current_expand
.extracted
;
1888 current_expand
= expand_save
;
1897 /* Top level subroutine for expanding constructors. We only expand
1898 constructor if they are small enough. */
1901 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1903 expand_info expand_save
;
1907 if (gfc_is_size_zero_array (e
))
1910 /* If we can successfully get an array element at the max array size then
1911 the array is too big to expand, so we just return. */
1912 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1918 gfc_error ("The number of elements in the array constructor "
1919 "at %L requires an increase of the allowed %d "
1920 "upper limit. See %<-fmax-array-constructor%> "
1921 "option", &e
->where
, flag_max_array_constructor
);
1927 /* We now know the array is not too big so go ahead and try to expand it. */
1928 expand_save
= current_expand
;
1929 current_expand
.base
= NULL
;
1933 empty_constructor
= true;
1934 gfc_clear_ts (&empty_ts
);
1935 current_expand
.expand_work_function
= expand
;
1937 if (!expand_constructor (e
->value
.constructor
))
1939 gfc_constructor_free (current_expand
.base
);
1944 /* If we don't have an explicit constructor type, and there
1945 were only empty constructors, then take the type from
1948 if (constructor_ts
.type
== BT_UNKNOWN
&& empty_constructor
)
1951 gfc_constructor_free (e
->value
.constructor
);
1952 e
->value
.constructor
= current_expand
.base
;
1957 current_expand
= expand_save
;
1963 /* Work function for checking that an element of a constructor is a
1964 constant, after removal of any iteration variables. We return
1968 is_constant_element (gfc_expr
*e
)
1972 rv
= gfc_is_constant_expr (e
);
1975 return rv
? true : false;
1979 /* Given an array constructor, determine if the constructor is
1980 constant or not by expanding it and making sure that all elements
1981 are constants. This is a bit of a hack since something like (/ (i,
1982 i=1,100000000) /) will take a while as* opposed to a more clever
1983 function that traverses the expression tree. FIXME. */
1986 gfc_constant_ac (gfc_expr
*e
)
1988 expand_info expand_save
;
1992 expand_save
= current_expand
;
1993 current_expand
.expand_work_function
= is_constant_element
;
1995 rc
= expand_constructor (e
->value
.constructor
);
1997 current_expand
= expand_save
;
2005 /* Returns nonzero if an array constructor has been completely
2006 expanded (no iterators) and zero if iterators are present. */
2009 gfc_expanded_ac (gfc_expr
*e
)
2013 if (e
->expr_type
== EXPR_ARRAY
)
2014 for (c
= gfc_constructor_first (e
->value
.constructor
);
2015 c
; c
= gfc_constructor_next (c
))
2016 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
2023 /*************** Type resolution of array constructors ***************/
2026 /* The symbol expr_is_sought_symbol_ref will try to find. */
2027 static const gfc_symbol
*sought_symbol
= NULL
;
2030 /* Tells whether the expression E is a variable reference to the symbol
2031 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
2033 To be used with gfc_expr_walker: if a reference is found we don't need
2034 to look further so we return 1 to skip any further walk. */
2037 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2040 gfc_expr
*expr
= *e
;
2041 locus
*sym_loc
= (locus
*)where
;
2043 if (expr
->expr_type
== EXPR_VARIABLE
2044 && expr
->symtree
->n
.sym
== sought_symbol
)
2046 *sym_loc
= expr
->where
;
2054 /* Tells whether the expression EXPR contains a reference to the symbol
2055 SYM and in that case sets the position SYM_LOC where the reference is. */
2058 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
2062 sought_symbol
= sym
;
2063 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
2064 sought_symbol
= NULL
;
2069 /* Recursive array list resolution function. All of the elements must
2070 be of the same type. */
2073 resolve_array_list (gfc_constructor_base base
)
2081 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2086 gfc_symbol
*iter_var
;
2089 if (!gfc_resolve_iterator (iter
, false, true))
2092 /* Check for bounds referencing the iterator variable. */
2093 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
2094 iter_var
= iter
->var
->symtree
->n
.sym
;
2095 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
2097 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
2098 "expression references control variable "
2099 "at %L", &iter_var_loc
))
2102 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
2104 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
2105 "expression references control variable "
2106 "at %L", &iter_var_loc
))
2109 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
2111 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
2112 "expression references control variable "
2113 "at %L", &iter_var_loc
))
2118 if (!gfc_resolve_expr (c
->expr
))
2121 if (UNLIMITED_POLY (c
->expr
))
2123 gfc_error ("Array constructor value at %L shall not be unlimited "
2124 "polymorphic [F2008: C4106]", &c
->expr
->where
);
2132 /* Resolve character array constructor. If it has a specified constant character
2133 length, pad/truncate the elements here; if the length is not specified and
2134 all elements are of compile-time known length, emit an error as this is
2138 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
2141 HOST_WIDE_INT found_length
;
2143 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
2144 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2146 if (expr
->ts
.u
.cl
== NULL
)
2148 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2149 p
; p
= gfc_constructor_next (p
))
2150 if (p
->expr
->ts
.u
.cl
!= NULL
)
2152 /* Ensure that if there is a char_len around that it is
2153 used; otherwise the middle-end confuses them! */
2154 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2158 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2163 /* Early exit for zero size arrays. */
2167 HOST_WIDE_INT arraysize
;
2169 gfc_array_size (expr
, &size
);
2170 arraysize
= mpz_get_ui (size
);
2179 if (expr
->ts
.u
.cl
->length
== NULL
)
2181 /* Check that all constant string elements have the same length until
2182 we reach the end or find a variable-length one. */
2184 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2185 p
; p
= gfc_constructor_next (p
))
2187 HOST_WIDE_INT current_length
= -1;
2189 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2190 if (ref
->type
== REF_SUBSTRING
2192 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2194 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2197 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2198 current_length
= p
->expr
->value
.character
.length
;
2200 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2201 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2202 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2203 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2204 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2208 if (current_length
< 0)
2211 if (found_length
== -1)
2212 found_length
= current_length
;
2213 else if (found_length
!= current_length
)
2215 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2216 " constructor at %L", (long) found_length
,
2217 (long) current_length
, &p
->expr
->where
);
2221 gcc_assert (found_length
== current_length
);
2224 gcc_assert (found_length
!= -1);
2226 /* Update the character length of the array constructor. */
2227 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2228 NULL
, found_length
);
2232 /* We've got a character length specified. It should be an integer,
2233 otherwise an error is signalled elsewhere. */
2234 gcc_assert (expr
->ts
.u
.cl
->length
);
2236 /* If we've got a constant character length, pad according to this.
2237 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2238 max_length only if they pass. */
2239 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2241 /* Now pad/truncate the elements accordingly to the specified character
2242 length. This is ok inside this conditional, as in the case above
2243 (without typespec) all elements are verified to have the same length
2245 if (found_length
!= -1)
2246 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2247 p
; p
= gfc_constructor_next (p
))
2248 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2250 gfc_expr
*cl
= NULL
;
2251 HOST_WIDE_INT current_length
= -1;
2254 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2256 cl
= p
->expr
->ts
.u
.cl
->length
;
2257 gfc_extract_hwi (cl
, ¤t_length
);
2260 /* If gfc_extract_int above set current_length, we implicitly
2261 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2263 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2266 || (current_length
!= -1 && current_length
!= found_length
))
2267 gfc_set_constant_character_len (found_length
, p
->expr
,
2268 has_ts
? -1 : found_length
);
2276 /* Resolve all of the expressions in an array list. */
2279 gfc_resolve_array_constructor (gfc_expr
*expr
)
2283 t
= resolve_array_list (expr
->value
.constructor
);
2285 t
= gfc_check_constructor_type (expr
);
2287 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2288 the call to this function, so we don't need to call it here; if it was
2289 called twice, an error message there would be duplicated. */
2295 /* Copy an iterator structure. */
2298 gfc_copy_iterator (gfc_iterator
*src
)
2305 dest
= gfc_get_iterator ();
2307 dest
->var
= gfc_copy_expr (src
->var
);
2308 dest
->start
= gfc_copy_expr (src
->start
);
2309 dest
->end
= gfc_copy_expr (src
->end
);
2310 dest
->step
= gfc_copy_expr (src
->step
);
2311 dest
->unroll
= src
->unroll
;
2312 dest
->ivdep
= src
->ivdep
;
2313 dest
->vector
= src
->vector
;
2314 dest
->novector
= src
->novector
;
2320 /********* Subroutines for determining the size of an array *********/
2322 /* These are needed just to accommodate RESHAPE(). There are no
2323 diagnostics here, we just return false if something goes wrong. */
2326 /* Get the size of single dimension of an array specification. The
2327 array is guaranteed to be one dimensional. */
2330 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2335 if (dimen
< 0 || dimen
> as
->rank
- 1)
2336 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2338 if (as
->type
!= AS_EXPLICIT
2339 || !as
->lower
[dimen
]
2340 || !as
->upper
[dimen
])
2343 if (as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2344 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2345 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2346 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2351 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2352 as
->lower
[dimen
]->value
.integer
);
2354 mpz_add_ui (*result
, *result
, 1);
2356 if (mpz_cmp_si (*result
, 0) < 0)
2357 mpz_set_si (*result
, 0);
2364 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2369 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2372 mpz_init_set_ui (*result
, 1);
2374 for (d
= 0; d
< as
->rank
; d
++)
2376 if (!spec_dimen_size (as
, d
, &size
))
2378 mpz_clear (*result
);
2382 mpz_mul (*result
, *result
, size
);
2390 /* Get the number of elements in an array section. Optionally, also supply
2394 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2396 mpz_t upper
, lower
, stride
;
2399 gfc_expr
*stride_expr
= NULL
;
2401 if (dimen
< 0 || ar
== NULL
)
2402 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2404 if (dimen
> ar
->dimen
- 1)
2406 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2410 switch (ar
->dimen_type
[dimen
])
2414 mpz_set_ui (*result
, 1);
2419 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2426 if (ar
->stride
[dimen
] == NULL
)
2427 mpz_set_ui (stride
, 1);
2430 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2432 if (!gfc_simplify_expr (stride_expr
, 1)
2433 || stride_expr
->expr_type
!= EXPR_CONSTANT
2434 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2436 gfc_free_expr (stride_expr
);
2440 mpz_set (stride
, stride_expr
->value
.integer
);
2441 gfc_free_expr(stride_expr
);
2444 /* Calculate the number of elements via gfc_dep_difference, but only if
2445 start and end are both supplied in the reference or the array spec.
2446 This is to guard against strange but valid code like
2451 print *,size(a(n-1:))
2453 where the user changes the value of a variable. If we have to
2454 determine end as well, we cannot do this using gfc_dep_difference.
2455 Fall back to the constants-only code then. */
2461 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2463 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2464 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2465 ar
->as
->lower
[dimen
], &diff
);
2470 mpz_add (*result
, diff
, stride
);
2471 mpz_div (*result
, *result
, stride
);
2472 if (mpz_cmp_ui (*result
, 0) < 0)
2473 mpz_set_ui (*result
, 0);
2482 /* Constant-only code here, which covers more cases
2488 if (ar
->start
[dimen
] == NULL
)
2490 if (ar
->as
->lower
[dimen
] == NULL
2491 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2492 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2494 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2498 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2500 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2503 if (ar
->end
[dimen
] == NULL
)
2505 if (ar
->as
->upper
[dimen
] == NULL
2506 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2507 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2509 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2513 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2515 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2519 mpz_sub (*result
, upper
, lower
);
2520 mpz_add (*result
, *result
, stride
);
2521 mpz_div (*result
, *result
, stride
);
2523 /* Zero stride caught earlier. */
2524 if (mpz_cmp_ui (*result
, 0) < 0)
2525 mpz_set_ui (*result
, 0);
2532 mpz_sub_ui (*end
, *result
, 1UL);
2533 mpz_mul (*end
, *end
, stride
);
2534 mpz_add (*end
, *end
, lower
);
2544 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2552 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2557 mpz_init_set_ui (*result
, 1);
2559 for (d
= 0; d
< ar
->dimen
; d
++)
2561 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2563 mpz_clear (*result
);
2567 mpz_mul (*result
, *result
, size
);
2575 /* Given an array expression and a dimension, figure out how many
2576 elements it has along that dimension. Returns true if we were
2577 able to return a result in the 'result' variable, false
2581 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2586 gcc_assert (array
!= NULL
);
2588 if (array
->ts
.type
== BT_CLASS
)
2591 if (array
->rank
== -1)
2594 if (dimen
< 0 || dimen
> array
->rank
- 1)
2595 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2597 switch (array
->expr_type
)
2601 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2603 if (ref
->type
!= REF_ARRAY
)
2606 if (ref
->u
.ar
.type
== AR_FULL
)
2607 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2609 if (ref
->u
.ar
.type
== AR_SECTION
)
2611 for (i
= 0; dimen
>= 0; i
++)
2612 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2615 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2621 mpz_init_set (*result
, array
->shape
[dimen
]);
2625 if (array
->symtree
->n
.sym
->attr
.generic
2626 && array
->value
.function
.esym
!= NULL
)
2628 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2631 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2637 if (array
->shape
== NULL
) {
2638 /* Expressions with rank > 1 should have "shape" properly set */
2639 if ( array
->rank
!= 1 )
2640 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2641 return gfc_array_size(array
, result
);
2646 if (array
->shape
== NULL
)
2649 mpz_init_set (*result
, array
->shape
[dimen
]);
2658 /* Given an array expression, figure out how many elements are in the
2659 array. Returns true if this is possible, and sets the 'result'
2660 variable. Otherwise returns false. */
2663 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2665 expand_info expand_save
;
2670 if (array
->ts
.type
== BT_CLASS
)
2673 switch (array
->expr_type
)
2676 gfc_push_suppress_errors ();
2678 expand_save
= current_expand
;
2680 current_expand
.count
= result
;
2681 mpz_init_set_ui (*result
, 0);
2683 current_expand
.expand_work_function
= count_elements
;
2686 t
= expand_constructor (array
->value
.constructor
);
2688 gfc_pop_suppress_errors ();
2691 mpz_clear (*result
);
2692 current_expand
= expand_save
;
2696 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2698 if (ref
->type
!= REF_ARRAY
)
2701 if (ref
->u
.ar
.type
== AR_FULL
)
2702 return spec_size (ref
->u
.ar
.as
, result
);
2704 if (ref
->u
.ar
.type
== AR_SECTION
)
2705 return ref_size (&ref
->u
.ar
, result
);
2708 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2712 if (array
->rank
== 0 || array
->shape
== NULL
)
2715 mpz_init_set_ui (*result
, 1);
2717 for (i
= 0; i
< array
->rank
; i
++)
2718 mpz_mul (*result
, *result
, array
->shape
[i
]);
2727 /* Given an array reference, return the shape of the reference in an
2728 array of mpz_t integers. */
2731 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2741 for (; d
< ar
->as
->rank
; d
++)
2742 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2748 for (i
= 0; i
< ar
->dimen
; i
++)
2750 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2752 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2765 gfc_clear_shape (shape
, d
);
2770 /* Given an array expression, find the array reference structure that
2771 characterizes the reference. */
2774 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2778 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2779 if (ref
->type
== REF_ARRAY
2780 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2788 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2795 /* Find out if an array shape is known at compile time. */
2798 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2800 if (as
->type
!= AS_EXPLICIT
)
2803 for (int i
= 0; i
< as
->rank
; i
++)
2804 if (!gfc_is_constant_expr (as
->lower
[i
])
2805 || !gfc_is_constant_expr (as
->upper
[i
]))