c++: diagnose usage of co_await and co_yield in default args [PR115906]
[official-gcc.git] / gcc / fortran / array.cc
blob79c774d59a0b1d1a16910eaf5682d3d60a446277
1 /* Array things
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
10 version.
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
15 for more details.
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/>. */
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "options.h"
25 #include "gfortran.h"
26 #include "parse.h"
27 #include "match.h"
28 #include "constructor.h"
30 /**************** Array reference matching subroutines *****************/
32 /* Copy an array reference structure. */
34 gfc_array_ref *
35 gfc_copy_array_ref (gfc_array_ref *src)
37 gfc_array_ref *dest;
38 int i;
40 if (src == NULL)
41 return NULL;
43 dest = gfc_get_array_ref ();
45 *dest = *src;
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]);
54 return dest;
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
62 expression. */
64 static match
65 match_subscript (gfc_array_ref *ar, int init, bool match_star)
67 match m = MATCH_ERROR;
68 bool star = false;
69 int i;
70 bool saw_boz = false;
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
80 resolution time. */
82 ar->dimen_type[i] = DIMEN_UNKNOWN;
84 if (gfc_match_char (':') == MATCH_YES)
85 goto end_element;
87 /* Get start element. */
88 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
89 star = true;
91 if (!star && init)
92 m = gfc_match_init_expr (&ar->start[i]);
93 else if (!star)
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");
99 saw_boz = true;
102 if (m == MATCH_NO)
103 gfc_error ("Expected array subscript at %C");
104 if (m != MATCH_YES)
105 return MATCH_ERROR;
107 if (gfc_match_char (':') == MATCH_NO)
108 goto matched;
110 if (star)
112 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
113 return MATCH_ERROR;
116 /* Get an optional end element. Because we've seen the colon, we
117 definitely have a range along this dimension. */
118 end_element:
119 ar->dimen_type[i] = DIMEN_RANGE;
121 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
122 star = true;
123 else if (init)
124 m = gfc_match_init_expr (&ar->end[i]);
125 else
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");
131 saw_boz = true;
134 if (m == MATCH_ERROR)
135 return MATCH_ERROR;
137 if (star && ar->start[i] == NULL)
139 gfc_error ("Missing lower bound in assumed size "
140 "coarray specification at %C");
141 return MATCH_ERROR;
144 /* See if we have an optional stride. */
145 if (gfc_match_char (':') == MATCH_YES)
147 if (star)
149 gfc_error ("Strides not allowed in coarray subscript at %C");
150 return MATCH_ERROR;
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");
159 saw_boz = true;
162 if (m == MATCH_NO)
163 gfc_error ("Expected array subscript stride at %C");
164 if (m != MATCH_YES)
165 return MATCH_ERROR;
168 matched:
169 if (star)
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. */
180 match
181 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
182 int corank)
184 match m;
185 bool matched_bracket = false;
186 gfc_expr *tmp;
187 bool stat_just_seen = false;
188 bool team_just_seen = false;
190 memset (ar, '\0', sizeof (*ar));
192 ar->where = gfc_current_locus;
193 ar->as = as;
194 ar->type = AR_UNKNOWN;
196 if (gfc_match_char ('[') == MATCH_YES)
198 matched_bracket = true;
199 goto coarray;
202 if (gfc_match_char ('(') != MATCH_YES)
204 ar->type = AR_FULL;
205 ar->dimen = 0;
206 return 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)
213 return MATCH_ERROR;
215 if (gfc_match_char (')') == MATCH_YES)
217 ar->dimen++;
218 goto coarray;
221 if (gfc_match_char (',') != MATCH_YES)
223 gfc_error ("Invalid form of array reference at %C");
224 return MATCH_ERROR;
228 if (ar->dimen >= 7
229 && !gfc_notify_std (GFC_STD_F2008,
230 "Array reference at %C has more than 7 dimensions"))
231 return MATCH_ERROR;
233 gfc_error ("Array reference at %C cannot have more than %d dimensions",
234 GFC_MAX_DIMENSIONS);
235 return MATCH_ERROR;
237 coarray:
238 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
240 if (ar->dimen > 0)
241 return MATCH_YES;
242 else
243 return MATCH_ERROR;
246 if (flag_coarray == GFC_FCOARRAY_NONE)
248 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
249 return MATCH_ERROR;
252 if (corank == 0)
254 gfc_error ("Unexpected coarray designator at %C");
255 return MATCH_ERROR;
258 ar->stat = NULL;
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)
264 return MATCH_ERROR;
266 team_just_seen = false;
267 stat_just_seen = false;
268 if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL)
270 ar->team = tmp;
271 team_just_seen = true;
274 if (ar->team && !team_just_seen)
276 gfc_error ("TEAM= attribute in %C misplaced");
277 return MATCH_ERROR;
280 if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL)
282 ar->stat = tmp;
283 stat_just_seen = true;
286 if (ar->stat && !stat_just_seen)
288 gfc_error ("STAT= attribute in %C misplaced");
289 return MATCH_ERROR;
292 if (gfc_match_char (']') == MATCH_YES)
294 ar->codimen++;
295 if (ar->codimen < corank)
297 gfc_error ("Too few codimensions at %C, expected %d not %d",
298 corank, ar->codimen);
299 return MATCH_ERROR;
301 if (ar->codimen > corank)
303 gfc_error ("Too many codimensions at %C, expected %d not %d",
304 corank, ar->codimen);
305 return MATCH_ERROR;
307 return MATCH_YES;
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);
315 else
316 gfc_error ("Invalid form of coarray reference at %C");
317 return MATCH_ERROR;
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);
323 return MATCH_ERROR;
326 if (ar->codimen >= corank)
328 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
329 ar->codimen + 1, corank);
330 return MATCH_ERROR;
334 gfc_error ("Array reference at %C cannot have more than %d dimensions",
335 GFC_MAX_DIMENSIONS);
336 return MATCH_ERROR;
341 /************** Array specification matching subroutines ***************/
343 /* Free all of the expressions associated with array bounds
344 specifications. */
346 void
347 gfc_free_array_spec (gfc_array_spec *as)
349 int i;
351 if (as == NULL)
352 return;
354 if (as->corank == 0)
356 for (i = 0; i < as->rank; i++)
358 gfc_free_expr (as->lower[i]);
359 gfc_free_expr (as->upper[i]);
362 else
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]);
372 free (as);
376 /* Take an array bound, resolves the expression, that make up the
377 shape and check associated constraints. */
379 static bool
380 resolve_array_bound (gfc_expr *e, int check_constant)
382 if (e == NULL)
383 return true;
385 if (!gfc_resolve_expr (e)
386 || !gfc_specification_expr (e))
387 return false;
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);
394 else
395 gfc_error ("Expression at %L in this context must be constant",
396 &e->where);
397 return false;
400 return true;
404 /* Takes an array specification, resolves the expressions that make up
405 the shape and make sure everything is integral. */
407 bool
408 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
410 gfc_expr *e;
411 int i;
413 if (as == NULL)
414 return true;
416 if (as->resolved)
417 return true;
419 for (i = 0; i < as->rank + as->corank; i++)
421 if (i == GFC_MAX_DIMENSIONS)
422 return false;
424 e = as->lower[i];
425 if (!resolve_array_bound (e, check_constant))
426 return false;
428 e = as->upper[i];
429 if (!resolve_array_bound (e, check_constant))
430 return false;
432 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
433 continue;
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);
448 as->resolved = true;
450 return true;
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 (*)
463 x 1 x AS_EXPLICIT
464 x: x NULL AS_ASSUMED_SHAPE
465 x:y x y AS_EXPLICIT
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. */
474 static array_type
475 match_array_element_spec (gfc_array_spec *as)
477 gfc_expr **upper, **lower;
478 match m;
479 int rank;
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);
499 return AS_UNKNOWN;
501 else
503 return AS_DEFERRED;
507 m = gfc_match_expr (upper);
508 if (m == MATCH_NO)
509 gfc_error ("Expected expression in array specification at %C");
510 if (m != MATCH_YES)
511 return AS_UNKNOWN;
512 if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
513 return AS_UNKNOWN;
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
519 && (*upper)->symtree
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));
524 return AS_UNKNOWN;
527 if (gfc_match_char (':') == MATCH_NO)
529 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
530 return AS_EXPLICIT;
533 *lower = *upper;
534 *upper = NULL;
536 if (gfc_match_char ('*') == MATCH_YES)
537 return AS_ASSUMED_SIZE;
539 m = gfc_match_expr (upper);
540 if (m == MATCH_ERROR)
541 return AS_UNKNOWN;
542 if (m == MATCH_NO)
543 return AS_ASSUMED_SHAPE;
544 if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
545 return AS_UNKNOWN;
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
551 && (*upper)->symtree
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));
556 return AS_UNKNOWN;
559 return AS_EXPLICIT;
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. */
567 match
568 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
570 array_type current_type;
571 gfc_array_spec *as;
572 int i;
574 as = gfc_get_array_spec ();
576 if (!match_dim)
577 goto coarray;
579 if (gfc_match_char ('(') != MATCH_YES)
581 if (!match_codim)
582 goto done;
583 goto coarray;
586 if (gfc_match (" .. )") == MATCH_YES)
588 as->type = AS_ASSUMED_RANK;
589 as->rank = -1;
591 if (!gfc_notify_std (GFC_STD_F2018, "Assumed-rank array at %C"))
592 goto cleanup;
594 if (!match_codim)
595 goto done;
596 goto coarray;
599 for (;;)
601 as->rank++;
602 current_type = match_array_element_spec (as);
603 if (current_type == AS_UNKNOWN)
604 goto cleanup;
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. */
612 if (as->rank == 1)
614 as->type = current_type;
616 else
617 switch (as->type)
618 { /* See how current spec meshes with the existing. */
619 case AS_UNKNOWN:
620 goto cleanup;
622 case AS_IMPLIED_SHAPE:
623 if (current_type != AS_ASSUMED_SIZE)
625 gfc_error ("Bad array specification for implied-shape"
626 " array at %C");
627 goto cleanup;
629 break;
631 case AS_EXPLICIT:
632 if (current_type == AS_ASSUMED_SIZE)
634 as->type = AS_ASSUMED_SIZE;
635 break;
638 if (current_type == AS_EXPLICIT)
639 break;
641 gfc_error ("Bad array specification for an explicitly shaped "
642 "array at %C");
644 goto cleanup;
646 case AS_ASSUMED_SHAPE:
647 if ((current_type == AS_ASSUMED_SHAPE)
648 || (current_type == AS_DEFERRED))
649 break;
651 gfc_error ("Bad array specification for assumed shape "
652 "array at %C");
653 goto cleanup;
655 case AS_DEFERRED:
656 if (current_type == AS_DEFERRED)
657 break;
659 if (current_type == AS_ASSUMED_SHAPE)
661 as->type = AS_ASSUMED_SHAPE;
662 break;
665 gfc_error ("Bad specification for deferred shape array at %C");
666 goto cleanup;
668 case AS_ASSUMED_SIZE:
669 if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
671 as->type = AS_IMPLIED_SHAPE;
672 break;
675 gfc_error ("Bad specification for assumed size array at %C");
676 goto cleanup;
678 case AS_ASSUMED_RANK:
679 gcc_unreachable ();
682 if (gfc_match_char (')') == MATCH_YES)
683 break;
685 if (gfc_match_char (',') != MATCH_YES)
687 gfc_error ("Expected another dimension in array declaration at %C");
688 goto cleanup;
691 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
693 gfc_error ("Array specification at %C has more than %d dimensions",
694 GFC_MAX_DIMENSIONS);
695 goto cleanup;
698 if (as->corank + as->rank >= 7
699 && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C "
700 "with more than 7 dimensions"))
701 goto cleanup;
704 if (!match_codim)
705 goto done;
707 coarray:
708 if (gfc_match_char ('[') != MATCH_YES)
709 goto done;
711 if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C"))
712 goto cleanup;
714 if (flag_coarray == GFC_FCOARRAY_NONE)
716 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
717 goto cleanup;
720 if (as->rank >= GFC_MAX_DIMENSIONS)
722 gfc_error ("Array specification at %C has more than %d "
723 "dimensions", GFC_MAX_DIMENSIONS);
724 goto cleanup;
727 for (;;)
729 as->corank++;
730 current_type = match_array_element_spec (as);
732 if (current_type == AS_UNKNOWN)
733 goto cleanup;
735 if (as->corank == 1)
736 as->cotype = current_type;
737 else
738 switch (as->cotype)
739 { /* See how current spec meshes with the existing. */
740 case AS_IMPLIED_SHAPE:
741 case AS_UNKNOWN:
742 goto cleanup;
744 case AS_EXPLICIT:
745 if (current_type == AS_ASSUMED_SIZE)
747 as->cotype = AS_ASSUMED_SIZE;
748 break;
751 if (current_type == AS_EXPLICIT)
752 break;
754 gfc_error ("Bad array specification for an explicitly "
755 "shaped array at %C");
757 goto cleanup;
759 case AS_ASSUMED_SHAPE:
760 if ((current_type == AS_ASSUMED_SHAPE)
761 || (current_type == AS_DEFERRED))
762 break;
764 gfc_error ("Bad array specification for assumed shape "
765 "array at %C");
766 goto cleanup;
768 case AS_DEFERRED:
769 if (current_type == AS_DEFERRED)
770 break;
772 if (current_type == AS_ASSUMED_SHAPE)
774 as->cotype = AS_ASSUMED_SHAPE;
775 break;
778 gfc_error ("Bad specification for deferred shape array at %C");
779 goto cleanup;
781 case AS_ASSUMED_SIZE:
782 gfc_error ("Bad specification for assumed size array at %C");
783 goto cleanup;
785 case AS_ASSUMED_RANK:
786 gcc_unreachable ();
789 if (gfc_match_char (']') == MATCH_YES)
790 break;
792 if (gfc_match_char (',') != MATCH_YES)
794 gfc_error ("Expected another dimension in array declaration at %C");
795 goto cleanup;
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);
802 goto cleanup;
806 if (current_type == AS_EXPLICIT)
808 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
809 goto cleanup;
812 if (as->cotype == AS_ASSUMED_SIZE)
813 as->cotype = AS_EXPLICIT;
815 if (as->rank == 0)
816 as->type = as->cotype;
818 done:
819 if (as->rank == 0 && as->corank == 0)
821 *asp = NULL;
822 gfc_free_array_spec (as);
823 return MATCH_NO;
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);
836 *asp = as;
838 return MATCH_YES;
840 cleanup:
841 /* Something went wrong. */
842 gfc_free_array_spec (as);
843 return MATCH_ERROR;
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. */
850 bool
851 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
853 int i;
854 symbol_attribute *attr;
856 if (as == NULL)
857 return true;
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. */
861 attr = &sym->attr;
862 if (gfc_submodule_procedure(attr))
863 return true;
865 if (as->rank
866 && !gfc_add_dimension (&sym->attr, sym->name, error_loc))
867 return false;
869 if (as->corank
870 && !gfc_add_codimension (&sym->attr, sym->name, error_loc))
871 return false;
873 if (sym->as == NULL)
875 sym->as = as;
876 return true;
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);
884 return false;
887 /* Check F2018:C822. */
888 if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
889 goto too_many;
891 if (as->corank)
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)
897 goto too_many;
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];
905 else
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)
919 goto too_many;
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];
933 free (as);
934 return true;
936 too_many:
938 gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name,
939 GFC_MAX_DIMENSIONS);
940 return false;
944 /* Copy an array specification. */
946 gfc_array_spec *
947 gfc_copy_array_spec (gfc_array_spec *src)
949 gfc_array_spec *dest;
950 int i;
952 if (src == NULL)
953 return NULL;
955 dest = gfc_get_array_spec ();
957 *dest = *src;
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]);
965 return dest;
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. */
976 static bool
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)
982 return false;
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
995 shape. */
997 bool
998 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
1000 int i;
1002 if (as1 == NULL && as2 == NULL)
1003 return 1;
1005 if (as1 == NULL || as2 == NULL)
1006 return 0;
1008 if (as1->rank != as2->rank)
1009 return 0;
1011 if (as1->corank != as2->corank)
1012 return 0;
1014 if (as1->rank == 0)
1015 return 1;
1017 if (as1->type != as2->type)
1018 return 0;
1020 if (as1->cotype != as2->cotype)
1021 return 0;
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]))
1027 return 0;
1029 if (!compare_bounds (as1->upper[i], as2->upper[i]))
1030 return 0;
1033 return 1;
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. */
1045 static bool
1046 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
1048 gfc_constructor *c;
1049 gfc_expr *e;
1051 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1053 e = c->expr;
1055 if (e->expr_type == EXPR_ARRAY
1056 && check_duplicate_iterator (e->value.constructor, master))
1057 return 1;
1059 if (c->iterator == NULL)
1060 continue;
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);
1067 return 1;
1071 return 0;
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. */
1080 static match
1081 match_array_list (gfc_constructor_base *result)
1083 gfc_constructor_base head;
1084 gfc_constructor *p;
1085 gfc_iterator iter;
1086 locus old_loc;
1087 gfc_expr *e;
1088 match m;
1089 int n;
1091 old_loc = gfc_current_locus;
1093 if (gfc_match_char ('(') == MATCH_NO)
1094 return MATCH_NO;
1096 memset (&iter, '\0', sizeof (gfc_iterator));
1097 head = NULL;
1099 m = match_array_cons_element (&head);
1100 if (m != MATCH_YES)
1101 goto cleanup;
1103 if (gfc_match_char (',') != MATCH_YES)
1105 m = MATCH_NO;
1106 goto cleanup;
1109 for (n = 1;; n++)
1111 m = gfc_match_iterator (&iter, 0);
1112 if (m == MATCH_YES)
1113 break;
1114 if (m == MATCH_ERROR)
1115 goto cleanup;
1117 m = match_array_cons_element (&head);
1118 if (m == MATCH_ERROR)
1119 goto cleanup;
1120 if (m == MATCH_NO)
1122 if (n > 2)
1123 goto syntax;
1124 m = MATCH_NO;
1125 goto cleanup; /* Could be a complex constant */
1128 if (gfc_match_char (',') != MATCH_YES)
1130 if (n > 2)
1131 goto syntax;
1132 m = MATCH_NO;
1133 goto cleanup;
1137 if (gfc_match_char (')') != MATCH_YES)
1138 goto syntax;
1140 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
1142 m = MATCH_ERROR;
1143 goto cleanup;
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;
1153 return MATCH_YES;
1155 syntax:
1156 gfc_error ("Syntax error in array constructor at %C");
1157 m = MATCH_ERROR;
1159 cleanup:
1160 gfc_constructor_free (head);
1161 gfc_free_iterator (&iter, 0);
1162 gfc_current_locus = old_loc;
1163 return m;
1167 /* Match a single element of an array constructor, which can be a
1168 single expression or a list of elements. */
1170 static match
1171 match_array_cons_element (gfc_constructor_base *result)
1173 gfc_expr *expr;
1174 match m;
1176 m = match_array_list (result);
1177 if (m != MATCH_NO)
1178 return m;
1180 m = gfc_match_expr (&expr);
1181 if (m != MATCH_YES)
1182 return m;
1184 if (expr->ts.type == BT_BOZ)
1186 gfc_error ("BOZ literal constant at %L cannot appear in an "
1187 "array constructor", &expr->where);
1188 goto done;
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");
1196 goto done;
1199 gfc_constructor_append_expr (result, expr, &gfc_current_locus);
1200 return MATCH_YES;
1202 done:
1203 gfc_free_expr (expr);
1204 return MATCH_ERROR;
1208 /* Convert components of an array constructor to the type in ts. */
1210 static match
1211 walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head)
1213 gfc_constructor *c;
1214 gfc_expr *e;
1215 match m;
1217 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1219 e = c->expr;
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)
1225 return m;
1227 else if (!gfc_convert_type_warn (e, ts, 1, 1, true)
1228 && e->ts.type != BT_UNKNOWN)
1229 return MATCH_ERROR;
1231 return MATCH_YES;
1234 /* Match an array constructor. */
1236 match
1237 gfc_match_array_constructor (gfc_expr **result)
1239 gfc_constructor *c;
1240 gfc_constructor_base head;
1241 gfc_expr *expr;
1242 gfc_typespec ts;
1243 locus where;
1244 match m;
1245 const char *end_delim;
1246 bool seen_ts;
1248 head = NULL;
1249 seen_ts = false;
1251 if (gfc_match (" (/") == MATCH_NO)
1253 if (gfc_match (" [") == MATCH_NO)
1254 return MATCH_NO;
1255 else
1257 if (!gfc_notify_std (GFC_STD_F2003, "[...] "
1258 "style array constructors at %C"))
1259 return MATCH_ERROR;
1260 end_delim = " ]";
1263 else
1264 end_delim = " /)";
1266 where = gfc_current_locus;
1268 /* Try to match an optional "type-spec ::" */
1269 gfc_clear_ts (&ts);
1270 m = gfc_match_type_spec (&ts);
1271 if (m == MATCH_YES)
1273 seen_ts = (gfc_match (" ::") == MATCH_YES);
1275 if (seen_ts)
1277 if (!gfc_notify_std (GFC_STD_F2003, "Array constructor "
1278 "including type specification at %C"))
1279 goto cleanup;
1281 if (ts.deferred)
1283 gfc_error ("Type-spec at %L cannot contain a deferred "
1284 "type parameter", &where);
1285 goto cleanup;
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);
1293 goto cleanup;
1297 else if (m == MATCH_ERROR)
1298 goto cleanup;
1300 if (!seen_ts)
1301 gfc_current_locus = where;
1303 if (gfc_match (end_delim) == MATCH_YES)
1305 if (seen_ts)
1306 goto done;
1307 else
1309 gfc_error ("Empty array constructor at %C is not allowed");
1310 goto cleanup;
1314 for (;;)
1316 m = match_array_cons_element (&head);
1317 if (m == MATCH_ERROR)
1318 goto cleanup;
1319 if (m == MATCH_NO)
1320 goto syntax;
1322 if (gfc_match_char (',') == MATCH_NO)
1323 break;
1326 if (gfc_match (end_delim) == MATCH_NO)
1327 goto syntax;
1329 done:
1330 /* Size must be calculated at resolution time. */
1331 if (seen_ts)
1333 expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1334 expr->ts = ts;
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",
1347 &c->expr->where);
1348 return MATCH_ERROR;
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",
1357 &c->expr->where);
1358 return MATCH_ERROR;
1363 /* Walk the constructor, and if possible, do type conversion for
1364 numeric types. */
1365 if (gfc_numeric_ts (&ts))
1367 m = walk_array_constructor (&ts, head);
1368 if (m == MATCH_ERROR)
1369 return m;
1372 else
1373 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1375 expr->value.constructor = head;
1376 if (expr->ts.u.cl)
1377 expr->ts.u.cl->length_from_typespec = seen_ts;
1379 *result = expr;
1381 return MATCH_YES;
1383 syntax:
1384 gfc_error ("Syntax error in array constructor at %C");
1386 cleanup:
1387 gfc_constructor_free (head);
1388 return MATCH_ERROR;
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
1399 starting out. */
1401 static gfc_typespec constructor_ts;
1402 static enum
1403 { CONS_START, CONS_GOOD, CONS_BAD }
1404 cons_state;
1406 static int
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;
1416 else
1418 cons_state = CONS_GOOD;
1419 constructor_ts = expr->ts;
1422 return 0;
1425 if (gfc_compare_types (&constructor_ts, &expr->ts))
1426 return 0;
1428 if (convert)
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;
1436 return 1;
1440 /* Recursive work function for gfc_check_constructor_type(). */
1442 static bool
1443 check_constructor_type (gfc_constructor_base base, bool convert)
1445 gfc_constructor *c;
1446 gfc_expr *e;
1448 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1450 e = c->expr;
1452 if (e->expr_type == EXPR_ARRAY)
1454 if (!check_constructor_type (e->value.constructor, convert))
1455 return false;
1457 continue;
1460 if (check_element_type (e, convert))
1461 return false;
1464 return true;
1468 /* Check that all elements of an array constructor are the same type.
1469 On false, an error has been generated. */
1471 bool
1472 gfc_check_constructor_type (gfc_expr *e)
1474 bool t;
1476 if (e->ts.type != BT_UNKNOWN)
1478 cons_state = CONS_GOOD;
1479 constructor_ts = e->ts;
1481 else
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;
1493 return t;
1498 typedef struct cons_stack
1500 gfc_iterator *iterator;
1501 struct cons_stack *previous;
1503 cons_stack;
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. */
1512 bool
1513 gfc_check_iter_variable (gfc_expr *expr)
1515 gfc_symbol *sym;
1516 cons_stack *c;
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)
1522 return true;
1524 return false;
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. */
1532 static bool
1533 check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *))
1535 cons_stack element;
1536 gfc_expr *e;
1537 bool t;
1538 gfc_constructor *c;
1540 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1542 e = c->expr;
1544 if (!e)
1545 continue;
1547 if (e->expr_type != EXPR_ARRAY)
1549 if (!(*check_function)(e))
1550 return false;
1551 continue;
1554 element.previous = base;
1555 element.iterator = c->iterator;
1557 base = &element;
1558 t = check_constructor (e->value.constructor, check_function);
1559 base = element.previous;
1561 if (!t)
1562 return false;
1565 /* Nothing went wrong, so all OK. */
1566 return true;
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. */
1574 bool
1575 gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *))
1577 cons_stack *base_save;
1578 bool t;
1580 base_save = base;
1581 base = NULL;
1583 t = check_constructor (expr->value.constructor, check_function);
1584 base = base_save;
1586 return t;
1591 /**************** Simplification of array constructors ****************/
1593 iterator_stack *iter_stack;
1595 typedef struct
1597 gfc_constructor_base base;
1598 int extract_count, extract_n;
1599 gfc_expr *extracted;
1600 mpz_t *count;
1602 mpz_t *offset;
1603 gfc_component *component;
1604 mpz_t *repeat;
1606 bool (*expand_work_function) (gfc_expr *);
1608 expand_info;
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
1616 constructor. */
1618 static bool
1619 count_elements (gfc_expr *e)
1621 mpz_t result;
1623 if (e->rank == 0)
1624 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1625 else
1627 if (!gfc_array_size (e, &result))
1629 gfc_free_expr (e);
1630 return false;
1633 mpz_add (*current_expand.count, *current_expand.count, result);
1634 mpz_clear (result);
1637 gfc_free_expr (e);
1638 return true;
1642 /* Work function that extracts a particular element from an array
1643 constructor, freeing the rest. */
1645 static bool
1646 extract_element (gfc_expr *e)
1648 if (e->rank != 0)
1649 { /* Something unextractable */
1650 gfc_free_expr (e);
1651 return false;
1654 if (current_expand.extract_count == current_expand.extract_n)
1655 current_expand.extracted = e;
1656 else
1657 gfc_free_expr (e);
1659 current_expand.extract_count++;
1661 return true;
1665 /* Work function that constructs a new constructor out of the old one,
1666 stringing new elements together. */
1668 static bool
1669 expand (gfc_expr *e)
1671 gfc_constructor *c = gfc_constructor_append_expr (&current_expand.base,
1672 e, &e->where);
1674 c->n.component = current_expand.component;
1675 return true;
1679 /* Given an initialization expression that is a variable reference,
1680 substitute the current value of the iteration variable. */
1682 void
1683 gfc_simplify_iterator_var (gfc_expr *e)
1685 iterator_stack *p;
1687 for (p = iter_stack; p; p = p->prev)
1688 if (e->symtree == p->variable)
1689 break;
1691 if (p == NULL)
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);
1698 return;
1702 /* Expand an expression with that is inside of a constructor,
1703 recursing into other constructors if present. */
1705 static bool
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))
1715 gfc_free_expr (e);
1716 return false;
1719 return current_expand.expand_work_function (e);
1723 static bool
1724 expand_iterator (gfc_constructor *c)
1726 gfc_expr *start, *end, *step;
1727 iterator_stack frame;
1728 mpz_t trip;
1729 bool t;
1731 end = step = NULL;
1733 t = false;
1735 mpz_init (trip);
1736 mpz_init (frame.value);
1737 frame.prev = NULL;
1739 start = gfc_copy_expr (c->iterator->start);
1740 if (!gfc_simplify_expr (start, 1))
1741 goto cleanup;
1743 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1744 goto cleanup;
1746 end = gfc_copy_expr (c->iterator->end);
1747 if (!gfc_simplify_expr (end, 1))
1748 goto cleanup;
1750 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1751 goto cleanup;
1753 step = gfc_copy_expr (c->iterator->step);
1754 if (!gfc_simplify_expr (step, 1))
1755 goto cleanup;
1757 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1758 goto cleanup;
1760 if (mpz_sgn (step->value.integer) == 0)
1762 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1763 goto cleanup;
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))
1780 goto cleanup;
1782 mpz_add (frame.value, frame.value, step->value.integer);
1783 mpz_sub_ui (trip, trip, 1);
1786 t = true;
1788 cleanup:
1789 gfc_free_expr (start);
1790 gfc_free_expr (end);
1791 gfc_free_expr (step);
1793 mpz_clear (trip);
1794 mpz_clear (frame.value);
1796 iter_stack = frame.prev;
1798 return t;
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. */
1812 static bool
1813 expand_constructor (gfc_constructor_base base)
1815 gfc_constructor *c;
1816 gfc_expr *e;
1818 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1820 if (c->iterator != NULL)
1822 if (!expand_iterator (c))
1823 return false;
1824 continue;
1827 e = c->expr;
1829 if (e == NULL)
1830 return false;
1832 if (empty_constructor)
1833 empty_ts = e->ts;
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))
1844 return false;
1846 continue;
1849 empty_constructor = false;
1850 e = gfc_copy_expr (e);
1851 if (!gfc_simplify_expr (e, 1))
1853 gfc_free_expr (e);
1854 return false;
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))
1861 return false;
1863 return true;
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. */
1874 static gfc_expr *
1875 gfc_get_array_element (gfc_expr *array, int element)
1877 expand_info expand_save;
1878 gfc_expr *e;
1879 bool rc;
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;
1887 iter_stack = NULL;
1889 rc = expand_constructor (array->value.constructor);
1890 e = current_expand.extracted;
1891 current_expand = expand_save;
1893 if (!rc)
1894 return NULL;
1896 return e;
1900 /* Top level subroutine for expanding constructors. We only expand
1901 constructor if they are small enough. */
1903 bool
1904 gfc_expand_constructor (gfc_expr *e, bool fatal)
1906 expand_info expand_save;
1907 gfc_expr *f;
1908 bool rc;
1910 if (gfc_is_size_zero_array (e))
1911 return true;
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);
1916 if (f != NULL)
1918 gfc_free_expr (f);
1919 if (fatal)
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);
1925 return false;
1927 return true;
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;
1934 iter_stack = 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);
1943 rc = false;
1944 goto done;
1947 /* If we don't have an explicit constructor type, and there
1948 were only empty constructors, then take the type from
1949 them. */
1951 if (constructor_ts.type == BT_UNKNOWN && empty_constructor)
1952 e->ts = empty_ts;
1954 gfc_constructor_free (e->value.constructor);
1955 e->value.constructor = current_expand.base;
1957 rc = true;
1959 done:
1960 current_expand = expand_save;
1962 return rc;
1966 /* Work function for checking that an element of a constructor is a
1967 constant, after removal of any iteration variables. We return
1968 false if not so. */
1970 static bool
1971 is_constant_element (gfc_expr *e)
1973 int rv;
1975 rv = gfc_is_constant_expr (e);
1976 gfc_free_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. */
1988 bool
1989 gfc_constant_ac (gfc_expr *e)
1991 expand_info expand_save;
1992 bool rc;
1994 iter_stack = NULL;
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;
2001 if (!rc)
2002 return 0;
2004 return 1;
2008 /* Returns nonzero if an array constructor has been completely
2009 expanded (no iterators) and zero if iterators are present. */
2011 bool
2012 gfc_expanded_ac (gfc_expr *e)
2014 gfc_constructor *c;
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))
2020 return 0;
2022 return 1;
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
2035 accordingly.
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. */
2039 static int
2040 expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2041 void *where)
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;
2050 return 1;
2053 return 0;
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. */
2060 static bool
2061 find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc)
2063 int ret;
2065 sought_symbol = sym;
2066 ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc);
2067 sought_symbol = NULL;
2068 return ret;
2072 /* Recursive array list resolution function. All of the elements must
2073 be of the same type. */
2075 static bool
2076 resolve_array_list (gfc_constructor_base base)
2078 bool t;
2079 gfc_constructor *c;
2080 gfc_iterator *iter;
2082 t = true;
2084 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2086 iter = c->iterator;
2087 if (iter != NULL)
2089 gfc_symbol *iter_var;
2090 locus iter_var_loc;
2092 if (!gfc_resolve_iterator (iter, false, true))
2093 t = false;
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))
2103 t = false;
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))
2110 t = false;
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))
2117 t = false;
2121 if (!gfc_resolve_expr (c->expr))
2122 t = false;
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);
2128 t = false;
2132 return t;
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
2138 invalid. */
2140 bool
2141 gfc_resolve_character_array_constructor (gfc_expr *expr)
2143 gfc_constructor *p;
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;
2158 goto got_charlen;
2161 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2164 got_charlen:
2166 /* Early exit for zero size arrays. */
2167 if (expr->shape)
2169 mpz_t size;
2170 HOST_WIDE_INT arraysize;
2172 gfc_array_size (expr, &size);
2173 arraysize = mpz_get_ui (size);
2174 mpz_clear (size);
2176 if (arraysize == 0)
2177 return true;
2180 found_length = -1;
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;
2191 gfc_ref *ref;
2192 for (ref = p->expr->ref; ref; ref = ref->next)
2193 if (ref->type == REF_SUBSTRING
2194 && ref->u.ss.start
2195 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2196 && ref->u.ss.end
2197 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2198 break;
2200 if (p->expr->expr_type == EXPR_CONSTANT)
2201 current_length = p->expr->value.character.length;
2202 else if (ref)
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);
2208 else
2209 return true;
2211 if (current_length < 0)
2212 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);
2221 return false;
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);
2233 else
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
2247 anyway. */
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;
2255 bool has_ts;
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, &current_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;
2268 if (! cl
2269 || (current_length != -1 && current_length != found_length))
2270 gfc_set_constant_character_len (found_length, p->expr,
2271 has_ts ? -1 : found_length);
2275 return true;
2279 /* Resolve all of the expressions in an array list. */
2281 bool
2282 gfc_resolve_array_constructor (gfc_expr *expr)
2284 bool t;
2286 t = resolve_array_list (expr->value.constructor);
2287 if (t)
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. */
2294 return t;
2298 /* Copy an iterator structure. */
2300 gfc_iterator *
2301 gfc_copy_iterator (gfc_iterator *src)
2303 gfc_iterator *dest;
2305 if (src == NULL)
2306 return NULL;
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;
2316 return dest;
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. */
2329 bool
2330 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2332 if (as == NULL)
2333 return false;
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])
2341 return false;
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)
2347 return false;
2349 mpz_init (*result);
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);
2359 return true;
2363 bool
2364 spec_size (gfc_array_spec *as, mpz_t *result)
2366 mpz_t size;
2367 int d;
2369 if (!as || as->type == AS_ASSUMED_RANK)
2370 return false;
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);
2379 return false;
2382 mpz_mul (*result, *result, size);
2383 mpz_clear (size);
2386 return true;
2390 /* Get the number of elements in an array section. Optionally, also supply
2391 the end value. */
2393 bool
2394 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
2396 mpz_t upper, lower, stride;
2397 mpz_t diff;
2398 bool t;
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]);
2407 return false;
2410 switch (ar->dimen_type[dimen])
2412 case DIMEN_ELEMENT:
2413 mpz_init (*result);
2414 mpz_set_ui (*result, 1);
2415 t = true;
2416 break;
2418 case DIMEN_VECTOR:
2419 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2420 break;
2422 case DIMEN_RANGE:
2424 mpz_init (stride);
2426 if (ar->stride[dimen] == NULL)
2427 mpz_set_ui (stride, 1);
2428 else
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);
2437 mpz_clear (stride);
2438 return false;
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
2448 subroutine foo(a,n)
2449 real a(1:n)
2450 n = 3
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. */
2457 if (end == NULL)
2459 bool use_dep;
2461 use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
2462 &diff);
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);
2467 if (use_dep)
2469 mpz_init (*result);
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);
2475 mpz_clear (stride);
2476 mpz_clear (diff);
2477 return true;
2482 /* Constant-only code here, which covers more cases
2483 like a(:4) etc. */
2484 mpz_init (upper);
2485 mpz_init (lower);
2486 t = false;
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)
2493 goto cleanup;
2494 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2496 else
2498 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2499 goto cleanup;
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)
2508 goto cleanup;
2509 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2511 else
2513 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2514 goto cleanup;
2515 mpz_set (upper, ar->end[dimen]->value.integer);
2518 mpz_init (*result);
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);
2526 t = true;
2528 if (end)
2530 mpz_init (*end);
2532 mpz_sub_ui (*end, *result, 1UL);
2533 mpz_mul (*end, *end, stride);
2534 mpz_add (*end, *end, lower);
2537 cleanup:
2538 mpz_clear (upper);
2539 mpz_clear (lower);
2540 mpz_clear (stride);
2541 return t;
2543 default:
2544 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2547 return t;
2551 static bool
2552 ref_size (gfc_array_ref *ar, mpz_t *result)
2554 mpz_t size;
2555 int d;
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);
2564 return false;
2567 mpz_mul (*result, *result, size);
2568 mpz_clear (size);
2571 return true;
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
2578 otherwise. */
2580 bool
2581 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2583 gfc_ref *ref;
2584 int i;
2586 gcc_assert (array != NULL);
2588 if (array->ts.type == BT_CLASS)
2589 return false;
2591 if (array->rank == -1)
2592 return false;
2594 if (dimen < 0 || dimen > array->rank - 1)
2595 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2597 switch (array->expr_type)
2599 case EXPR_VARIABLE:
2600 case EXPR_FUNCTION:
2601 for (ref = array->ref; ref; ref = ref->next)
2603 /* Ultimate component is a procedure pointer. */
2604 if (ref->type == REF_COMPONENT
2605 && !ref->next
2606 && ref->u.c.component->attr.function
2607 && IS_PROC_POINTER (ref->u.c.component))
2608 return false;
2610 if (ref->type != REF_ARRAY)
2611 continue;
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)
2620 dimen--;
2622 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2626 if (array->shape)
2628 mpz_init_set (*result, array->shape[dimen]);
2629 return true;
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))
2636 return false;
2638 else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result))
2639 return false;
2641 break;
2643 case EXPR_ARRAY:
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);
2651 /* Fall through */
2652 default:
2653 if (array->shape == NULL)
2654 return false;
2656 mpz_init_set (*result, array->shape[dimen]);
2658 break;
2661 return true;
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. */
2669 bool
2670 gfc_array_size (gfc_expr *array, mpz_t *result)
2672 expand_info expand_save;
2673 gfc_ref *ref;
2674 int i;
2675 bool t;
2677 if (array->ts.type == BT_CLASS)
2678 return false;
2680 switch (array->expr_type)
2682 case EXPR_ARRAY:
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;
2691 iter_stack = NULL;
2693 t = expand_constructor (array->value.constructor);
2695 gfc_pop_suppress_errors ();
2697 if (!t)
2698 mpz_clear (*result);
2699 current_expand = expand_save;
2700 return t;
2702 case EXPR_VARIABLE:
2703 for (ref = array->ref; ref; ref = ref->next)
2705 if (ref->type != REF_ARRAY)
2706 continue;
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);
2718 default:
2719 if (array->rank == 0 || array->shape == NULL)
2720 return false;
2722 mpz_init_set_ui (*result, 1);
2724 for (i = 0; i < array->rank; i++)
2725 mpz_mul (*result, *result, array->shape[i]);
2727 break;
2730 return true;
2734 /* Given an array reference, return the shape of the reference in an
2735 array of mpz_t integers. */
2737 bool
2738 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2740 int d;
2741 int i;
2743 d = 0;
2745 switch (ar->type)
2747 case AR_FULL:
2748 for (; d < ar->as->rank; d++)
2749 if (!spec_dimen_size (ar->as, d, &shape[d]))
2750 goto cleanup;
2752 return true;
2754 case AR_SECTION:
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))
2760 goto cleanup;
2761 d++;
2765 return true;
2767 default:
2768 break;
2771 cleanup:
2772 gfc_clear_shape (shape, d);
2773 return false;
2777 /* Given an array expression, find the array reference structure that
2778 characterizes the reference. */
2780 gfc_array_ref *
2781 gfc_find_array_ref (gfc_expr *e, bool allow_null)
2783 gfc_ref *ref;
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))
2788 break;
2790 if (ref == NULL)
2792 if (allow_null)
2793 return NULL;
2794 else
2795 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2798 return &ref->u.ar;
2802 /* Find out if an array shape is known at compile time. */
2804 bool
2805 gfc_is_compile_time_shape (gfc_array_spec *as)
2807 if (as->type != AS_EXPLICIT)
2808 return false;
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]))
2813 return false;
2815 return true;