2 Copyright (C) 2000-2024 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
->cotype
!= as2
->cotype
)
1023 if (as1
->type
== AS_EXPLICIT
)
1024 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
1026 if (!compare_bounds (as1
->lower
[i
], as2
->lower
[i
]))
1029 if (!compare_bounds (as1
->upper
[i
], as2
->upper
[i
]))
1037 /****************** Array constructor functions ******************/
1040 /* Given an expression node that might be an array constructor and a
1041 symbol, make sure that no iterators in this or child constructors
1042 use the symbol as an implied-DO iterator. Returns nonzero if a
1043 duplicate was found. */
1046 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
1051 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1055 if (e
->expr_type
== EXPR_ARRAY
1056 && check_duplicate_iterator (e
->value
.constructor
, master
))
1059 if (c
->iterator
== NULL
)
1062 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
1064 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1065 "same name", master
->name
, &c
->where
);
1075 /* Forward declaration because these functions are mutually recursive. */
1076 static match
match_array_cons_element (gfc_constructor_base
*);
1078 /* Match a list of array elements. */
1081 match_array_list (gfc_constructor_base
*result
)
1083 gfc_constructor_base head
;
1091 old_loc
= gfc_current_locus
;
1093 if (gfc_match_char ('(') == MATCH_NO
)
1096 memset (&iter
, '\0', sizeof (gfc_iterator
));
1099 m
= match_array_cons_element (&head
);
1103 if (gfc_match_char (',') != MATCH_YES
)
1111 m
= gfc_match_iterator (&iter
, 0);
1114 if (m
== MATCH_ERROR
)
1117 m
= match_array_cons_element (&head
);
1118 if (m
== MATCH_ERROR
)
1125 goto cleanup
; /* Could be a complex constant */
1128 if (gfc_match_char (',') != MATCH_YES
)
1137 if (gfc_match_char (')') != MATCH_YES
)
1140 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1146 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1147 e
->value
.constructor
= head
;
1149 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1150 p
->iterator
= gfc_get_iterator ();
1151 *p
->iterator
= iter
;
1156 gfc_error ("Syntax error in array constructor at %C");
1160 gfc_constructor_free (head
);
1161 gfc_free_iterator (&iter
, 0);
1162 gfc_current_locus
= old_loc
;
1167 /* Match a single element of an array constructor, which can be a
1168 single expression or a list of elements. */
1171 match_array_cons_element (gfc_constructor_base
*result
)
1176 m
= match_array_list (result
);
1180 m
= gfc_match_expr (&expr
);
1184 if (expr
->ts
.type
== BT_BOZ
)
1186 gfc_error ("BOZ literal constant at %L cannot appear in an "
1187 "array constructor", &expr
->where
);
1191 if (expr
->expr_type
== EXPR_FUNCTION
1192 && expr
->ts
.type
== BT_UNKNOWN
1193 && strcmp(expr
->symtree
->name
, "null") == 0)
1195 gfc_error ("NULL() at %C cannot appear in an array constructor");
1199 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1203 gfc_free_expr (expr
);
1208 /* Convert components of an array constructor to the type in ts. */
1211 walk_array_constructor (gfc_typespec
*ts
, gfc_constructor_base head
)
1217 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1220 if (e
->expr_type
== EXPR_ARRAY
&& e
->ts
.type
== BT_UNKNOWN
1221 && !e
->ref
&& e
->value
.constructor
)
1223 m
= walk_array_constructor (ts
, e
->value
.constructor
);
1224 if (m
== MATCH_ERROR
)
1227 else if (!gfc_convert_type_warn (e
, ts
, 1, 1, true)
1228 && e
->ts
.type
!= BT_UNKNOWN
)
1234 /* Match an array constructor. */
1237 gfc_match_array_constructor (gfc_expr
**result
)
1240 gfc_constructor_base head
;
1245 const char *end_delim
;
1251 if (gfc_match (" (/") == MATCH_NO
)
1253 if (gfc_match (" [") == MATCH_NO
)
1257 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1258 "style array constructors at %C"))
1266 where
= gfc_current_locus
;
1268 /* Try to match an optional "type-spec ::" */
1270 m
= gfc_match_type_spec (&ts
);
1273 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1277 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1278 "including type specification at %C"))
1283 gfc_error ("Type-spec at %L cannot contain a deferred "
1284 "type parameter", &where
);
1288 if (ts
.type
== BT_CHARACTER
1289 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1291 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1292 "type parameter", &where
);
1297 else if (m
== MATCH_ERROR
)
1301 gfc_current_locus
= where
;
1303 if (gfc_match (end_delim
) == MATCH_YES
)
1309 gfc_error ("Empty array constructor at %C is not allowed");
1316 m
= match_array_cons_element (&head
);
1317 if (m
== MATCH_ERROR
)
1322 if (gfc_match_char (',') == MATCH_NO
)
1326 if (gfc_match (end_delim
) == MATCH_NO
)
1330 /* Size must be calculated at resolution time. */
1333 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1336 /* If the typespec is CHARACTER, check that array elements can
1337 be converted. See PR fortran/67803. */
1338 if (ts
.type
== BT_CHARACTER
)
1340 c
= gfc_constructor_first (head
);
1341 for (; c
; c
= gfc_constructor_next (c
))
1343 if (gfc_numeric_ts (&c
->expr
->ts
)
1344 || c
->expr
->ts
.type
== BT_LOGICAL
)
1346 gfc_error ("Incompatible typespec for array element at %L",
1351 /* Special case null(). */
1352 if (c
->expr
->expr_type
== EXPR_FUNCTION
1353 && c
->expr
->ts
.type
== BT_UNKNOWN
1354 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1356 gfc_error ("Incompatible typespec for array element at %L",
1363 /* Walk the constructor, and if possible, do type conversion for
1365 if (gfc_numeric_ts (&ts
))
1367 m
= walk_array_constructor (&ts
, head
);
1368 if (m
== MATCH_ERROR
)
1373 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1375 expr
->value
.constructor
= head
;
1377 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1384 gfc_error ("Syntax error in array constructor at %C");
1387 gfc_constructor_free (head
);
1393 /************** Check array constructors for correctness **************/
1395 /* Given an expression, compare it's type with the type of the current
1396 constructor. Returns nonzero if an error was issued. The
1397 cons_state variable keeps track of whether the type of the
1398 constructor being read or resolved is known to be good, bad or just
1401 static gfc_typespec constructor_ts
;
1403 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1407 check_element_type (gfc_expr
*expr
, bool convert
)
1409 if (cons_state
== CONS_BAD
)
1410 return 0; /* Suppress further errors */
1412 if (cons_state
== CONS_START
)
1414 if (expr
->ts
.type
== BT_UNKNOWN
)
1415 cons_state
= CONS_BAD
;
1418 cons_state
= CONS_GOOD
;
1419 constructor_ts
= expr
->ts
;
1425 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1429 return gfc_convert_type_warn (expr
, &constructor_ts
, 1, 1, true) ? 0 : 1;
1431 gfc_error ("Element in %s array constructor at %L is %s",
1432 gfc_typename (&constructor_ts
), &expr
->where
,
1433 gfc_typename (expr
));
1435 cons_state
= CONS_BAD
;
1440 /* Recursive work function for gfc_check_constructor_type(). */
1443 check_constructor_type (gfc_constructor_base base
, bool convert
)
1448 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1452 if (e
->expr_type
== EXPR_ARRAY
)
1454 if (!check_constructor_type (e
->value
.constructor
, convert
))
1460 if (check_element_type (e
, convert
))
1468 /* Check that all elements of an array constructor are the same type.
1469 On false, an error has been generated. */
1472 gfc_check_constructor_type (gfc_expr
*e
)
1476 if (e
->ts
.type
!= BT_UNKNOWN
)
1478 cons_state
= CONS_GOOD
;
1479 constructor_ts
= e
->ts
;
1483 cons_state
= CONS_START
;
1484 gfc_clear_ts (&constructor_ts
);
1487 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1488 typespec, and we will now convert the values on the fly. */
1489 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1490 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1491 e
->ts
= constructor_ts
;
1498 typedef struct cons_stack
1500 gfc_iterator
*iterator
;
1501 struct cons_stack
*previous
;
1505 static cons_stack
*base
;
1507 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1509 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1510 that that variable is an iteration variable. */
1513 gfc_check_iter_variable (gfc_expr
*expr
)
1518 sym
= expr
->symtree
->n
.sym
;
1520 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1521 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1528 /* Recursive work function for gfc_check_constructor(). This amounts
1529 to calling the check function for each expression in the
1530 constructor, giving variables with the names of iterators a pass. */
1533 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1540 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1547 if (e
->expr_type
!= EXPR_ARRAY
)
1549 if (!(*check_function
)(e
))
1554 element
.previous
= base
;
1555 element
.iterator
= c
->iterator
;
1558 t
= check_constructor (e
->value
.constructor
, check_function
);
1559 base
= element
.previous
;
1565 /* Nothing went wrong, so all OK. */
1570 /* Checks a constructor to see if it is a particular kind of
1571 expression -- specification, restricted, or initialization as
1572 determined by the check_function. */
1575 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1577 cons_stack
*base_save
;
1583 t
= check_constructor (expr
->value
.constructor
, check_function
);
1591 /**************** Simplification of array constructors ****************/
1593 iterator_stack
*iter_stack
;
1597 gfc_constructor_base base
;
1598 int extract_count
, extract_n
;
1599 gfc_expr
*extracted
;
1603 gfc_component
*component
;
1606 bool (*expand_work_function
) (gfc_expr
*);
1610 static expand_info current_expand
;
1612 static bool expand_constructor (gfc_constructor_base
);
1615 /* Work function that counts the number of elements present in a
1619 count_elements (gfc_expr
*e
)
1624 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1627 if (!gfc_array_size (e
, &result
))
1633 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1642 /* Work function that extracts a particular element from an array
1643 constructor, freeing the rest. */
1646 extract_element (gfc_expr
*e
)
1649 { /* Something unextractable */
1654 if (current_expand
.extract_count
== current_expand
.extract_n
)
1655 current_expand
.extracted
= e
;
1659 current_expand
.extract_count
++;
1665 /* Work function that constructs a new constructor out of the old one,
1666 stringing new elements together. */
1669 expand (gfc_expr
*e
)
1671 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1674 c
->n
.component
= current_expand
.component
;
1679 /* Given an initialization expression that is a variable reference,
1680 substitute the current value of the iteration variable. */
1683 gfc_simplify_iterator_var (gfc_expr
*e
)
1687 for (p
= iter_stack
; p
; p
= p
->prev
)
1688 if (e
->symtree
== p
->variable
)
1692 return; /* Variable not found */
1694 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1696 mpz_set (e
->value
.integer
, p
->value
);
1702 /* Expand an expression with that is inside of a constructor,
1703 recursing into other constructors if present. */
1706 expand_expr (gfc_expr
*e
)
1708 if (e
->expr_type
== EXPR_ARRAY
)
1709 return expand_constructor (e
->value
.constructor
);
1711 e
= gfc_copy_expr (e
);
1713 if (!gfc_simplify_expr (e
, 1))
1719 return current_expand
.expand_work_function (e
);
1724 expand_iterator (gfc_constructor
*c
)
1726 gfc_expr
*start
, *end
, *step
;
1727 iterator_stack frame
;
1736 mpz_init (frame
.value
);
1739 start
= gfc_copy_expr (c
->iterator
->start
);
1740 if (!gfc_simplify_expr (start
, 1))
1743 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1746 end
= gfc_copy_expr (c
->iterator
->end
);
1747 if (!gfc_simplify_expr (end
, 1))
1750 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1753 step
= gfc_copy_expr (c
->iterator
->step
);
1754 if (!gfc_simplify_expr (step
, 1))
1757 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1760 if (mpz_sgn (step
->value
.integer
) == 0)
1762 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1766 /* Calculate the trip count of the loop. */
1767 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1768 mpz_add (trip
, trip
, step
->value
.integer
);
1769 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1771 mpz_set (frame
.value
, start
->value
.integer
);
1773 frame
.prev
= iter_stack
;
1774 frame
.variable
= c
->iterator
->var
->symtree
;
1775 iter_stack
= &frame
;
1777 while (mpz_sgn (trip
) > 0)
1779 if (!expand_expr (c
->expr
))
1782 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1783 mpz_sub_ui (trip
, trip
, 1);
1789 gfc_free_expr (start
);
1790 gfc_free_expr (end
);
1791 gfc_free_expr (step
);
1794 mpz_clear (frame
.value
);
1796 iter_stack
= frame
.prev
;
1801 /* Variables for noticing if all constructors are empty, and
1802 if any of them had a type. */
1804 static bool empty_constructor
;
1805 static gfc_typespec empty_ts
;
1807 /* Expand a constructor into constant constructors without any
1808 iterators, calling the work function for each of the expanded
1809 expressions. The work function needs to either save or free the
1810 passed expression. */
1813 expand_constructor (gfc_constructor_base base
)
1818 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1820 if (c
->iterator
!= NULL
)
1822 if (!expand_iterator (c
))
1832 if (empty_constructor
)
1835 /* Simplify constant array expression/section within constructor. */
1836 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0 && e
->ref
1837 && e
->symtree
&& e
->symtree
->n
.sym
1838 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1839 gfc_simplify_expr (e
, 0);
1841 if (e
->expr_type
== EXPR_ARRAY
)
1843 if (!expand_constructor (e
->value
.constructor
))
1849 empty_constructor
= false;
1850 e
= gfc_copy_expr (e
);
1851 if (!gfc_simplify_expr (e
, 1))
1856 e
->from_constructor
= 1;
1857 current_expand
.offset
= &c
->offset
;
1858 current_expand
.repeat
= &c
->repeat
;
1859 current_expand
.component
= c
->n
.component
;
1860 if (!current_expand
.expand_work_function(e
))
1867 /* Given an array expression and an element number (starting at zero),
1868 return a pointer to the array element. NULL is returned if the
1869 size of the array has been exceeded. The expression node returned
1870 remains a part of the array and should not be freed. Access is not
1871 efficient at all, but this is another place where things do not
1872 have to be particularly fast. */
1875 gfc_get_array_element (gfc_expr
*array
, int element
)
1877 expand_info expand_save
;
1881 expand_save
= current_expand
;
1882 current_expand
.extract_n
= element
;
1883 current_expand
.expand_work_function
= extract_element
;
1884 current_expand
.extracted
= NULL
;
1885 current_expand
.extract_count
= 0;
1889 rc
= expand_constructor (array
->value
.constructor
);
1890 e
= current_expand
.extracted
;
1891 current_expand
= expand_save
;
1900 /* Top level subroutine for expanding constructors. We only expand
1901 constructor if they are small enough. */
1904 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1906 expand_info expand_save
;
1910 if (gfc_is_size_zero_array (e
))
1913 /* If we can successfully get an array element at the max array size then
1914 the array is too big to expand, so we just return. */
1915 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1921 gfc_error ("The number of elements in the array constructor "
1922 "at %L requires an increase of the allowed %d "
1923 "upper limit. See %<-fmax-array-constructor%> "
1924 "option", &e
->where
, flag_max_array_constructor
);
1930 /* We now know the array is not too big so go ahead and try to expand it. */
1931 expand_save
= current_expand
;
1932 current_expand
.base
= NULL
;
1936 empty_constructor
= true;
1937 gfc_clear_ts (&empty_ts
);
1938 current_expand
.expand_work_function
= expand
;
1940 if (!expand_constructor (e
->value
.constructor
))
1942 gfc_constructor_free (current_expand
.base
);
1947 /* If we don't have an explicit constructor type, and there
1948 were only empty constructors, then take the type from
1951 if (constructor_ts
.type
== BT_UNKNOWN
&& empty_constructor
)
1954 gfc_constructor_free (e
->value
.constructor
);
1955 e
->value
.constructor
= current_expand
.base
;
1960 current_expand
= expand_save
;
1966 /* Work function for checking that an element of a constructor is a
1967 constant, after removal of any iteration variables. We return
1971 is_constant_element (gfc_expr
*e
)
1975 rv
= gfc_is_constant_expr (e
);
1978 return rv
? true : false;
1982 /* Given an array constructor, determine if the constructor is
1983 constant or not by expanding it and making sure that all elements
1984 are constants. This is a bit of a hack since something like (/ (i,
1985 i=1,100000000) /) will take a while as* opposed to a more clever
1986 function that traverses the expression tree. FIXME. */
1989 gfc_constant_ac (gfc_expr
*e
)
1991 expand_info expand_save
;
1995 expand_save
= current_expand
;
1996 current_expand
.expand_work_function
= is_constant_element
;
1998 rc
= expand_constructor (e
->value
.constructor
);
2000 current_expand
= expand_save
;
2008 /* Returns nonzero if an array constructor has been completely
2009 expanded (no iterators) and zero if iterators are present. */
2012 gfc_expanded_ac (gfc_expr
*e
)
2016 if (e
->expr_type
== EXPR_ARRAY
)
2017 for (c
= gfc_constructor_first (e
->value
.constructor
);
2018 c
; c
= gfc_constructor_next (c
))
2019 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
2026 /*************** Type resolution of array constructors ***************/
2029 /* The symbol expr_is_sought_symbol_ref will try to find. */
2030 static const gfc_symbol
*sought_symbol
= NULL
;
2033 /* Tells whether the expression E is a variable reference to the symbol
2034 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
2036 To be used with gfc_expr_walker: if a reference is found we don't need
2037 to look further so we return 1 to skip any further walk. */
2040 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2043 gfc_expr
*expr
= *e
;
2044 locus
*sym_loc
= (locus
*)where
;
2046 if (expr
->expr_type
== EXPR_VARIABLE
2047 && expr
->symtree
->n
.sym
== sought_symbol
)
2049 *sym_loc
= expr
->where
;
2057 /* Tells whether the expression EXPR contains a reference to the symbol
2058 SYM and in that case sets the position SYM_LOC where the reference is. */
2061 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
2065 sought_symbol
= sym
;
2066 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
2067 sought_symbol
= NULL
;
2072 /* Recursive array list resolution function. All of the elements must
2073 be of the same type. */
2076 resolve_array_list (gfc_constructor_base base
)
2084 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2089 gfc_symbol
*iter_var
;
2092 if (!gfc_resolve_iterator (iter
, false, true))
2095 /* Check for bounds referencing the iterator variable. */
2096 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
2097 iter_var
= iter
->var
->symtree
->n
.sym
;
2098 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
2100 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
2101 "expression references control variable "
2102 "at %L", &iter_var_loc
))
2105 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
2107 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
2108 "expression references control variable "
2109 "at %L", &iter_var_loc
))
2112 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
2114 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
2115 "expression references control variable "
2116 "at %L", &iter_var_loc
))
2121 if (!gfc_resolve_expr (c
->expr
))
2124 if (UNLIMITED_POLY (c
->expr
))
2126 gfc_error ("Array constructor value at %L shall not be unlimited "
2127 "polymorphic [F2008: C4106]", &c
->expr
->where
);
2135 /* Resolve character array constructor. If it has a specified constant character
2136 length, pad/truncate the elements here; if the length is not specified and
2137 all elements are of compile-time known length, emit an error as this is
2141 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
2144 HOST_WIDE_INT found_length
;
2146 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
2147 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2149 if (expr
->ts
.u
.cl
== NULL
)
2151 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2152 p
; p
= gfc_constructor_next (p
))
2153 if (p
->expr
->ts
.u
.cl
!= NULL
)
2155 /* Ensure that if there is a char_len around that it is
2156 used; otherwise the middle-end confuses them! */
2157 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2161 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2166 /* Early exit for zero size arrays. */
2170 HOST_WIDE_INT arraysize
;
2172 gfc_array_size (expr
, &size
);
2173 arraysize
= mpz_get_ui (size
);
2182 if (expr
->ts
.u
.cl
->length
== NULL
)
2184 /* Check that all constant string elements have the same length until
2185 we reach the end or find a variable-length one. */
2187 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2188 p
; p
= gfc_constructor_next (p
))
2190 HOST_WIDE_INT current_length
= -1;
2192 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2193 if (ref
->type
== REF_SUBSTRING
2195 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2197 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2200 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2201 current_length
= p
->expr
->value
.character
.length
;
2203 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2204 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2205 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2206 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2207 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2211 if (current_length
< 0)
2214 if (found_length
== -1)
2215 found_length
= current_length
;
2216 else if (found_length
!= current_length
)
2218 gfc_error ("Different CHARACTER lengths (%wd/%wd) in array"
2219 " constructor at %L", found_length
,
2220 current_length
, &p
->expr
->where
);
2224 gcc_assert (found_length
== current_length
);
2227 gcc_assert (found_length
!= -1);
2229 /* Update the character length of the array constructor. */
2230 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2231 NULL
, found_length
);
2235 /* We've got a character length specified. It should be an integer,
2236 otherwise an error is signalled elsewhere. */
2237 gcc_assert (expr
->ts
.u
.cl
->length
);
2239 /* If we've got a constant character length, pad according to this.
2240 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2241 max_length only if they pass. */
2242 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2244 /* Now pad/truncate the elements accordingly to the specified character
2245 length. This is ok inside this conditional, as in the case above
2246 (without typespec) all elements are verified to have the same length
2248 if (found_length
!= -1)
2249 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2250 p
; p
= gfc_constructor_next (p
))
2251 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2253 gfc_expr
*cl
= NULL
;
2254 HOST_WIDE_INT current_length
= -1;
2257 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2259 cl
= p
->expr
->ts
.u
.cl
->length
;
2260 gfc_extract_hwi (cl
, ¤t_length
);
2263 /* If gfc_extract_int above set current_length, we implicitly
2264 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2266 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2269 || (current_length
!= -1 && current_length
!= found_length
))
2270 gfc_set_constant_character_len (found_length
, p
->expr
,
2271 has_ts
? -1 : found_length
);
2279 /* Resolve all of the expressions in an array list. */
2282 gfc_resolve_array_constructor (gfc_expr
*expr
)
2286 t
= resolve_array_list (expr
->value
.constructor
);
2288 t
= gfc_check_constructor_type (expr
);
2290 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2291 the call to this function, so we don't need to call it here; if it was
2292 called twice, an error message there would be duplicated. */
2298 /* Copy an iterator structure. */
2301 gfc_copy_iterator (gfc_iterator
*src
)
2308 dest
= gfc_get_iterator ();
2310 dest
->var
= gfc_copy_expr (src
->var
);
2311 dest
->start
= gfc_copy_expr (src
->start
);
2312 dest
->end
= gfc_copy_expr (src
->end
);
2313 dest
->step
= gfc_copy_expr (src
->step
);
2314 dest
->annot
= src
->annot
;
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 /* Ultimate component is a procedure pointer. */
2604 if (ref
->type
== REF_COMPONENT
2606 && ref
->u
.c
.component
->attr
.function
2607 && IS_PROC_POINTER (ref
->u
.c
.component
))
2610 if (ref
->type
!= REF_ARRAY
)
2613 if (ref
->u
.ar
.type
== AR_FULL
)
2614 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2616 if (ref
->u
.ar
.type
== AR_SECTION
)
2618 for (i
= 0; dimen
>= 0; i
++)
2619 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2622 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2628 mpz_init_set (*result
, array
->shape
[dimen
]);
2632 if (array
->symtree
->n
.sym
->attr
.generic
2633 && array
->value
.function
.esym
!= NULL
)
2635 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2638 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2644 if (array
->shape
== NULL
) {
2645 /* Expressions with rank > 1 should have "shape" properly set */
2646 if ( array
->rank
!= 1 )
2647 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2648 return gfc_array_size(array
, result
);
2653 if (array
->shape
== NULL
)
2656 mpz_init_set (*result
, array
->shape
[dimen
]);
2665 /* Given an array expression, figure out how many elements are in the
2666 array. Returns true if this is possible, and sets the 'result'
2667 variable. Otherwise returns false. */
2670 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2672 expand_info expand_save
;
2677 if (array
->ts
.type
== BT_CLASS
)
2680 switch (array
->expr_type
)
2683 gfc_push_suppress_errors ();
2685 expand_save
= current_expand
;
2687 current_expand
.count
= result
;
2688 mpz_init_set_ui (*result
, 0);
2690 current_expand
.expand_work_function
= count_elements
;
2693 t
= expand_constructor (array
->value
.constructor
);
2695 gfc_pop_suppress_errors ();
2698 mpz_clear (*result
);
2699 current_expand
= expand_save
;
2703 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2705 if (ref
->type
!= REF_ARRAY
)
2708 if (ref
->u
.ar
.type
== AR_FULL
)
2709 return spec_size (ref
->u
.ar
.as
, result
);
2711 if (ref
->u
.ar
.type
== AR_SECTION
)
2712 return ref_size (&ref
->u
.ar
, result
);
2715 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2719 if (array
->rank
== 0 || array
->shape
== NULL
)
2722 mpz_init_set_ui (*result
, 1);
2724 for (i
= 0; i
< array
->rank
; i
++)
2725 mpz_mul (*result
, *result
, array
->shape
[i
]);
2734 /* Given an array reference, return the shape of the reference in an
2735 array of mpz_t integers. */
2738 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2748 for (; d
< ar
->as
->rank
; d
++)
2749 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2755 for (i
= 0; i
< ar
->dimen
; i
++)
2757 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2759 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2772 gfc_clear_shape (shape
, d
);
2777 /* Given an array expression, find the array reference structure that
2778 characterizes the reference. */
2781 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2785 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2786 if (ref
->type
== REF_ARRAY
2787 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2795 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2802 /* Find out if an array shape is known at compile time. */
2805 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2807 if (as
->type
!= AS_EXPLICIT
)
2810 for (int i
= 0; i
< as
->rank
; i
++)
2811 if (!gfc_is_constant_expr (as
->lower
[i
])
2812 || !gfc_is_constant_expr (as
->upper
[i
]))