2 Copyright (C) 2000-2022 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "constructor.h"
30 /**************** Array reference matching subroutines *****************/
32 /* Copy an array reference structure. */
35 gfc_copy_array_ref (gfc_array_ref
*src
)
43 dest
= gfc_get_array_ref ();
47 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
49 dest
->start
[i
] = gfc_copy_expr (src
->start
[i
]);
50 dest
->end
[i
] = gfc_copy_expr (src
->end
[i
]);
51 dest
->stride
[i
] = gfc_copy_expr (src
->stride
[i
]);
58 /* Match a single dimension of an array reference. This can be a
59 single element or an array section. Any modifications we've made
60 to the ar structure are cleaned up by the caller. If the init
61 is set, we require the subscript to be a valid initialization
65 match_subscript (gfc_array_ref
*ar
, int init
, bool match_star
)
67 match m
= MATCH_ERROR
;
72 i
= ar
->dimen
+ ar
->codimen
;
74 gfc_gobble_whitespace ();
75 ar
->c_where
[i
] = gfc_current_locus
;
76 ar
->start
[i
] = ar
->end
[i
] = ar
->stride
[i
] = NULL
;
78 /* We can't be sure of the difference between DIMEN_ELEMENT and
79 DIMEN_VECTOR until we know the type of the element itself at
82 ar
->dimen_type
[i
] = DIMEN_UNKNOWN
;
84 if (gfc_match_char (':') == MATCH_YES
)
87 /* Get start element. */
88 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
92 m
= gfc_match_init_expr (&ar
->start
[i
]);
94 m
= gfc_match_expr (&ar
->start
[i
]);
96 if (ar
->start
[i
] && ar
->start
[i
]->ts
.type
== BT_BOZ
)
98 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
103 gfc_error ("Expected array subscript at %C");
107 if (gfc_match_char (':') == MATCH_NO
)
112 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
116 /* Get an optional end element. Because we've seen the colon, we
117 definitely have a range along this dimension. */
119 ar
->dimen_type
[i
] = DIMEN_RANGE
;
121 if (match_star
&& (m
= gfc_match_char ('*')) == MATCH_YES
)
124 m
= gfc_match_init_expr (&ar
->end
[i
]);
126 m
= gfc_match_expr (&ar
->end
[i
]);
128 if (ar
->end
[i
] && ar
->end
[i
]->ts
.type
== BT_BOZ
)
130 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
134 if (m
== MATCH_ERROR
)
137 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
)
494 m
= gfc_match_expr (upper
);
496 gfc_error ("Expected expression in array specification at %C");
499 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
502 gfc_try_simplify_expr (*upper
, 0);
504 if (((*upper
)->expr_type
== EXPR_CONSTANT
505 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
506 ((*upper
)->expr_type
== EXPR_FUNCTION
507 && (*upper
)->ts
.type
== BT_UNKNOWN
509 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
511 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
512 gfc_basic_typename ((*upper
)->ts
.type
));
516 if (gfc_match_char (':') == MATCH_NO
)
518 *lower
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
525 if (gfc_match_char ('*') == MATCH_YES
)
526 return AS_ASSUMED_SIZE
;
528 m
= gfc_match_expr (upper
);
529 if (m
== MATCH_ERROR
)
532 return AS_ASSUMED_SHAPE
;
533 if (!gfc_expr_check_typed (*upper
, gfc_current_ns
, false))
536 gfc_try_simplify_expr (*upper
, 0);
538 if (((*upper
)->expr_type
== EXPR_CONSTANT
539 && (*upper
)->ts
.type
!= BT_INTEGER
) ||
540 ((*upper
)->expr_type
== EXPR_FUNCTION
541 && (*upper
)->ts
.type
== BT_UNKNOWN
543 && strcmp ((*upper
)->symtree
->name
, "null") == 0))
545 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
546 gfc_basic_typename ((*upper
)->ts
.type
));
554 /* Matches an array specification, incidentally figuring out what sort
555 it is. Match either a normal array specification, or a coarray spec
556 or both. Optionally allow [:] for coarrays. */
559 gfc_match_array_spec (gfc_array_spec
**asp
, bool match_dim
, bool match_codim
)
561 array_type current_type
;
565 as
= gfc_get_array_spec ();
570 if (gfc_match_char ('(') != MATCH_YES
)
577 if (gfc_match (" .. )") == MATCH_YES
)
579 as
->type
= AS_ASSUMED_RANK
;
582 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed-rank array at %C"))
593 current_type
= match_array_element_spec (as
);
595 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
596 and implied-shape specifications. If the rank is at least 2, we can
597 distinguish between them. But for rank 1, we currently return
598 ASSUMED_SIZE; this gets adjusted later when we know for sure
599 whether the symbol parsed is a PARAMETER or not. */
603 if (current_type
== AS_UNKNOWN
)
605 as
->type
= current_type
;
609 { /* See how current spec meshes with the existing. */
613 case AS_IMPLIED_SHAPE
:
614 if (current_type
!= AS_ASSUMED_SIZE
)
616 gfc_error ("Bad array specification for implied-shape"
623 if (current_type
== AS_ASSUMED_SIZE
)
625 as
->type
= AS_ASSUMED_SIZE
;
629 if (current_type
== AS_EXPLICIT
)
632 gfc_error ("Bad array specification for an explicitly shaped "
637 case AS_ASSUMED_SHAPE
:
638 if ((current_type
== AS_ASSUMED_SHAPE
)
639 || (current_type
== AS_DEFERRED
))
642 gfc_error ("Bad array specification for assumed shape "
647 if (current_type
== AS_DEFERRED
)
650 if (current_type
== AS_ASSUMED_SHAPE
)
652 as
->type
= AS_ASSUMED_SHAPE
;
656 gfc_error ("Bad specification for deferred shape array at %C");
659 case AS_ASSUMED_SIZE
:
660 if (as
->rank
== 2 && current_type
== AS_ASSUMED_SIZE
)
662 as
->type
= AS_IMPLIED_SHAPE
;
666 gfc_error ("Bad specification for assumed size array at %C");
669 case AS_ASSUMED_RANK
:
673 if (gfc_match_char (')') == MATCH_YES
)
676 if (gfc_match_char (',') != MATCH_YES
)
678 gfc_error ("Expected another dimension in array declaration at %C");
682 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
684 gfc_error ("Array specification at %C has more than %d dimensions",
689 if (as
->corank
+ as
->rank
>= 7
690 && !gfc_notify_std (GFC_STD_F2008
, "Array specification at %C "
691 "with more than 7 dimensions"))
699 if (gfc_match_char ('[') != MATCH_YES
)
702 if (!gfc_notify_std (GFC_STD_F2008
, "Coarray declaration at %C"))
705 if (flag_coarray
== GFC_FCOARRAY_NONE
)
707 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
711 if (as
->rank
>= GFC_MAX_DIMENSIONS
)
713 gfc_error ("Array specification at %C has more than %d "
714 "dimensions", GFC_MAX_DIMENSIONS
);
721 current_type
= match_array_element_spec (as
);
723 if (current_type
== AS_UNKNOWN
)
727 as
->cotype
= current_type
;
730 { /* See how current spec meshes with the existing. */
731 case AS_IMPLIED_SHAPE
:
736 if (current_type
== AS_ASSUMED_SIZE
)
738 as
->cotype
= AS_ASSUMED_SIZE
;
742 if (current_type
== AS_EXPLICIT
)
745 gfc_error ("Bad array specification for an explicitly "
746 "shaped array at %C");
750 case AS_ASSUMED_SHAPE
:
751 if ((current_type
== AS_ASSUMED_SHAPE
)
752 || (current_type
== AS_DEFERRED
))
755 gfc_error ("Bad array specification for assumed shape "
760 if (current_type
== AS_DEFERRED
)
763 if (current_type
== AS_ASSUMED_SHAPE
)
765 as
->cotype
= AS_ASSUMED_SHAPE
;
769 gfc_error ("Bad specification for deferred shape array at %C");
772 case AS_ASSUMED_SIZE
:
773 gfc_error ("Bad specification for assumed size array at %C");
776 case AS_ASSUMED_RANK
:
780 if (gfc_match_char (']') == MATCH_YES
)
783 if (gfc_match_char (',') != MATCH_YES
)
785 gfc_error ("Expected another dimension in array declaration at %C");
789 if (as
->rank
+ as
->corank
>= GFC_MAX_DIMENSIONS
)
791 gfc_error ("Array specification at %C has more than %d "
792 "dimensions", GFC_MAX_DIMENSIONS
);
797 if (current_type
== AS_EXPLICIT
)
799 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
803 if (as
->cotype
== AS_ASSUMED_SIZE
)
804 as
->cotype
= AS_EXPLICIT
;
807 as
->type
= as
->cotype
;
810 if (as
->rank
== 0 && as
->corank
== 0)
813 gfc_free_array_spec (as
);
817 /* If a lower bounds of an assumed shape array is blank, put in one. */
818 if (as
->type
== AS_ASSUMED_SHAPE
)
820 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
822 if (as
->lower
[i
] == NULL
)
823 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
832 /* Something went wrong. */
833 gfc_free_array_spec (as
);
837 /* Given a symbol and an array specification, modify the symbol to
838 have that array specification. The error locus is needed in case
839 something goes wrong. On failure, the caller must free the spec. */
842 gfc_set_array_spec (gfc_symbol
*sym
, gfc_array_spec
*as
, locus
*error_loc
)
845 symbol_attribute
*attr
;
850 /* If the symbol corresponds to a submodule module procedure the array spec is
851 already set, so do not attempt to set it again here. */
853 if (gfc_submodule_procedure(attr
))
857 && !gfc_add_dimension (&sym
->attr
, sym
->name
, error_loc
))
861 && !gfc_add_codimension (&sym
->attr
, sym
->name
, error_loc
))
870 if ((sym
->as
->type
== AS_ASSUMED_RANK
&& as
->corank
)
871 || (as
->type
== AS_ASSUMED_RANK
&& sym
->as
->corank
))
873 gfc_error ("The assumed-rank array %qs at %L shall not have a "
874 "codimension", sym
->name
, error_loc
);
878 /* Check F2018:C822. */
879 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
884 sym
->as
->cotype
= as
->cotype
;
885 sym
->as
->corank
= as
->corank
;
886 /* Check F2018:C822. */
887 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
890 for (i
= 0; i
< as
->corank
; i
++)
892 sym
->as
->lower
[sym
->as
->rank
+ i
] = as
->lower
[i
];
893 sym
->as
->upper
[sym
->as
->rank
+ i
] = as
->upper
[i
];
898 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
899 the dimension is added - but first the codimensions (if existing
900 need to be shifted to make space for the dimension. */
901 gcc_assert (as
->corank
== 0 && sym
->as
->rank
== 0);
903 sym
->as
->rank
= as
->rank
;
904 sym
->as
->type
= as
->type
;
905 sym
->as
->cray_pointee
= as
->cray_pointee
;
906 sym
->as
->cp_was_assumed
= as
->cp_was_assumed
;
908 /* Check F2018:C822. */
909 if (sym
->as
->rank
+ sym
->as
->corank
> GFC_MAX_DIMENSIONS
)
912 for (i
= sym
->as
->corank
- 1; i
>= 0; i
--)
914 sym
->as
->lower
[as
->rank
+ i
] = sym
->as
->lower
[i
];
915 sym
->as
->upper
[as
->rank
+ i
] = sym
->as
->upper
[i
];
917 for (i
= 0; i
< as
->rank
; i
++)
919 sym
->as
->lower
[i
] = as
->lower
[i
];
920 sym
->as
->upper
[i
] = as
->upper
[i
];
929 gfc_error ("rank + corank of %qs exceeds %d at %C", sym
->name
,
935 /* Copy an array specification. */
938 gfc_copy_array_spec (gfc_array_spec
*src
)
940 gfc_array_spec
*dest
;
946 dest
= gfc_get_array_spec ();
950 for (i
= 0; i
< dest
->rank
+ dest
->corank
; i
++)
952 dest
->lower
[i
] = gfc_copy_expr (dest
->lower
[i
]);
953 dest
->upper
[i
] = gfc_copy_expr (dest
->upper
[i
]);
960 /* Returns nonzero if the two expressions are equal.
961 We should not need to support more than constant values, as that’s what is
962 allowed in derived type component array spec. However, we may create types
963 with non-constant array spec for dummy variable class container types, for
964 which the _data component holds the array spec of the variable declaration.
965 So we have to support non-constant bounds as well. */
968 compare_bounds (gfc_expr
*bound1
, gfc_expr
*bound2
)
970 if (bound1
== NULL
|| bound2
== NULL
971 || bound1
->ts
.type
!= BT_INTEGER
972 || bound2
->ts
.type
!= BT_INTEGER
)
973 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
975 /* What qualifies as identical bounds? We could probably just check that the
976 expressions are exact clones. We avoid rewriting a specific comparison
977 function and re-use instead the rather involved gfc_dep_compare_expr which
978 is just a bit more permissive, as it can also detect identical values for
979 some mismatching expressions (extra parenthesis, swapped operands, unary
980 plus, etc). It probably only makes a difference in corner cases. */
981 return gfc_dep_compare_expr (bound1
, bound2
) == 0;
985 /* Compares two array specifications. They must be constant or deferred
989 gfc_compare_array_spec (gfc_array_spec
*as1
, gfc_array_spec
*as2
)
993 if (as1
== NULL
&& as2
== NULL
)
996 if (as1
== NULL
|| as2
== NULL
)
999 if (as1
->rank
!= as2
->rank
)
1002 if (as1
->corank
!= as2
->corank
)
1008 if (as1
->type
!= as2
->type
)
1011 if (as1
->type
== AS_EXPLICIT
)
1012 for (i
= 0; i
< as1
->rank
+ as1
->corank
; i
++)
1014 if (!compare_bounds (as1
->lower
[i
], as2
->lower
[i
]))
1017 if (!compare_bounds (as1
->upper
[i
], as2
->upper
[i
]))
1025 /****************** Array constructor functions ******************/
1028 /* Given an expression node that might be an array constructor and a
1029 symbol, make sure that no iterators in this or child constructors
1030 use the symbol as an implied-DO iterator. Returns nonzero if a
1031 duplicate was found. */
1034 check_duplicate_iterator (gfc_constructor_base base
, gfc_symbol
*master
)
1039 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1043 if (e
->expr_type
== EXPR_ARRAY
1044 && check_duplicate_iterator (e
->value
.constructor
, master
))
1047 if (c
->iterator
== NULL
)
1050 if (c
->iterator
->var
->symtree
->n
.sym
== master
)
1052 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1053 "same name", master
->name
, &c
->where
);
1063 /* Forward declaration because these functions are mutually recursive. */
1064 static match
match_array_cons_element (gfc_constructor_base
*);
1066 /* Match a list of array elements. */
1069 match_array_list (gfc_constructor_base
*result
)
1071 gfc_constructor_base head
;
1079 old_loc
= gfc_current_locus
;
1081 if (gfc_match_char ('(') == MATCH_NO
)
1084 memset (&iter
, '\0', sizeof (gfc_iterator
));
1087 m
= match_array_cons_element (&head
);
1091 if (gfc_match_char (',') != MATCH_YES
)
1099 m
= gfc_match_iterator (&iter
, 0);
1102 if (m
== MATCH_ERROR
)
1105 m
= match_array_cons_element (&head
);
1106 if (m
== MATCH_ERROR
)
1113 goto cleanup
; /* Could be a complex constant */
1116 if (gfc_match_char (',') != MATCH_YES
)
1125 if (gfc_match_char (')') != MATCH_YES
)
1128 if (check_duplicate_iterator (head
, iter
.var
->symtree
->n
.sym
))
1134 e
= gfc_get_array_expr (BT_UNKNOWN
, 0, &old_loc
);
1135 e
->value
.constructor
= head
;
1137 p
= gfc_constructor_append_expr (result
, e
, &gfc_current_locus
);
1138 p
->iterator
= gfc_get_iterator ();
1139 *p
->iterator
= iter
;
1144 gfc_error ("Syntax error in array constructor at %C");
1148 gfc_constructor_free (head
);
1149 gfc_free_iterator (&iter
, 0);
1150 gfc_current_locus
= old_loc
;
1155 /* Match a single element of an array constructor, which can be a
1156 single expression or a list of elements. */
1159 match_array_cons_element (gfc_constructor_base
*result
)
1164 m
= match_array_list (result
);
1168 m
= gfc_match_expr (&expr
);
1172 if (expr
->ts
.type
== BT_BOZ
)
1174 gfc_error ("BOZ literal constant at %L cannot appear in an "
1175 "array constructor", &expr
->where
);
1179 if (expr
->expr_type
== EXPR_FUNCTION
1180 && expr
->ts
.type
== BT_UNKNOWN
1181 && strcmp(expr
->symtree
->name
, "null") == 0)
1183 gfc_error ("NULL() at %C cannot appear in an array constructor");
1187 gfc_constructor_append_expr (result
, expr
, &gfc_current_locus
);
1191 gfc_free_expr (expr
);
1196 /* Convert components of an array constructor to the type in ts. */
1199 walk_array_constructor (gfc_typespec
*ts
, gfc_constructor_base head
)
1205 for (c
= gfc_constructor_first (head
); c
; c
= gfc_constructor_next (c
))
1208 if (e
->expr_type
== EXPR_ARRAY
&& e
->ts
.type
== BT_UNKNOWN
1209 && !e
->ref
&& e
->value
.constructor
)
1211 m
= walk_array_constructor (ts
, e
->value
.constructor
);
1212 if (m
== MATCH_ERROR
)
1215 else if (!gfc_convert_type_warn (e
, ts
, 1, 1, true)
1216 && e
->ts
.type
!= BT_UNKNOWN
)
1222 /* Match an array constructor. */
1225 gfc_match_array_constructor (gfc_expr
**result
)
1228 gfc_constructor_base head
;
1233 const char *end_delim
;
1239 if (gfc_match (" (/") == MATCH_NO
)
1241 if (gfc_match (" [") == MATCH_NO
)
1245 if (!gfc_notify_std (GFC_STD_F2003
, "[...] "
1246 "style array constructors at %C"))
1254 where
= gfc_current_locus
;
1256 /* Try to match an optional "type-spec ::" */
1258 m
= gfc_match_type_spec (&ts
);
1261 seen_ts
= (gfc_match (" ::") == MATCH_YES
);
1265 if (!gfc_notify_std (GFC_STD_F2003
, "Array constructor "
1266 "including type specification at %C"))
1271 gfc_error ("Type-spec at %L cannot contain a deferred "
1272 "type parameter", &where
);
1276 if (ts
.type
== BT_CHARACTER
1277 && ts
.u
.cl
&& !ts
.u
.cl
->length
&& !ts
.u
.cl
->length_from_typespec
)
1279 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1280 "type parameter", &where
);
1285 else if (m
== MATCH_ERROR
)
1289 gfc_current_locus
= where
;
1291 if (gfc_match (end_delim
) == MATCH_YES
)
1297 gfc_error ("Empty array constructor at %C is not allowed");
1304 m
= match_array_cons_element (&head
);
1305 if (m
== MATCH_ERROR
)
1310 if (gfc_match_char (',') == MATCH_NO
)
1314 if (gfc_match (end_delim
) == MATCH_NO
)
1318 /* Size must be calculated at resolution time. */
1321 expr
= gfc_get_array_expr (ts
.type
, ts
.kind
, &where
);
1324 /* If the typespec is CHARACTER, check that array elements can
1325 be converted. See PR fortran/67803. */
1326 if (ts
.type
== BT_CHARACTER
)
1328 c
= gfc_constructor_first (head
);
1329 for (; c
; c
= gfc_constructor_next (c
))
1331 if (gfc_numeric_ts (&c
->expr
->ts
)
1332 || c
->expr
->ts
.type
== BT_LOGICAL
)
1334 gfc_error ("Incompatible typespec for array element at %L",
1339 /* Special case null(). */
1340 if (c
->expr
->expr_type
== EXPR_FUNCTION
1341 && c
->expr
->ts
.type
== BT_UNKNOWN
1342 && strcmp (c
->expr
->symtree
->name
, "null") == 0)
1344 gfc_error ("Incompatible typespec for array element at %L",
1351 /* Walk the constructor, and if possible, do type conversion for
1353 if (gfc_numeric_ts (&ts
))
1355 m
= walk_array_constructor (&ts
, head
);
1356 if (m
== MATCH_ERROR
)
1361 expr
= gfc_get_array_expr (BT_UNKNOWN
, 0, &where
);
1363 expr
->value
.constructor
= head
;
1365 expr
->ts
.u
.cl
->length_from_typespec
= seen_ts
;
1372 gfc_error ("Syntax error in array constructor at %C");
1375 gfc_constructor_free (head
);
1381 /************** Check array constructors for correctness **************/
1383 /* Given an expression, compare it's type with the type of the current
1384 constructor. Returns nonzero if an error was issued. The
1385 cons_state variable keeps track of whether the type of the
1386 constructor being read or resolved is known to be good, bad or just
1389 static gfc_typespec constructor_ts
;
1391 { CONS_START
, CONS_GOOD
, CONS_BAD
}
1395 check_element_type (gfc_expr
*expr
, bool convert
)
1397 if (cons_state
== CONS_BAD
)
1398 return 0; /* Suppress further errors */
1400 if (cons_state
== CONS_START
)
1402 if (expr
->ts
.type
== BT_UNKNOWN
)
1403 cons_state
= CONS_BAD
;
1406 cons_state
= CONS_GOOD
;
1407 constructor_ts
= expr
->ts
;
1413 if (gfc_compare_types (&constructor_ts
, &expr
->ts
))
1417 return gfc_convert_type_warn (expr
, &constructor_ts
, 1, 1, true) ? 0 : 1;
1419 gfc_error ("Element in %s array constructor at %L is %s",
1420 gfc_typename (&constructor_ts
), &expr
->where
,
1421 gfc_typename (expr
));
1423 cons_state
= CONS_BAD
;
1428 /* Recursive work function for gfc_check_constructor_type(). */
1431 check_constructor_type (gfc_constructor_base base
, bool convert
)
1436 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1440 if (e
->expr_type
== EXPR_ARRAY
)
1442 if (!check_constructor_type (e
->value
.constructor
, convert
))
1448 if (check_element_type (e
, convert
))
1456 /* Check that all elements of an array constructor are the same type.
1457 On false, an error has been generated. */
1460 gfc_check_constructor_type (gfc_expr
*e
)
1464 if (e
->ts
.type
!= BT_UNKNOWN
)
1466 cons_state
= CONS_GOOD
;
1467 constructor_ts
= e
->ts
;
1471 cons_state
= CONS_START
;
1472 gfc_clear_ts (&constructor_ts
);
1475 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1476 typespec, and we will now convert the values on the fly. */
1477 t
= check_constructor_type (e
->value
.constructor
, e
->ts
.type
!= BT_UNKNOWN
);
1478 if (t
&& e
->ts
.type
== BT_UNKNOWN
)
1479 e
->ts
= constructor_ts
;
1486 typedef struct cons_stack
1488 gfc_iterator
*iterator
;
1489 struct cons_stack
*previous
;
1493 static cons_stack
*base
;
1495 static bool check_constructor (gfc_constructor_base
, bool (*) (gfc_expr
*));
1497 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1498 that that variable is an iteration variable. */
1501 gfc_check_iter_variable (gfc_expr
*expr
)
1506 sym
= expr
->symtree
->n
.sym
;
1508 for (c
= base
; c
&& c
->iterator
; c
= c
->previous
)
1509 if (sym
== c
->iterator
->var
->symtree
->n
.sym
)
1516 /* Recursive work function for gfc_check_constructor(). This amounts
1517 to calling the check function for each expression in the
1518 constructor, giving variables with the names of iterators a pass. */
1521 check_constructor (gfc_constructor_base ctor
, bool (*check_function
) (gfc_expr
*))
1528 for (c
= gfc_constructor_first (ctor
); c
; c
= gfc_constructor_next (c
))
1535 if (e
->expr_type
!= EXPR_ARRAY
)
1537 if (!(*check_function
)(e
))
1542 element
.previous
= base
;
1543 element
.iterator
= c
->iterator
;
1546 t
= check_constructor (e
->value
.constructor
, check_function
);
1547 base
= element
.previous
;
1553 /* Nothing went wrong, so all OK. */
1558 /* Checks a constructor to see if it is a particular kind of
1559 expression -- specification, restricted, or initialization as
1560 determined by the check_function. */
1563 gfc_check_constructor (gfc_expr
*expr
, bool (*check_function
) (gfc_expr
*))
1565 cons_stack
*base_save
;
1571 t
= check_constructor (expr
->value
.constructor
, check_function
);
1579 /**************** Simplification of array constructors ****************/
1581 iterator_stack
*iter_stack
;
1585 gfc_constructor_base base
;
1586 int extract_count
, extract_n
;
1587 gfc_expr
*extracted
;
1591 gfc_component
*component
;
1594 bool (*expand_work_function
) (gfc_expr
*);
1598 static expand_info current_expand
;
1600 static bool expand_constructor (gfc_constructor_base
);
1603 /* Work function that counts the number of elements present in a
1607 count_elements (gfc_expr
*e
)
1612 mpz_add_ui (*current_expand
.count
, *current_expand
.count
, 1);
1615 if (!gfc_array_size (e
, &result
))
1621 mpz_add (*current_expand
.count
, *current_expand
.count
, result
);
1630 /* Work function that extracts a particular element from an array
1631 constructor, freeing the rest. */
1634 extract_element (gfc_expr
*e
)
1637 { /* Something unextractable */
1642 if (current_expand
.extract_count
== current_expand
.extract_n
)
1643 current_expand
.extracted
= e
;
1647 current_expand
.extract_count
++;
1653 /* Work function that constructs a new constructor out of the old one,
1654 stringing new elements together. */
1657 expand (gfc_expr
*e
)
1659 gfc_constructor
*c
= gfc_constructor_append_expr (¤t_expand
.base
,
1662 c
->n
.component
= current_expand
.component
;
1667 /* Given an initialization expression that is a variable reference,
1668 substitute the current value of the iteration variable. */
1671 gfc_simplify_iterator_var (gfc_expr
*e
)
1675 for (p
= iter_stack
; p
; p
= p
->prev
)
1676 if (e
->symtree
== p
->variable
)
1680 return; /* Variable not found */
1682 gfc_replace_expr (e
, gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
1684 mpz_set (e
->value
.integer
, p
->value
);
1690 /* Expand an expression with that is inside of a constructor,
1691 recursing into other constructors if present. */
1694 expand_expr (gfc_expr
*e
)
1696 if (e
->expr_type
== EXPR_ARRAY
)
1697 return expand_constructor (e
->value
.constructor
);
1699 e
= gfc_copy_expr (e
);
1701 if (!gfc_simplify_expr (e
, 1))
1707 return current_expand
.expand_work_function (e
);
1712 expand_iterator (gfc_constructor
*c
)
1714 gfc_expr
*start
, *end
, *step
;
1715 iterator_stack frame
;
1724 mpz_init (frame
.value
);
1727 start
= gfc_copy_expr (c
->iterator
->start
);
1728 if (!gfc_simplify_expr (start
, 1))
1731 if (start
->expr_type
!= EXPR_CONSTANT
|| start
->ts
.type
!= BT_INTEGER
)
1734 end
= gfc_copy_expr (c
->iterator
->end
);
1735 if (!gfc_simplify_expr (end
, 1))
1738 if (end
->expr_type
!= EXPR_CONSTANT
|| end
->ts
.type
!= BT_INTEGER
)
1741 step
= gfc_copy_expr (c
->iterator
->step
);
1742 if (!gfc_simplify_expr (step
, 1))
1745 if (step
->expr_type
!= EXPR_CONSTANT
|| step
->ts
.type
!= BT_INTEGER
)
1748 if (mpz_sgn (step
->value
.integer
) == 0)
1750 gfc_error ("Iterator step at %L cannot be zero", &step
->where
);
1754 /* Calculate the trip count of the loop. */
1755 mpz_sub (trip
, end
->value
.integer
, start
->value
.integer
);
1756 mpz_add (trip
, trip
, step
->value
.integer
);
1757 mpz_tdiv_q (trip
, trip
, step
->value
.integer
);
1759 mpz_set (frame
.value
, start
->value
.integer
);
1761 frame
.prev
= iter_stack
;
1762 frame
.variable
= c
->iterator
->var
->symtree
;
1763 iter_stack
= &frame
;
1765 while (mpz_sgn (trip
) > 0)
1767 if (!expand_expr (c
->expr
))
1770 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
1771 mpz_sub_ui (trip
, trip
, 1);
1777 gfc_free_expr (start
);
1778 gfc_free_expr (end
);
1779 gfc_free_expr (step
);
1782 mpz_clear (frame
.value
);
1784 iter_stack
= frame
.prev
;
1789 /* Variables for noticing if all constructors are empty, and
1790 if any of them had a type. */
1792 static bool empty_constructor
;
1793 static gfc_typespec empty_ts
;
1795 /* Expand a constructor into constant constructors without any
1796 iterators, calling the work function for each of the expanded
1797 expressions. The work function needs to either save or free the
1798 passed expression. */
1801 expand_constructor (gfc_constructor_base base
)
1806 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next(c
))
1808 if (c
->iterator
!= NULL
)
1810 if (!expand_iterator (c
))
1820 if (empty_constructor
)
1823 /* Simplify constant array expression/section within constructor. */
1824 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0 && e
->ref
1825 && e
->symtree
&& e
->symtree
->n
.sym
1826 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1827 gfc_simplify_expr (e
, 0);
1829 if (e
->expr_type
== EXPR_ARRAY
)
1831 if (!expand_constructor (e
->value
.constructor
))
1837 empty_constructor
= false;
1838 e
= gfc_copy_expr (e
);
1839 if (!gfc_simplify_expr (e
, 1))
1844 e
->from_constructor
= 1;
1845 current_expand
.offset
= &c
->offset
;
1846 current_expand
.repeat
= &c
->repeat
;
1847 current_expand
.component
= c
->n
.component
;
1848 if (!current_expand
.expand_work_function(e
))
1855 /* Given an array expression and an element number (starting at zero),
1856 return a pointer to the array element. NULL is returned if the
1857 size of the array has been exceeded. The expression node returned
1858 remains a part of the array and should not be freed. Access is not
1859 efficient at all, but this is another place where things do not
1860 have to be particularly fast. */
1863 gfc_get_array_element (gfc_expr
*array
, int element
)
1865 expand_info expand_save
;
1869 expand_save
= current_expand
;
1870 current_expand
.extract_n
= element
;
1871 current_expand
.expand_work_function
= extract_element
;
1872 current_expand
.extracted
= NULL
;
1873 current_expand
.extract_count
= 0;
1877 rc
= expand_constructor (array
->value
.constructor
);
1878 e
= current_expand
.extracted
;
1879 current_expand
= expand_save
;
1888 /* Top level subroutine for expanding constructors. We only expand
1889 constructor if they are small enough. */
1892 gfc_expand_constructor (gfc_expr
*e
, bool fatal
)
1894 expand_info expand_save
;
1898 if (gfc_is_size_zero_array (e
))
1901 /* If we can successfully get an array element at the max array size then
1902 the array is too big to expand, so we just return. */
1903 f
= gfc_get_array_element (e
, flag_max_array_constructor
);
1909 gfc_error ("The number of elements in the array constructor "
1910 "at %L requires an increase of the allowed %d "
1911 "upper limit. See %<-fmax-array-constructor%> "
1912 "option", &e
->where
, flag_max_array_constructor
);
1918 /* We now know the array is not too big so go ahead and try to expand it. */
1919 expand_save
= current_expand
;
1920 current_expand
.base
= NULL
;
1924 empty_constructor
= true;
1925 gfc_clear_ts (&empty_ts
);
1926 current_expand
.expand_work_function
= expand
;
1928 if (!expand_constructor (e
->value
.constructor
))
1930 gfc_constructor_free (current_expand
.base
);
1935 /* If we don't have an explicit constructor type, and there
1936 were only empty constructors, then take the type from
1939 if (constructor_ts
.type
== BT_UNKNOWN
&& empty_constructor
)
1942 gfc_constructor_free (e
->value
.constructor
);
1943 e
->value
.constructor
= current_expand
.base
;
1948 current_expand
= expand_save
;
1954 /* Work function for checking that an element of a constructor is a
1955 constant, after removal of any iteration variables. We return
1959 is_constant_element (gfc_expr
*e
)
1963 rv
= gfc_is_constant_expr (e
);
1966 return rv
? true : false;
1970 /* Given an array constructor, determine if the constructor is
1971 constant or not by expanding it and making sure that all elements
1972 are constants. This is a bit of a hack since something like (/ (i,
1973 i=1,100000000) /) will take a while as* opposed to a more clever
1974 function that traverses the expression tree. FIXME. */
1977 gfc_constant_ac (gfc_expr
*e
)
1979 expand_info expand_save
;
1983 expand_save
= current_expand
;
1984 current_expand
.expand_work_function
= is_constant_element
;
1986 rc
= expand_constructor (e
->value
.constructor
);
1988 current_expand
= expand_save
;
1996 /* Returns nonzero if an array constructor has been completely
1997 expanded (no iterators) and zero if iterators are present. */
2000 gfc_expanded_ac (gfc_expr
*e
)
2004 if (e
->expr_type
== EXPR_ARRAY
)
2005 for (c
= gfc_constructor_first (e
->value
.constructor
);
2006 c
; c
= gfc_constructor_next (c
))
2007 if (c
->iterator
!= NULL
|| !gfc_expanded_ac (c
->expr
))
2014 /*************** Type resolution of array constructors ***************/
2017 /* The symbol expr_is_sought_symbol_ref will try to find. */
2018 static const gfc_symbol
*sought_symbol
= NULL
;
2021 /* Tells whether the expression E is a variable reference to the symbol
2022 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
2024 To be used with gfc_expr_walker: if a reference is found we don't need
2025 to look further so we return 1 to skip any further walk. */
2028 expr_is_sought_symbol_ref (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2031 gfc_expr
*expr
= *e
;
2032 locus
*sym_loc
= (locus
*)where
;
2034 if (expr
->expr_type
== EXPR_VARIABLE
2035 && expr
->symtree
->n
.sym
== sought_symbol
)
2037 *sym_loc
= expr
->where
;
2045 /* Tells whether the expression EXPR contains a reference to the symbol
2046 SYM and in that case sets the position SYM_LOC where the reference is. */
2049 find_symbol_in_expr (gfc_symbol
*sym
, gfc_expr
*expr
, locus
*sym_loc
)
2053 sought_symbol
= sym
;
2054 ret
= gfc_expr_walker (&expr
, &expr_is_sought_symbol_ref
, sym_loc
);
2055 sought_symbol
= NULL
;
2060 /* Recursive array list resolution function. All of the elements must
2061 be of the same type. */
2064 resolve_array_list (gfc_constructor_base base
)
2072 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
2077 gfc_symbol
*iter_var
;
2080 if (!gfc_resolve_iterator (iter
, false, true))
2083 /* Check for bounds referencing the iterator variable. */
2084 gcc_assert (iter
->var
->expr_type
== EXPR_VARIABLE
);
2085 iter_var
= iter
->var
->symtree
->n
.sym
;
2086 if (find_symbol_in_expr (iter_var
, iter
->start
, &iter_var_loc
))
2088 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO initial "
2089 "expression references control variable "
2090 "at %L", &iter_var_loc
))
2093 if (find_symbol_in_expr (iter_var
, iter
->end
, &iter_var_loc
))
2095 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO final "
2096 "expression references control variable "
2097 "at %L", &iter_var_loc
))
2100 if (find_symbol_in_expr (iter_var
, iter
->step
, &iter_var_loc
))
2102 if (!gfc_notify_std (GFC_STD_LEGACY
, "AC-IMPLIED-DO step "
2103 "expression references control variable "
2104 "at %L", &iter_var_loc
))
2109 if (!gfc_resolve_expr (c
->expr
))
2112 if (UNLIMITED_POLY (c
->expr
))
2114 gfc_error ("Array constructor value at %L shall not be unlimited "
2115 "polymorphic [F2008: C4106]", &c
->expr
->where
);
2123 /* Resolve character array constructor. If it has a specified constant character
2124 length, pad/truncate the elements here; if the length is not specified and
2125 all elements are of compile-time known length, emit an error as this is
2129 gfc_resolve_character_array_constructor (gfc_expr
*expr
)
2132 HOST_WIDE_INT found_length
;
2134 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
2135 gcc_assert (expr
->ts
.type
== BT_CHARACTER
);
2137 if (expr
->ts
.u
.cl
== NULL
)
2139 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2140 p
; p
= gfc_constructor_next (p
))
2141 if (p
->expr
->ts
.u
.cl
!= NULL
)
2143 /* Ensure that if there is a char_len around that it is
2144 used; otherwise the middle-end confuses them! */
2145 expr
->ts
.u
.cl
= p
->expr
->ts
.u
.cl
;
2149 expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2154 /* Early exit for zero size arrays. */
2158 HOST_WIDE_INT arraysize
;
2160 gfc_array_size (expr
, &size
);
2161 arraysize
= mpz_get_ui (size
);
2170 if (expr
->ts
.u
.cl
->length
== NULL
)
2172 /* Check that all constant string elements have the same length until
2173 we reach the end or find a variable-length one. */
2175 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2176 p
; p
= gfc_constructor_next (p
))
2178 HOST_WIDE_INT current_length
= -1;
2180 for (ref
= p
->expr
->ref
; ref
; ref
= ref
->next
)
2181 if (ref
->type
== REF_SUBSTRING
2183 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
2185 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
2188 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2189 current_length
= p
->expr
->value
.character
.length
;
2191 current_length
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
)
2192 - gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
) + 1;
2193 else if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
2194 && p
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2195 current_length
= gfc_mpz_get_hwi (p
->expr
->ts
.u
.cl
->length
->value
.integer
);
2199 if (current_length
< 0)
2202 if (found_length
== -1)
2203 found_length
= current_length
;
2204 else if (found_length
!= current_length
)
2206 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2207 " constructor at %L", (long) found_length
,
2208 (long) current_length
, &p
->expr
->where
);
2212 gcc_assert (found_length
== current_length
);
2215 gcc_assert (found_length
!= -1);
2217 /* Update the character length of the array constructor. */
2218 expr
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2219 NULL
, found_length
);
2223 /* We've got a character length specified. It should be an integer,
2224 otherwise an error is signalled elsewhere. */
2225 gcc_assert (expr
->ts
.u
.cl
->length
);
2227 /* If we've got a constant character length, pad according to this.
2228 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2229 max_length only if they pass. */
2230 gfc_extract_hwi (expr
->ts
.u
.cl
->length
, &found_length
);
2232 /* Now pad/truncate the elements accordingly to the specified character
2233 length. This is ok inside this conditional, as in the case above
2234 (without typespec) all elements are verified to have the same length
2236 if (found_length
!= -1)
2237 for (p
= gfc_constructor_first (expr
->value
.constructor
);
2238 p
; p
= gfc_constructor_next (p
))
2239 if (p
->expr
->expr_type
== EXPR_CONSTANT
)
2241 gfc_expr
*cl
= NULL
;
2242 HOST_WIDE_INT current_length
= -1;
2245 if (p
->expr
->ts
.u
.cl
&& p
->expr
->ts
.u
.cl
->length
)
2247 cl
= p
->expr
->ts
.u
.cl
->length
;
2248 gfc_extract_hwi (cl
, ¤t_length
);
2251 /* If gfc_extract_int above set current_length, we implicitly
2252 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2254 has_ts
= expr
->ts
.u
.cl
->length_from_typespec
;
2257 || (current_length
!= -1 && current_length
!= found_length
))
2258 gfc_set_constant_character_len (found_length
, p
->expr
,
2259 has_ts
? -1 : found_length
);
2267 /* Resolve all of the expressions in an array list. */
2270 gfc_resolve_array_constructor (gfc_expr
*expr
)
2274 t
= resolve_array_list (expr
->value
.constructor
);
2276 t
= gfc_check_constructor_type (expr
);
2278 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2279 the call to this function, so we don't need to call it here; if it was
2280 called twice, an error message there would be duplicated. */
2286 /* Copy an iterator structure. */
2289 gfc_copy_iterator (gfc_iterator
*src
)
2296 dest
= gfc_get_iterator ();
2298 dest
->var
= gfc_copy_expr (src
->var
);
2299 dest
->start
= gfc_copy_expr (src
->start
);
2300 dest
->end
= gfc_copy_expr (src
->end
);
2301 dest
->step
= gfc_copy_expr (src
->step
);
2302 dest
->unroll
= src
->unroll
;
2303 dest
->ivdep
= src
->ivdep
;
2304 dest
->vector
= src
->vector
;
2305 dest
->novector
= src
->novector
;
2311 /********* Subroutines for determining the size of an array *********/
2313 /* These are needed just to accommodate RESHAPE(). There are no
2314 diagnostics here, we just return false if something goes wrong. */
2317 /* Get the size of single dimension of an array specification. The
2318 array is guaranteed to be one dimensional. */
2321 spec_dimen_size (gfc_array_spec
*as
, int dimen
, mpz_t
*result
)
2326 if (dimen
< 0 || dimen
> as
->rank
- 1)
2327 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2329 if (as
->type
!= AS_EXPLICIT
2330 || !as
->lower
[dimen
]
2331 || !as
->upper
[dimen
])
2334 if (as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2335 || as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2336 || as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
2337 || as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2342 mpz_sub (*result
, as
->upper
[dimen
]->value
.integer
,
2343 as
->lower
[dimen
]->value
.integer
);
2345 mpz_add_ui (*result
, *result
, 1);
2347 if (mpz_cmp_si (*result
, 0) < 0)
2348 mpz_set_si (*result
, 0);
2355 spec_size (gfc_array_spec
*as
, mpz_t
*result
)
2360 if (!as
|| as
->type
== AS_ASSUMED_RANK
)
2363 mpz_init_set_ui (*result
, 1);
2365 for (d
= 0; d
< as
->rank
; d
++)
2367 if (!spec_dimen_size (as
, d
, &size
))
2369 mpz_clear (*result
);
2373 mpz_mul (*result
, *result
, size
);
2381 /* Get the number of elements in an array section. Optionally, also supply
2385 gfc_ref_dimen_size (gfc_array_ref
*ar
, int dimen
, mpz_t
*result
, mpz_t
*end
)
2387 mpz_t upper
, lower
, stride
;
2390 gfc_expr
*stride_expr
= NULL
;
2392 if (dimen
< 0 || ar
== NULL
)
2393 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2395 if (dimen
> ar
->dimen
- 1)
2397 gfc_error ("Bad array dimension at %L", &ar
->c_where
[dimen
]);
2401 switch (ar
->dimen_type
[dimen
])
2405 mpz_set_ui (*result
, 1);
2410 t
= gfc_array_size (ar
->start
[dimen
], result
); /* Recurse! */
2417 if (ar
->stride
[dimen
] == NULL
)
2418 mpz_set_ui (stride
, 1);
2421 stride_expr
= gfc_copy_expr(ar
->stride
[dimen
]);
2423 if (!gfc_simplify_expr (stride_expr
, 1)
2424 || stride_expr
->expr_type
!= EXPR_CONSTANT
2425 || mpz_cmp_ui (stride_expr
->value
.integer
, 0) == 0)
2427 gfc_free_expr (stride_expr
);
2431 mpz_set (stride
, stride_expr
->value
.integer
);
2432 gfc_free_expr(stride_expr
);
2435 /* Calculate the number of elements via gfc_dep_difference, but only if
2436 start and end are both supplied in the reference or the array spec.
2437 This is to guard against strange but valid code like
2442 print *,size(a(n-1:))
2444 where the user changes the value of a variable. If we have to
2445 determine end as well, we cannot do this using gfc_dep_difference.
2446 Fall back to the constants-only code then. */
2452 use_dep
= gfc_dep_difference (ar
->end
[dimen
], ar
->start
[dimen
],
2454 if (!use_dep
&& ar
->end
[dimen
] == NULL
&& ar
->start
[dimen
] == NULL
)
2455 use_dep
= gfc_dep_difference (ar
->as
->upper
[dimen
],
2456 ar
->as
->lower
[dimen
], &diff
);
2461 mpz_add (*result
, diff
, stride
);
2462 mpz_div (*result
, *result
, stride
);
2463 if (mpz_cmp_ui (*result
, 0) < 0)
2464 mpz_set_ui (*result
, 0);
2473 /* Constant-only code here, which covers more cases
2479 if (ar
->start
[dimen
] == NULL
)
2481 if (ar
->as
->lower
[dimen
] == NULL
2482 || ar
->as
->lower
[dimen
]->expr_type
!= EXPR_CONSTANT
2483 || ar
->as
->lower
[dimen
]->ts
.type
!= BT_INTEGER
)
2485 mpz_set (lower
, ar
->as
->lower
[dimen
]->value
.integer
);
2489 if (ar
->start
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2491 mpz_set (lower
, ar
->start
[dimen
]->value
.integer
);
2494 if (ar
->end
[dimen
] == NULL
)
2496 if (ar
->as
->upper
[dimen
] == NULL
2497 || ar
->as
->upper
[dimen
]->expr_type
!= EXPR_CONSTANT
2498 || ar
->as
->upper
[dimen
]->ts
.type
!= BT_INTEGER
)
2500 mpz_set (upper
, ar
->as
->upper
[dimen
]->value
.integer
);
2504 if (ar
->end
[dimen
]->expr_type
!= EXPR_CONSTANT
)
2506 mpz_set (upper
, ar
->end
[dimen
]->value
.integer
);
2510 mpz_sub (*result
, upper
, lower
);
2511 mpz_add (*result
, *result
, stride
);
2512 mpz_div (*result
, *result
, stride
);
2514 /* Zero stride caught earlier. */
2515 if (mpz_cmp_ui (*result
, 0) < 0)
2516 mpz_set_ui (*result
, 0);
2523 mpz_sub_ui (*end
, *result
, 1UL);
2524 mpz_mul (*end
, *end
, stride
);
2525 mpz_add (*end
, *end
, lower
);
2535 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2543 ref_size (gfc_array_ref
*ar
, mpz_t
*result
)
2548 mpz_init_set_ui (*result
, 1);
2550 for (d
= 0; d
< ar
->dimen
; d
++)
2552 if (!gfc_ref_dimen_size (ar
, d
, &size
, NULL
))
2554 mpz_clear (*result
);
2558 mpz_mul (*result
, *result
, size
);
2566 /* Given an array expression and a dimension, figure out how many
2567 elements it has along that dimension. Returns true if we were
2568 able to return a result in the 'result' variable, false
2572 gfc_array_dimen_size (gfc_expr
*array
, int dimen
, mpz_t
*result
)
2577 gcc_assert (array
!= NULL
);
2579 if (array
->ts
.type
== BT_CLASS
)
2582 if (array
->rank
== -1)
2585 if (dimen
< 0 || dimen
> array
->rank
- 1)
2586 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2588 switch (array
->expr_type
)
2592 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2594 if (ref
->type
!= REF_ARRAY
)
2597 if (ref
->u
.ar
.type
== AR_FULL
)
2598 return spec_dimen_size (ref
->u
.ar
.as
, dimen
, result
);
2600 if (ref
->u
.ar
.type
== AR_SECTION
)
2602 for (i
= 0; dimen
>= 0; i
++)
2603 if (ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
2606 return gfc_ref_dimen_size (&ref
->u
.ar
, i
- 1, result
, NULL
);
2612 mpz_init_set (*result
, array
->shape
[dimen
]);
2616 if (array
->symtree
->n
.sym
->attr
.generic
2617 && array
->value
.function
.esym
!= NULL
)
2619 if (!spec_dimen_size (array
->value
.function
.esym
->as
, dimen
, result
))
2622 else if (!spec_dimen_size (array
->symtree
->n
.sym
->as
, dimen
, result
))
2628 if (array
->shape
== NULL
) {
2629 /* Expressions with rank > 1 should have "shape" properly set */
2630 if ( array
->rank
!= 1 )
2631 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2632 return gfc_array_size(array
, result
);
2637 if (array
->shape
== NULL
)
2640 mpz_init_set (*result
, array
->shape
[dimen
]);
2649 /* Given an array expression, figure out how many elements are in the
2650 array. Returns true if this is possible, and sets the 'result'
2651 variable. Otherwise returns false. */
2654 gfc_array_size (gfc_expr
*array
, mpz_t
*result
)
2656 expand_info expand_save
;
2661 if (array
->ts
.type
== BT_CLASS
)
2664 switch (array
->expr_type
)
2667 gfc_push_suppress_errors ();
2669 expand_save
= current_expand
;
2671 current_expand
.count
= result
;
2672 mpz_init_set_ui (*result
, 0);
2674 current_expand
.expand_work_function
= count_elements
;
2677 t
= expand_constructor (array
->value
.constructor
);
2679 gfc_pop_suppress_errors ();
2682 mpz_clear (*result
);
2683 current_expand
= expand_save
;
2687 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
2689 if (ref
->type
!= REF_ARRAY
)
2692 if (ref
->u
.ar
.type
== AR_FULL
)
2693 return spec_size (ref
->u
.ar
.as
, result
);
2695 if (ref
->u
.ar
.type
== AR_SECTION
)
2696 return ref_size (&ref
->u
.ar
, result
);
2699 return spec_size (array
->symtree
->n
.sym
->as
, result
);
2703 if (array
->rank
== 0 || array
->shape
== NULL
)
2706 mpz_init_set_ui (*result
, 1);
2708 for (i
= 0; i
< array
->rank
; i
++)
2709 mpz_mul (*result
, *result
, array
->shape
[i
]);
2718 /* Given an array reference, return the shape of the reference in an
2719 array of mpz_t integers. */
2722 gfc_array_ref_shape (gfc_array_ref
*ar
, mpz_t
*shape
)
2732 for (; d
< ar
->as
->rank
; d
++)
2733 if (!spec_dimen_size (ar
->as
, d
, &shape
[d
]))
2739 for (i
= 0; i
< ar
->dimen
; i
++)
2741 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
2743 if (!gfc_ref_dimen_size (ar
, i
, &shape
[d
], NULL
))
2756 gfc_clear_shape (shape
, d
);
2761 /* Given an array expression, find the array reference structure that
2762 characterizes the reference. */
2765 gfc_find_array_ref (gfc_expr
*e
, bool allow_null
)
2769 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2770 if (ref
->type
== REF_ARRAY
2771 && (ref
->u
.ar
.type
== AR_FULL
|| ref
->u
.ar
.type
== AR_SECTION
))
2779 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2786 /* Find out if an array shape is known at compile time. */
2789 gfc_is_compile_time_shape (gfc_array_spec
*as
)
2791 if (as
->type
!= AS_EXPLICIT
)
2794 for (int i
= 0; i
< as
->rank
; i
++)
2795 if (!gfc_is_constant_expr (as
->lower
[i
])
2796 || !gfc_is_constant_expr (as
->upper
[i
]))