1 /* Array things
2 Copyright (C) 2000-2022 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
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.
11
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.
16
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/>. */
20
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"
29
30 /**************** Array reference matching subroutines *****************/
31
32 /* Copy an array reference structure. */
33
34 gfc_array_ref *
gfc_copy_array_ref(gfc_array_ref * src)35 gfc_copy_array_ref (gfc_array_ref *src)
36 {
37 gfc_array_ref *dest;
38 int i;
39
40 if (src == NULL)
41 return NULL;
42
43 dest = gfc_get_array_ref ();
44
45 *dest = *src;
46
47 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
48 {
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]);
52 }
53
54 return dest;
55 }
56
57
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. */
63
64 static match
match_subscript(gfc_array_ref * ar,int init,bool match_star)65 match_subscript (gfc_array_ref *ar, int init, bool match_star)
66 {
67 match m = MATCH_ERROR;
68 bool star = false;
69 int i;
70 bool saw_boz = false;
71
72 i = ar->dimen + ar->codimen;
73
74 gfc_gobble_whitespace ();
75 ar->c_where[i] = gfc_current_locus;
76 ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
77
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. */
81
82 ar->dimen_type[i] = DIMEN_UNKNOWN;
83
84 if (gfc_match_char (':') == MATCH_YES)
85 goto end_element;
86
87 /* Get start element. */
88 if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
89 star = true;
90
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]);
95
96 if (ar->start[i] && ar->start[i]->ts.type == BT_BOZ)
97 {
98 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
99 saw_boz = true;
100 }
101
102 if (m == MATCH_NO)
103 gfc_error ("Expected array subscript at %C");
104 if (m != MATCH_YES)
105 return MATCH_ERROR;
106
107 if (gfc_match_char (':') == MATCH_NO)
108 goto matched;
109
110 if (star)
111 {
112 gfc_error ("Unexpected %<*%> in coarray subscript at %C");
113 return MATCH_ERROR;
114 }
115
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;
120
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]);
127
128 if (ar->end[i] && ar->end[i]->ts.type == BT_BOZ)
129 {
130 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
131 saw_boz = true;
132 }
133
134 if (m == MATCH_ERROR)
135 return MATCH_ERROR;
136
137 if (star && ar->start[i] == NULL)
138 {
139 gfc_error ("Missing lower bound in assumed size "
140 "coarray specification at %C");
141 return MATCH_ERROR;
142 }
143
144 /* See if we have an optional stride. */
145 if (gfc_match_char (':') == MATCH_YES)
146 {
147 if (star)
148 {
149 gfc_error ("Strides not allowed in coarray subscript at %C");
150 return MATCH_ERROR;
151 }
152
153 m = init ? gfc_match_init_expr (&ar->stride[i])
154 : gfc_match_expr (&ar->stride[i]);
155
156 if (ar->stride[i] && ar->stride[i]->ts.type == BT_BOZ)
157 {
158 gfc_error ("Invalid BOZ literal constant used in subscript at %C");
159 saw_boz = true;
160 }
161
162 if (m == MATCH_NO)
163 gfc_error ("Expected array subscript stride at %C");
164 if (m != MATCH_YES)
165 return MATCH_ERROR;
166 }
167
168 matched:
169 if (star)
170 ar->dimen_type[i] = DIMEN_STAR;
171
172 return (saw_boz ? MATCH_ERROR : MATCH_YES);
173 }
174
175
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. */
179
180 match
gfc_match_array_ref(gfc_array_ref * ar,gfc_array_spec * as,int init,int corank)181 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
182 int corank)
183 {
184 match m;
185 bool matched_bracket = false;
186 gfc_expr *tmp;
187 bool stat_just_seen = false;
188 bool team_just_seen = false;
189
190 memset (ar, '\0', sizeof (*ar));
191
192 ar->where = gfc_current_locus;
193 ar->as = as;
194 ar->type = AR_UNKNOWN;
195
196 if (gfc_match_char ('[') == MATCH_YES)
197 {
198 matched_bracket = true;
199 goto coarray;
200 }
201
202 if (gfc_match_char ('(') != MATCH_YES)
203 {
204 ar->type = AR_FULL;
205 ar->dimen = 0;
206 return MATCH_YES;
207 }
208
209 for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
210 {
211 m = match_subscript (ar, init, false);
212 if (m == MATCH_ERROR)
213 return MATCH_ERROR;
214
215 if (gfc_match_char (')') == MATCH_YES)
216 {
217 ar->dimen++;
218 goto coarray;
219 }
220
221 if (gfc_match_char (',') != MATCH_YES)
222 {
223 gfc_error ("Invalid form of array reference at %C");
224 return MATCH_ERROR;
225 }
226 }
227
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;
232
233 gfc_error ("Array reference at %C cannot have more than %d dimensions",
234 GFC_MAX_DIMENSIONS);
235 return MATCH_ERROR;
236
237 coarray:
238 if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
239 {
240 if (ar->dimen > 0)
241 return MATCH_YES;
242 else
243 return MATCH_ERROR;
244 }
245
246 if (flag_coarray == GFC_FCOARRAY_NONE)
247 {
248 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
249 return MATCH_ERROR;
250 }
251
252 if (corank == 0)
253 {
254 gfc_error ("Unexpected coarray designator at %C");
255 return MATCH_ERROR;
256 }
257
258 ar->stat = NULL;
259
260 for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
261 {
262 m = match_subscript (ar, init, true);
263 if (m == MATCH_ERROR)
264 return MATCH_ERROR;
265
266 team_just_seen = false;
267 stat_just_seen = false;
268 if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL)
269 {
270 ar->team = tmp;
271 team_just_seen = true;
272 }
273
274 if (ar->team && !team_just_seen)
275 {
276 gfc_error ("TEAM= attribute in %C misplaced");
277 return MATCH_ERROR;
278 }
279
280 if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL)
281 {
282 ar->stat = tmp;
283 stat_just_seen = true;
284 }
285
286 if (ar->stat && !stat_just_seen)
287 {
288 gfc_error ("STAT= attribute in %C misplaced");
289 return MATCH_ERROR;
290 }
291
292 if (gfc_match_char (']') == MATCH_YES)
293 {
294 ar->codimen++;
295 if (ar->codimen < corank)
296 {
297 gfc_error ("Too few codimensions at %C, expected %d not %d",
298 corank, ar->codimen);
299 return MATCH_ERROR;
300 }
301 if (ar->codimen > corank)
302 {
303 gfc_error ("Too many codimensions at %C, expected %d not %d",
304 corank, ar->codimen);
305 return MATCH_ERROR;
306 }
307 return MATCH_YES;
308 }
309
310 if (gfc_match_char (',') != MATCH_YES)
311 {
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;
318 }
319 else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR)
320 {
321 gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
322 ar->codimen + 1, corank);
323 return MATCH_ERROR;
324 }
325
326 if (ar->codimen >= corank)
327 {
328 gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
329 ar->codimen + 1, corank);
330 return MATCH_ERROR;
331 }
332 }
333
334 gfc_error ("Array reference at %C cannot have more than %d dimensions",
335 GFC_MAX_DIMENSIONS);
336 return MATCH_ERROR;
337
338 }
339
340
341 /************** Array specification matching subroutines ***************/
342
343 /* Free all of the expressions associated with array bounds
344 specifications. */
345
346 void
gfc_free_array_spec(gfc_array_spec * as)347 gfc_free_array_spec (gfc_array_spec *as)
348 {
349 int i;
350
351 if (as == NULL)
352 return;
353
354 if (as->corank == 0)
355 {
356 for (i = 0; i < as->rank; i++)
357 {
358 gfc_free_expr (as->lower[i]);
359 gfc_free_expr (as->upper[i]);
360 }
361 }
362 else
363 {
364 int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0);
365 for (i = 0; i < n; i++)
366 {
367 gfc_free_expr (as->lower[i]);
368 gfc_free_expr (as->upper[i]);
369 }
370 }
371
372 free (as);
373 }
374
375
376 /* Take an array bound, resolves the expression, that make up the
377 shape and check associated constraints. */
378
379 static bool
resolve_array_bound(gfc_expr * e,int check_constant)380 resolve_array_bound (gfc_expr *e, int check_constant)
381 {
382 if (e == NULL)
383 return true;
384
385 if (!gfc_resolve_expr (e)
386 || !gfc_specification_expr (e))
387 return false;
388
389 if (check_constant && !gfc_is_constant_expr (e))
390 {
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;
398 }
399
400 return true;
401 }
402
403
404 /* Takes an array specification, resolves the expressions that make up
405 the shape and make sure everything is integral. */
406
407 bool
gfc_resolve_array_spec(gfc_array_spec * as,int check_constant)408 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
409 {
410 gfc_expr *e;
411 int i;
412
413 if (as == NULL)
414 return true;
415
416 if (as->resolved)
417 return true;
418
419 for (i = 0; i < as->rank + as->corank; i++)
420 {
421 if (i == GFC_MAX_DIMENSIONS)
422 return false;
423
424 e = as->lower[i];
425 if (!resolve_array_bound (e, check_constant))
426 return false;
427
428 e = as->upper[i];
429 if (!resolve_array_bound (e, check_constant))
430 return false;
431
432 if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
433 continue;
434
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)
440 {
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);
445 }
446 }
447
448 as->resolved = true;
449
450 return true;
451 }
452
453
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.
458
459
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
468
469 (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
470 is fixed during the resolution of formal interfaces.
471
472 Anything else AS_UNKNOWN. */
473
474 static array_type
match_array_element_spec(gfc_array_spec * as)475 match_array_element_spec (gfc_array_spec *as)
476 {
477 gfc_expr **upper, **lower;
478 match m;
479 int rank;
480
481 rank = as->rank == -1 ? 0 : as->rank;
482 lower = &as->lower[rank + as->corank - 1];
483 upper = &as->upper[rank + as->corank - 1];
484
485 if (gfc_match_char ('*') == MATCH_YES)
486 {
487 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
488 return AS_ASSUMED_SIZE;
489 }
490
491 if (gfc_match_char (':') == MATCH_YES)
492 return AS_DEFERRED;
493
494 m = gfc_match_expr (upper);
495 if (m == MATCH_NO)
496 gfc_error ("Expected expression in array specification at %C");
497 if (m != MATCH_YES)
498 return AS_UNKNOWN;
499 if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
500 return AS_UNKNOWN;
501
502 if (((*upper)->expr_type == EXPR_CONSTANT
503 && (*upper)->ts.type != BT_INTEGER) ||
504 ((*upper)->expr_type == EXPR_FUNCTION
505 && (*upper)->ts.type == BT_UNKNOWN
506 && (*upper)->symtree
507 && strcmp ((*upper)->symtree->name, "null") == 0))
508 {
509 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
510 gfc_basic_typename ((*upper)->ts.type));
511 return AS_UNKNOWN;
512 }
513
514 if (gfc_match_char (':') == MATCH_NO)
515 {
516 *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
517 return AS_EXPLICIT;
518 }
519
520 *lower = *upper;
521 *upper = NULL;
522
523 if (gfc_match_char ('*') == MATCH_YES)
524 return AS_ASSUMED_SIZE;
525
526 m = gfc_match_expr (upper);
527 if (m == MATCH_ERROR)
528 return AS_UNKNOWN;
529 if (m == MATCH_NO)
530 return AS_ASSUMED_SHAPE;
531 if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
532 return AS_UNKNOWN;
533
534 if (((*upper)->expr_type == EXPR_CONSTANT
535 && (*upper)->ts.type != BT_INTEGER) ||
536 ((*upper)->expr_type == EXPR_FUNCTION
537 && (*upper)->ts.type == BT_UNKNOWN
538 && (*upper)->symtree
539 && strcmp ((*upper)->symtree->name, "null") == 0))
540 {
541 gfc_error ("Expecting a scalar INTEGER expression at %C, found %s",
542 gfc_basic_typename ((*upper)->ts.type));
543 return AS_UNKNOWN;
544 }
545
546 return AS_EXPLICIT;
547 }
548
549
550 /* Matches an array specification, incidentally figuring out what sort
551 it is. Match either a normal array specification, or a coarray spec
552 or both. Optionally allow [:] for coarrays. */
553
554 match
gfc_match_array_spec(gfc_array_spec ** asp,bool match_dim,bool match_codim)555 gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
556 {
557 array_type current_type;
558 gfc_array_spec *as;
559 int i;
560
561 as = gfc_get_array_spec ();
562
563 if (!match_dim)
564 goto coarray;
565
566 if (gfc_match_char ('(') != MATCH_YES)
567 {
568 if (!match_codim)
569 goto done;
570 goto coarray;
571 }
572
573 if (gfc_match (" .. )") == MATCH_YES)
574 {
575 as->type = AS_ASSUMED_RANK;
576 as->rank = -1;
577
578 if (!gfc_notify_std (GFC_STD_F2018, "Assumed-rank array at %C"))
579 goto cleanup;
580
581 if (!match_codim)
582 goto done;
583 goto coarray;
584 }
585
586 for (;;)
587 {
588 as->rank++;
589 current_type = match_array_element_spec (as);
590
591 /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
592 and implied-shape specifications. If the rank is at least 2, we can
593 distinguish between them. But for rank 1, we currently return
594 ASSUMED_SIZE; this gets adjusted later when we know for sure
595 whether the symbol parsed is a PARAMETER or not. */
596
597 if (as->rank == 1)
598 {
599 if (current_type == AS_UNKNOWN)
600 goto cleanup;
601 as->type = current_type;
602 }
603 else
604 switch (as->type)
605 { /* See how current spec meshes with the existing. */
606 case AS_UNKNOWN:
607 goto cleanup;
608
609 case AS_IMPLIED_SHAPE:
610 if (current_type != AS_ASSUMED_SIZE)
611 {
612 gfc_error ("Bad array specification for implied-shape"
613 " array at %C");
614 goto cleanup;
615 }
616 break;
617
618 case AS_EXPLICIT:
619 if (current_type == AS_ASSUMED_SIZE)
620 {
621 as->type = AS_ASSUMED_SIZE;
622 break;
623 }
624
625 if (current_type == AS_EXPLICIT)
626 break;
627
628 gfc_error ("Bad array specification for an explicitly shaped "
629 "array at %C");
630
631 goto cleanup;
632
633 case AS_ASSUMED_SHAPE:
634 if ((current_type == AS_ASSUMED_SHAPE)
635 || (current_type == AS_DEFERRED))
636 break;
637
638 gfc_error ("Bad array specification for assumed shape "
639 "array at %C");
640 goto cleanup;
641
642 case AS_DEFERRED:
643 if (current_type == AS_DEFERRED)
644 break;
645
646 if (current_type == AS_ASSUMED_SHAPE)
647 {
648 as->type = AS_ASSUMED_SHAPE;
649 break;
650 }
651
652 gfc_error ("Bad specification for deferred shape array at %C");
653 goto cleanup;
654
655 case AS_ASSUMED_SIZE:
656 if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
657 {
658 as->type = AS_IMPLIED_SHAPE;
659 break;
660 }
661
662 gfc_error ("Bad specification for assumed size array at %C");
663 goto cleanup;
664
665 case AS_ASSUMED_RANK:
666 gcc_unreachable ();
667 }
668
669 if (gfc_match_char (')') == MATCH_YES)
670 break;
671
672 if (gfc_match_char (',') != MATCH_YES)
673 {
674 gfc_error ("Expected another dimension in array declaration at %C");
675 goto cleanup;
676 }
677
678 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
679 {
680 gfc_error ("Array specification at %C has more than %d dimensions",
681 GFC_MAX_DIMENSIONS);
682 goto cleanup;
683 }
684
685 if (as->corank + as->rank >= 7
686 && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C "
687 "with more than 7 dimensions"))
688 goto cleanup;
689 }
690
691 if (!match_codim)
692 goto done;
693
694 coarray:
695 if (gfc_match_char ('[') != MATCH_YES)
696 goto done;
697
698 if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C"))
699 goto cleanup;
700
701 if (flag_coarray == GFC_FCOARRAY_NONE)
702 {
703 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
704 goto cleanup;
705 }
706
707 if (as->rank >= GFC_MAX_DIMENSIONS)
708 {
709 gfc_error ("Array specification at %C has more than %d "
710 "dimensions", GFC_MAX_DIMENSIONS);
711 goto cleanup;
712 }
713
714 for (;;)
715 {
716 as->corank++;
717 current_type = match_array_element_spec (as);
718
719 if (current_type == AS_UNKNOWN)
720 goto cleanup;
721
722 if (as->corank == 1)
723 as->cotype = current_type;
724 else
725 switch (as->cotype)
726 { /* See how current spec meshes with the existing. */
727 case AS_IMPLIED_SHAPE:
728 case AS_UNKNOWN:
729 goto cleanup;
730
731 case AS_EXPLICIT:
732 if (current_type == AS_ASSUMED_SIZE)
733 {
734 as->cotype = AS_ASSUMED_SIZE;
735 break;
736 }
737
738 if (current_type == AS_EXPLICIT)
739 break;
740
741 gfc_error ("Bad array specification for an explicitly "
742 "shaped array at %C");
743
744 goto cleanup;
745
746 case AS_ASSUMED_SHAPE:
747 if ((current_type == AS_ASSUMED_SHAPE)
748 || (current_type == AS_DEFERRED))
749 break;
750
751 gfc_error ("Bad array specification for assumed shape "
752 "array at %C");
753 goto cleanup;
754
755 case AS_DEFERRED:
756 if (current_type == AS_DEFERRED)
757 break;
758
759 if (current_type == AS_ASSUMED_SHAPE)
760 {
761 as->cotype = AS_ASSUMED_SHAPE;
762 break;
763 }
764
765 gfc_error ("Bad specification for deferred shape array at %C");
766 goto cleanup;
767
768 case AS_ASSUMED_SIZE:
769 gfc_error ("Bad specification for assumed size array at %C");
770 goto cleanup;
771
772 case AS_ASSUMED_RANK:
773 gcc_unreachable ();
774 }
775
776 if (gfc_match_char (']') == MATCH_YES)
777 break;
778
779 if (gfc_match_char (',') != MATCH_YES)
780 {
781 gfc_error ("Expected another dimension in array declaration at %C");
782 goto cleanup;
783 }
784
785 if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
786 {
787 gfc_error ("Array specification at %C has more than %d "
788 "dimensions", GFC_MAX_DIMENSIONS);
789 goto cleanup;
790 }
791 }
792
793 if (current_type == AS_EXPLICIT)
794 {
795 gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
796 goto cleanup;
797 }
798
799 if (as->cotype == AS_ASSUMED_SIZE)
800 as->cotype = AS_EXPLICIT;
801
802 if (as->rank == 0)
803 as->type = as->cotype;
804
805 done:
806 if (as->rank == 0 && as->corank == 0)
807 {
808 *asp = NULL;
809 gfc_free_array_spec (as);
810 return MATCH_NO;
811 }
812
813 /* If a lower bounds of an assumed shape array is blank, put in one. */
814 if (as->type == AS_ASSUMED_SHAPE)
815 {
816 for (i = 0; i < as->rank + as->corank; i++)
817 {
818 if (as->lower[i] == NULL)
819 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
820 }
821 }
822
823 *asp = as;
824
825 return MATCH_YES;
826
827 cleanup:
828 /* Something went wrong. */
829 gfc_free_array_spec (as);
830 return MATCH_ERROR;
831 }
832
833 /* Given a symbol and an array specification, modify the symbol to
834 have that array specification. The error locus is needed in case
835 something goes wrong. On failure, the caller must free the spec. */
836
837 bool
gfc_set_array_spec(gfc_symbol * sym,gfc_array_spec * as,locus * error_loc)838 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
839 {
840 int i;
841 symbol_attribute *attr;
842
843 if (as == NULL)
844 return true;
845
846 /* If the symbol corresponds to a submodule module procedure the array spec is
847 already set, so do not attempt to set it again here. */
848 attr = &sym->attr;
849 if (gfc_submodule_procedure(attr))
850 return true;
851
852 if (as->rank
853 && !gfc_add_dimension (&sym->attr, sym->name, error_loc))
854 return false;
855
856 if (as->corank
857 && !gfc_add_codimension (&sym->attr, sym->name, error_loc))
858 return false;
859
860 if (sym->as == NULL)
861 {
862 sym->as = as;
863 return true;
864 }
865
866 if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
867 || (as->type == AS_ASSUMED_RANK && sym->as->corank))
868 {
869 gfc_error ("The assumed-rank array %qs at %L shall not have a "
870 "codimension", sym->name, error_loc);
871 return false;
872 }
873
874 /* Check F2018:C822. */
875 if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
876 goto too_many;
877
878 if (as->corank)
879 {
880 sym->as->cotype = as->cotype;
881 sym->as->corank = as->corank;
882 /* Check F2018:C822. */
883 if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
884 goto too_many;
885
886 for (i = 0; i < as->corank; i++)
887 {
888 sym->as->lower[sym->as->rank + i] = as->lower[i];
889 sym->as->upper[sym->as->rank + i] = as->upper[i];
890 }
891 }
892 else
893 {
894 /* The "sym" has no rank (checked via gfc_add_dimension). Thus
895 the dimension is added - but first the codimensions (if existing
896 need to be shifted to make space for the dimension. */
897 gcc_assert (as->corank == 0 && sym->as->rank == 0);
898
899 sym->as->rank = as->rank;
900 sym->as->type = as->type;
901 sym->as->cray_pointee = as->cray_pointee;
902 sym->as->cp_was_assumed = as->cp_was_assumed;
903
904 /* Check F2018:C822. */
905 if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
906 goto too_many;
907
908 for (i = sym->as->corank - 1; i >= 0; i--)
909 {
910 sym->as->lower[as->rank + i] = sym->as->lower[i];
911 sym->as->upper[as->rank + i] = sym->as->upper[i];
912 }
913 for (i = 0; i < as->rank; i++)
914 {
915 sym->as->lower[i] = as->lower[i];
916 sym->as->upper[i] = as->upper[i];
917 }
918 }
919
920 free (as);
921 return true;
922
923 too_many:
924
925 gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name,
926 GFC_MAX_DIMENSIONS);
927 return false;
928 }
929
930
931 /* Copy an array specification. */
932
933 gfc_array_spec *
gfc_copy_array_spec(gfc_array_spec * src)934 gfc_copy_array_spec (gfc_array_spec *src)
935 {
936 gfc_array_spec *dest;
937 int i;
938
939 if (src == NULL)
940 return NULL;
941
942 dest = gfc_get_array_spec ();
943
944 *dest = *src;
945
946 for (i = 0; i < dest->rank + dest->corank; i++)
947 {
948 dest->lower[i] = gfc_copy_expr (dest->lower[i]);
949 dest->upper[i] = gfc_copy_expr (dest->upper[i]);
950 }
951
952 return dest;
953 }
954
955
956 /* Returns nonzero if the two expressions are equal.
957 We should not need to support more than constant values, as that’s what is
958 allowed in derived type component array spec. However, we may create types
959 with non-constant array spec for dummy variable class container types, for
960 which the _data component holds the array spec of the variable declaration.
961 So we have to support non-constant bounds as well. */
962
963 static bool
compare_bounds(gfc_expr * bound1,gfc_expr * bound2)964 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
965 {
966 if (bound1 == NULL || bound2 == NULL
967 || bound1->ts.type != BT_INTEGER
968 || bound2->ts.type != BT_INTEGER)
969 gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
970
971 /* What qualifies as identical bounds? We could probably just check that the
972 expressions are exact clones. We avoid rewriting a specific comparison
973 function and re-use instead the rather involved gfc_dep_compare_expr which
974 is just a bit more permissive, as it can also detect identical values for
975 some mismatching expressions (extra parenthesis, swapped operands, unary
976 plus, etc). It probably only makes a difference in corner cases. */
977 return gfc_dep_compare_expr (bound1, bound2) == 0;
978 }
979
980
981 /* Compares two array specifications. They must be constant or deferred
982 shape. */
983
984 int
gfc_compare_array_spec(gfc_array_spec * as1,gfc_array_spec * as2)985 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
986 {
987 int i;
988
989 if (as1 == NULL && as2 == NULL)
990 return 1;
991
992 if (as1 == NULL || as2 == NULL)
993 return 0;
994
995 if (as1->rank != as2->rank)
996 return 0;
997
998 if (as1->corank != as2->corank)
999 return 0;
1000
1001 if (as1->rank == 0)
1002 return 1;
1003
1004 if (as1->type != as2->type)
1005 return 0;
1006
1007 if (as1->type == AS_EXPLICIT)
1008 for (i = 0; i < as1->rank + as1->corank; i++)
1009 {
1010 if (!compare_bounds (as1->lower[i], as2->lower[i]))
1011 return 0;
1012
1013 if (!compare_bounds (as1->upper[i], as2->upper[i]))
1014 return 0;
1015 }
1016
1017 return 1;
1018 }
1019
1020
1021 /****************** Array constructor functions ******************/
1022
1023
1024 /* Given an expression node that might be an array constructor and a
1025 symbol, make sure that no iterators in this or child constructors
1026 use the symbol as an implied-DO iterator. Returns nonzero if a
1027 duplicate was found. */
1028
1029 static int
check_duplicate_iterator(gfc_constructor_base base,gfc_symbol * master)1030 check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
1031 {
1032 gfc_constructor *c;
1033 gfc_expr *e;
1034
1035 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1036 {
1037 e = c->expr;
1038
1039 if (e->expr_type == EXPR_ARRAY
1040 && check_duplicate_iterator (e->value.constructor, master))
1041 return 1;
1042
1043 if (c->iterator == NULL)
1044 continue;
1045
1046 if (c->iterator->var->symtree->n.sym == master)
1047 {
1048 gfc_error ("DO-iterator %qs at %L is inside iterator of the "
1049 "same name", master->name, &c->where);
1050
1051 return 1;
1052 }
1053 }
1054
1055 return 0;
1056 }
1057
1058
1059 /* Forward declaration because these functions are mutually recursive. */
1060 static match match_array_cons_element (gfc_constructor_base *);
1061
1062 /* Match a list of array elements. */
1063
1064 static match
match_array_list(gfc_constructor_base * result)1065 match_array_list (gfc_constructor_base *result)
1066 {
1067 gfc_constructor_base head;
1068 gfc_constructor *p;
1069 gfc_iterator iter;
1070 locus old_loc;
1071 gfc_expr *e;
1072 match m;
1073 int n;
1074
1075 old_loc = gfc_current_locus;
1076
1077 if (gfc_match_char ('(') == MATCH_NO)
1078 return MATCH_NO;
1079
1080 memset (&iter, '\0', sizeof (gfc_iterator));
1081 head = NULL;
1082
1083 m = match_array_cons_element (&head);
1084 if (m != MATCH_YES)
1085 goto cleanup;
1086
1087 if (gfc_match_char (',') != MATCH_YES)
1088 {
1089 m = MATCH_NO;
1090 goto cleanup;
1091 }
1092
1093 for (n = 1;; n++)
1094 {
1095 m = gfc_match_iterator (&iter, 0);
1096 if (m == MATCH_YES)
1097 break;
1098 if (m == MATCH_ERROR)
1099 goto cleanup;
1100
1101 m = match_array_cons_element (&head);
1102 if (m == MATCH_ERROR)
1103 goto cleanup;
1104 if (m == MATCH_NO)
1105 {
1106 if (n > 2)
1107 goto syntax;
1108 m = MATCH_NO;
1109 goto cleanup; /* Could be a complex constant */
1110 }
1111
1112 if (gfc_match_char (',') != MATCH_YES)
1113 {
1114 if (n > 2)
1115 goto syntax;
1116 m = MATCH_NO;
1117 goto cleanup;
1118 }
1119 }
1120
1121 if (gfc_match_char (')') != MATCH_YES)
1122 goto syntax;
1123
1124 if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
1125 {
1126 m = MATCH_ERROR;
1127 goto cleanup;
1128 }
1129
1130 e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
1131 e->value.constructor = head;
1132
1133 p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
1134 p->iterator = gfc_get_iterator ();
1135 *p->iterator = iter;
1136
1137 return MATCH_YES;
1138
1139 syntax:
1140 gfc_error ("Syntax error in array constructor at %C");
1141 m = MATCH_ERROR;
1142
1143 cleanup:
1144 gfc_constructor_free (head);
1145 gfc_free_iterator (&iter, 0);
1146 gfc_current_locus = old_loc;
1147 return m;
1148 }
1149
1150
1151 /* Match a single element of an array constructor, which can be a
1152 single expression or a list of elements. */
1153
1154 static match
match_array_cons_element(gfc_constructor_base * result)1155 match_array_cons_element (gfc_constructor_base *result)
1156 {
1157 gfc_expr *expr;
1158 match m;
1159
1160 m = match_array_list (result);
1161 if (m != MATCH_NO)
1162 return m;
1163
1164 m = gfc_match_expr (&expr);
1165 if (m != MATCH_YES)
1166 return m;
1167
1168 if (expr->ts.type == BT_BOZ)
1169 {
1170 gfc_error ("BOZ literal constant at %L cannot appear in an "
1171 "array constructor", &expr->where);
1172 goto done;
1173 }
1174
1175 if (expr->expr_type == EXPR_FUNCTION
1176 && expr->ts.type == BT_UNKNOWN
1177 && strcmp(expr->symtree->name, "null") == 0)
1178 {
1179 gfc_error ("NULL() at %C cannot appear in an array constructor");
1180 goto done;
1181 }
1182
1183 gfc_constructor_append_expr (result, expr, &gfc_current_locus);
1184 return MATCH_YES;
1185
1186 done:
1187 gfc_free_expr (expr);
1188 return MATCH_ERROR;
1189 }
1190
1191
1192 /* Convert components of an array constructor to the type in ts. */
1193
1194 static match
walk_array_constructor(gfc_typespec * ts,gfc_constructor_base head)1195 walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head)
1196 {
1197 gfc_constructor *c;
1198 gfc_expr *e;
1199 match m;
1200
1201 for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
1202 {
1203 e = c->expr;
1204 if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_UNKNOWN
1205 && !e->ref && e->value.constructor)
1206 {
1207 m = walk_array_constructor (ts, e->value.constructor);
1208 if (m == MATCH_ERROR)
1209 return m;
1210 }
1211 else if (!gfc_convert_type_warn (e, ts, 1, 1, true)
1212 && e->ts.type != BT_UNKNOWN)
1213 return MATCH_ERROR;
1214 }
1215 return MATCH_YES;
1216 }
1217
1218 /* Match an array constructor. */
1219
1220 match
gfc_match_array_constructor(gfc_expr ** result)1221 gfc_match_array_constructor (gfc_expr **result)
1222 {
1223 gfc_constructor *c;
1224 gfc_constructor_base head;
1225 gfc_expr *expr;
1226 gfc_typespec ts;
1227 locus where;
1228 match m;
1229 const char *end_delim;
1230 bool seen_ts;
1231
1232 head = NULL;
1233 seen_ts = false;
1234
1235 if (gfc_match (" (/") == MATCH_NO)
1236 {
1237 if (gfc_match (" [") == MATCH_NO)
1238 return MATCH_NO;
1239 else
1240 {
1241 if (!gfc_notify_std (GFC_STD_F2003, "[...] "
1242 "style array constructors at %C"))
1243 return MATCH_ERROR;
1244 end_delim = " ]";
1245 }
1246 }
1247 else
1248 end_delim = " /)";
1249
1250 where = gfc_current_locus;
1251
1252 /* Try to match an optional "type-spec ::" */
1253 gfc_clear_ts (&ts);
1254 m = gfc_match_type_spec (&ts);
1255 if (m == MATCH_YES)
1256 {
1257 seen_ts = (gfc_match (" ::") == MATCH_YES);
1258
1259 if (seen_ts)
1260 {
1261 if (!gfc_notify_std (GFC_STD_F2003, "Array constructor "
1262 "including type specification at %C"))
1263 goto cleanup;
1264
1265 if (ts.deferred)
1266 {
1267 gfc_error ("Type-spec at %L cannot contain a deferred "
1268 "type parameter", &where);
1269 goto cleanup;
1270 }
1271
1272 if (ts.type == BT_CHARACTER
1273 && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec)
1274 {
1275 gfc_error ("Type-spec at %L cannot contain an asterisk for a "
1276 "type parameter", &where);
1277 goto cleanup;
1278 }
1279 }
1280 }
1281 else if (m == MATCH_ERROR)
1282 goto cleanup;
1283
1284 if (!seen_ts)
1285 gfc_current_locus = where;
1286
1287 if (gfc_match (end_delim) == MATCH_YES)
1288 {
1289 if (seen_ts)
1290 goto done;
1291 else
1292 {
1293 gfc_error ("Empty array constructor at %C is not allowed");
1294 goto cleanup;
1295 }
1296 }
1297
1298 for (;;)
1299 {
1300 m = match_array_cons_element (&head);
1301 if (m == MATCH_ERROR)
1302 goto cleanup;
1303 if (m == MATCH_NO)
1304 goto syntax;
1305
1306 if (gfc_match_char (',') == MATCH_NO)
1307 break;
1308 }
1309
1310 if (gfc_match (end_delim) == MATCH_NO)
1311 goto syntax;
1312
1313 done:
1314 /* Size must be calculated at resolution time. */
1315 if (seen_ts)
1316 {
1317 expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1318 expr->ts = ts;
1319
1320 /* If the typespec is CHARACTER, check that array elements can
1321 be converted. See PR fortran/67803. */
1322 if (ts.type == BT_CHARACTER)
1323 {
1324 c = gfc_constructor_first (head);
1325 for (; c; c = gfc_constructor_next (c))
1326 {
1327 if (gfc_numeric_ts (&c->expr->ts)
1328 || c->expr->ts.type == BT_LOGICAL)
1329 {
1330 gfc_error ("Incompatible typespec for array element at %L",
1331 &c->expr->where);
1332 return MATCH_ERROR;
1333 }
1334
1335 /* Special case null(). */
1336 if (c->expr->expr_type == EXPR_FUNCTION
1337 && c->expr->ts.type == BT_UNKNOWN
1338 && strcmp (c->expr->symtree->name, "null") == 0)
1339 {
1340 gfc_error ("Incompatible typespec for array element at %L",
1341 &c->expr->where);
1342 return MATCH_ERROR;
1343 }
1344 }
1345 }
1346
1347 /* Walk the constructor, and if possible, do type conversion for
1348 numeric types. */
1349 if (gfc_numeric_ts (&ts))
1350 {
1351 m = walk_array_constructor (&ts, head);
1352 if (m == MATCH_ERROR)
1353 return m;
1354 }
1355 }
1356 else
1357 expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1358
1359 expr->value.constructor = head;
1360 if (expr->ts.u.cl)
1361 expr->ts.u.cl->length_from_typespec = seen_ts;
1362
1363 *result = expr;
1364
1365 return MATCH_YES;
1366
1367 syntax:
1368 gfc_error ("Syntax error in array constructor at %C");
1369
1370 cleanup:
1371 gfc_constructor_free (head);
1372 return MATCH_ERROR;
1373 }
1374
1375
1376
1377 /************** Check array constructors for correctness **************/
1378
1379 /* Given an expression, compare it's type with the type of the current
1380 constructor. Returns nonzero if an error was issued. The
1381 cons_state variable keeps track of whether the type of the
1382 constructor being read or resolved is known to be good, bad or just
1383 starting out. */
1384
1385 static gfc_typespec constructor_ts;
1386 static enum
1387 { CONS_START, CONS_GOOD, CONS_BAD }
1388 cons_state;
1389
1390 static int
check_element_type(gfc_expr * expr,bool convert)1391 check_element_type (gfc_expr *expr, bool convert)
1392 {
1393 if (cons_state == CONS_BAD)
1394 return 0; /* Suppress further errors */
1395
1396 if (cons_state == CONS_START)
1397 {
1398 if (expr->ts.type == BT_UNKNOWN)
1399 cons_state = CONS_BAD;
1400 else
1401 {
1402 cons_state = CONS_GOOD;
1403 constructor_ts = expr->ts;
1404 }
1405
1406 return 0;
1407 }
1408
1409 if (gfc_compare_types (&constructor_ts, &expr->ts))
1410 return 0;
1411
1412 if (convert)
1413 return gfc_convert_type_warn (expr, &constructor_ts, 1, 1, true) ? 0 : 1;
1414
1415 gfc_error ("Element in %s array constructor at %L is %s",
1416 gfc_typename (&constructor_ts), &expr->where,
1417 gfc_typename (expr));
1418
1419 cons_state = CONS_BAD;
1420 return 1;
1421 }
1422
1423
1424 /* Recursive work function for gfc_check_constructor_type(). */
1425
1426 static bool
check_constructor_type(gfc_constructor_base base,bool convert)1427 check_constructor_type (gfc_constructor_base base, bool convert)
1428 {
1429 gfc_constructor *c;
1430 gfc_expr *e;
1431
1432 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1433 {
1434 e = c->expr;
1435
1436 if (e->expr_type == EXPR_ARRAY)
1437 {
1438 if (!check_constructor_type (e->value.constructor, convert))
1439 return false;
1440
1441 continue;
1442 }
1443
1444 if (check_element_type (e, convert))
1445 return false;
1446 }
1447
1448 return true;
1449 }
1450
1451
1452 /* Check that all elements of an array constructor are the same type.
1453 On false, an error has been generated. */
1454
1455 bool
gfc_check_constructor_type(gfc_expr * e)1456 gfc_check_constructor_type (gfc_expr *e)
1457 {
1458 bool t;
1459
1460 if (e->ts.type != BT_UNKNOWN)
1461 {
1462 cons_state = CONS_GOOD;
1463 constructor_ts = e->ts;
1464 }
1465 else
1466 {
1467 cons_state = CONS_START;
1468 gfc_clear_ts (&constructor_ts);
1469 }
1470
1471 /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1472 typespec, and we will now convert the values on the fly. */
1473 t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1474 if (t && e->ts.type == BT_UNKNOWN)
1475 e->ts = constructor_ts;
1476
1477 return t;
1478 }
1479
1480
1481
1482 typedef struct cons_stack
1483 {
1484 gfc_iterator *iterator;
1485 struct cons_stack *previous;
1486 }
1487 cons_stack;
1488
1489 static cons_stack *base;
1490
1491 static bool check_constructor (gfc_constructor_base, bool (*) (gfc_expr *));
1492
1493 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1494 that that variable is an iteration variable. */
1495
1496 bool
gfc_check_iter_variable(gfc_expr * expr)1497 gfc_check_iter_variable (gfc_expr *expr)
1498 {
1499 gfc_symbol *sym;
1500 cons_stack *c;
1501
1502 sym = expr->symtree->n.sym;
1503
1504 for (c = base; c && c->iterator; c = c->previous)
1505 if (sym == c->iterator->var->symtree->n.sym)
1506 return true;
1507
1508 return false;
1509 }
1510
1511
1512 /* Recursive work function for gfc_check_constructor(). This amounts
1513 to calling the check function for each expression in the
1514 constructor, giving variables with the names of iterators a pass. */
1515
1516 static bool
check_constructor(gfc_constructor_base ctor,bool (* check_function)(gfc_expr *))1517 check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *))
1518 {
1519 cons_stack element;
1520 gfc_expr *e;
1521 bool t;
1522 gfc_constructor *c;
1523
1524 for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1525 {
1526 e = c->expr;
1527
1528 if (!e)
1529 continue;
1530
1531 if (e->expr_type != EXPR_ARRAY)
1532 {
1533 if (!(*check_function)(e))
1534 return false;
1535 continue;
1536 }
1537
1538 element.previous = base;
1539 element.iterator = c->iterator;
1540
1541 base = &element;
1542 t = check_constructor (e->value.constructor, check_function);
1543 base = element.previous;
1544
1545 if (!t)
1546 return false;
1547 }
1548
1549 /* Nothing went wrong, so all OK. */
1550 return true;
1551 }
1552
1553
1554 /* Checks a constructor to see if it is a particular kind of
1555 expression -- specification, restricted, or initialization as
1556 determined by the check_function. */
1557
1558 bool
gfc_check_constructor(gfc_expr * expr,bool (* check_function)(gfc_expr *))1559 gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *))
1560 {
1561 cons_stack *base_save;
1562 bool t;
1563
1564 base_save = base;
1565 base = NULL;
1566
1567 t = check_constructor (expr->value.constructor, check_function);
1568 base = base_save;
1569
1570 return t;
1571 }
1572
1573
1574
1575 /**************** Simplification of array constructors ****************/
1576
1577 iterator_stack *iter_stack;
1578
1579 typedef struct
1580 {
1581 gfc_constructor_base base;
1582 int extract_count, extract_n;
1583 gfc_expr *extracted;
1584 mpz_t *count;
1585
1586 mpz_t *offset;
1587 gfc_component *component;
1588 mpz_t *repeat;
1589
1590 bool (*expand_work_function) (gfc_expr *);
1591 }
1592 expand_info;
1593
1594 static expand_info current_expand;
1595
1596 static bool expand_constructor (gfc_constructor_base);
1597
1598
1599 /* Work function that counts the number of elements present in a
1600 constructor. */
1601
1602 static bool
count_elements(gfc_expr * e)1603 count_elements (gfc_expr *e)
1604 {
1605 mpz_t result;
1606
1607 if (e->rank == 0)
1608 mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1609 else
1610 {
1611 if (!gfc_array_size (e, &result))
1612 {
1613 gfc_free_expr (e);
1614 return false;
1615 }
1616
1617 mpz_add (*current_expand.count, *current_expand.count, result);
1618 mpz_clear (result);
1619 }
1620
1621 gfc_free_expr (e);
1622 return true;
1623 }
1624
1625
1626 /* Work function that extracts a particular element from an array
1627 constructor, freeing the rest. */
1628
1629 static bool
extract_element(gfc_expr * e)1630 extract_element (gfc_expr *e)
1631 {
1632 if (e->rank != 0)
1633 { /* Something unextractable */
1634 gfc_free_expr (e);
1635 return false;
1636 }
1637
1638 if (current_expand.extract_count == current_expand.extract_n)
1639 current_expand.extracted = e;
1640 else
1641 gfc_free_expr (e);
1642
1643 current_expand.extract_count++;
1644
1645 return true;
1646 }
1647
1648
1649 /* Work function that constructs a new constructor out of the old one,
1650 stringing new elements together. */
1651
1652 static bool
expand(gfc_expr * e)1653 expand (gfc_expr *e)
1654 {
1655 gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
1656 e, &e->where);
1657
1658 c->n.component = current_expand.component;
1659 return true;
1660 }
1661
1662
1663 /* Given an initialization expression that is a variable reference,
1664 substitute the current value of the iteration variable. */
1665
1666 void
gfc_simplify_iterator_var(gfc_expr * e)1667 gfc_simplify_iterator_var (gfc_expr *e)
1668 {
1669 iterator_stack *p;
1670
1671 for (p = iter_stack; p; p = p->prev)
1672 if (e->symtree == p->variable)
1673 break;
1674
1675 if (p == NULL)
1676 return; /* Variable not found */
1677
1678 gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1679
1680 mpz_set (e->value.integer, p->value);
1681
1682 return;
1683 }
1684
1685
1686 /* Expand an expression with that is inside of a constructor,
1687 recursing into other constructors if present. */
1688
1689 static bool
expand_expr(gfc_expr * e)1690 expand_expr (gfc_expr *e)
1691 {
1692 if (e->expr_type == EXPR_ARRAY)
1693 return expand_constructor (e->value.constructor);
1694
1695 e = gfc_copy_expr (e);
1696
1697 if (!gfc_simplify_expr (e, 1))
1698 {
1699 gfc_free_expr (e);
1700 return false;
1701 }
1702
1703 return current_expand.expand_work_function (e);
1704 }
1705
1706
1707 static bool
expand_iterator(gfc_constructor * c)1708 expand_iterator (gfc_constructor *c)
1709 {
1710 gfc_expr *start, *end, *step;
1711 iterator_stack frame;
1712 mpz_t trip;
1713 bool t;
1714
1715 end = step = NULL;
1716
1717 t = false;
1718
1719 mpz_init (trip);
1720 mpz_init (frame.value);
1721 frame.prev = NULL;
1722
1723 start = gfc_copy_expr (c->iterator->start);
1724 if (!gfc_simplify_expr (start, 1))
1725 goto cleanup;
1726
1727 if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1728 goto cleanup;
1729
1730 end = gfc_copy_expr (c->iterator->end);
1731 if (!gfc_simplify_expr (end, 1))
1732 goto cleanup;
1733
1734 if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1735 goto cleanup;
1736
1737 step = gfc_copy_expr (c->iterator->step);
1738 if (!gfc_simplify_expr (step, 1))
1739 goto cleanup;
1740
1741 if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1742 goto cleanup;
1743
1744 if (mpz_sgn (step->value.integer) == 0)
1745 {
1746 gfc_error ("Iterator step at %L cannot be zero", &step->where);
1747 goto cleanup;
1748 }
1749
1750 /* Calculate the trip count of the loop. */
1751 mpz_sub (trip, end->value.integer, start->value.integer);
1752 mpz_add (trip, trip, step->value.integer);
1753 mpz_tdiv_q (trip, trip, step->value.integer);
1754
1755 mpz_set (frame.value, start->value.integer);
1756
1757 frame.prev = iter_stack;
1758 frame.variable = c->iterator->var->symtree;
1759 iter_stack = &frame;
1760
1761 while (mpz_sgn (trip) > 0)
1762 {
1763 if (!expand_expr (c->expr))
1764 goto cleanup;
1765
1766 mpz_add (frame.value, frame.value, step->value.integer);
1767 mpz_sub_ui (trip, trip, 1);
1768 }
1769
1770 t = true;
1771
1772 cleanup:
1773 gfc_free_expr (start);
1774 gfc_free_expr (end);
1775 gfc_free_expr (step);
1776
1777 mpz_clear (trip);
1778 mpz_clear (frame.value);
1779
1780 iter_stack = frame.prev;
1781
1782 return t;
1783 }
1784
1785 /* Variables for noticing if all constructors are empty, and
1786 if any of them had a type. */
1787
1788 static bool empty_constructor;
1789 static gfc_typespec empty_ts;
1790
1791 /* Expand a constructor into constant constructors without any
1792 iterators, calling the work function for each of the expanded
1793 expressions. The work function needs to either save or free the
1794 passed expression. */
1795
1796 static bool
expand_constructor(gfc_constructor_base base)1797 expand_constructor (gfc_constructor_base base)
1798 {
1799 gfc_constructor *c;
1800 gfc_expr *e;
1801
1802 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1803 {
1804 if (c->iterator != NULL)
1805 {
1806 if (!expand_iterator (c))
1807 return false;
1808 continue;
1809 }
1810
1811 e = c->expr;
1812
1813 if (e == NULL)
1814 return false;
1815
1816 if (empty_constructor)
1817 empty_ts = e->ts;
1818
1819 /* Simplify constant array expression/section within constructor. */
1820 if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref
1821 && e->symtree && e->symtree->n.sym
1822 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1823 gfc_simplify_expr (e, 0);
1824
1825 if (e->expr_type == EXPR_ARRAY)
1826 {
1827 if (!expand_constructor (e->value.constructor))
1828 return false;
1829
1830 continue;
1831 }
1832
1833 empty_constructor = false;
1834 e = gfc_copy_expr (e);
1835 if (!gfc_simplify_expr (e, 1))
1836 {
1837 gfc_free_expr (e);
1838 return false;
1839 }
1840 e->from_constructor = 1;
1841 current_expand.offset = &c->offset;
1842 current_expand.repeat = &c->repeat;
1843 current_expand.component = c->n.component;
1844 if (!current_expand.expand_work_function(e))
1845 return false;
1846 }
1847 return true;
1848 }
1849
1850
1851 /* Given an array expression and an element number (starting at zero),
1852 return a pointer to the array element. NULL is returned if the
1853 size of the array has been exceeded. The expression node returned
1854 remains a part of the array and should not be freed. Access is not
1855 efficient at all, but this is another place where things do not
1856 have to be particularly fast. */
1857
1858 static gfc_expr *
gfc_get_array_element(gfc_expr * array,int element)1859 gfc_get_array_element (gfc_expr *array, int element)
1860 {
1861 expand_info expand_save;
1862 gfc_expr *e;
1863 bool rc;
1864
1865 expand_save = current_expand;
1866 current_expand.extract_n = element;
1867 current_expand.expand_work_function = extract_element;
1868 current_expand.extracted = NULL;
1869 current_expand.extract_count = 0;
1870
1871 iter_stack = NULL;
1872
1873 rc = expand_constructor (array->value.constructor);
1874 e = current_expand.extracted;
1875 current_expand = expand_save;
1876
1877 if (!rc)
1878 return NULL;
1879
1880 return e;
1881 }
1882
1883
1884 /* Top level subroutine for expanding constructors. We only expand
1885 constructor if they are small enough. */
1886
1887 bool
gfc_expand_constructor(gfc_expr * e,bool fatal)1888 gfc_expand_constructor (gfc_expr *e, bool fatal)
1889 {
1890 expand_info expand_save;
1891 gfc_expr *f;
1892 bool rc;
1893
1894 if (gfc_is_size_zero_array (e))
1895 return true;
1896
1897 /* If we can successfully get an array element at the max array size then
1898 the array is too big to expand, so we just return. */
1899 f = gfc_get_array_element (e, flag_max_array_constructor);
1900 if (f != NULL)
1901 {
1902 gfc_free_expr (f);
1903 if (fatal)
1904 {
1905 gfc_error ("The number of elements in the array constructor "
1906 "at %L requires an increase of the allowed %d "
1907 "upper limit. See %<-fmax-array-constructor%> "
1908 "option", &e->where, flag_max_array_constructor);
1909 return false;
1910 }
1911 return true;
1912 }
1913
1914 /* We now know the array is not too big so go ahead and try to expand it. */
1915 expand_save = current_expand;
1916 current_expand.base = NULL;
1917
1918 iter_stack = NULL;
1919
1920 empty_constructor = true;
1921 gfc_clear_ts (&empty_ts);
1922 current_expand.expand_work_function = expand;
1923
1924 if (!expand_constructor (e->value.constructor))
1925 {
1926 gfc_constructor_free (current_expand.base);
1927 rc = false;
1928 goto done;
1929 }
1930
1931 /* If we don't have an explicit constructor type, and there
1932 were only empty constructors, then take the type from
1933 them. */
1934
1935 if (constructor_ts.type == BT_UNKNOWN && empty_constructor)
1936 e->ts = empty_ts;
1937
1938 gfc_constructor_free (e->value.constructor);
1939 e->value.constructor = current_expand.base;
1940
1941 rc = true;
1942
1943 done:
1944 current_expand = expand_save;
1945
1946 return rc;
1947 }
1948
1949
1950 /* Work function for checking that an element of a constructor is a
1951 constant, after removal of any iteration variables. We return
1952 false if not so. */
1953
1954 static bool
is_constant_element(gfc_expr * e)1955 is_constant_element (gfc_expr *e)
1956 {
1957 int rv;
1958
1959 rv = gfc_is_constant_expr (e);
1960 gfc_free_expr (e);
1961
1962 return rv ? true : false;
1963 }
1964
1965
1966 /* Given an array constructor, determine if the constructor is
1967 constant or not by expanding it and making sure that all elements
1968 are constants. This is a bit of a hack since something like (/ (i,
1969 i=1,100000000) /) will take a while as* opposed to a more clever
1970 function that traverses the expression tree. FIXME. */
1971
1972 int
gfc_constant_ac(gfc_expr * e)1973 gfc_constant_ac (gfc_expr *e)
1974 {
1975 expand_info expand_save;
1976 bool rc;
1977
1978 iter_stack = NULL;
1979 expand_save = current_expand;
1980 current_expand.expand_work_function = is_constant_element;
1981
1982 rc = expand_constructor (e->value.constructor);
1983
1984 current_expand = expand_save;
1985 if (!rc)
1986 return 0;
1987
1988 return 1;
1989 }
1990
1991
1992 /* Returns nonzero if an array constructor has been completely
1993 expanded (no iterators) and zero if iterators are present. */
1994
1995 int
gfc_expanded_ac(gfc_expr * e)1996 gfc_expanded_ac (gfc_expr *e)
1997 {
1998 gfc_constructor *c;
1999
2000 if (e->expr_type == EXPR_ARRAY)
2001 for (c = gfc_constructor_first (e->value.constructor);
2002 c; c = gfc_constructor_next (c))
2003 if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
2004 return 0;
2005
2006 return 1;
2007 }
2008
2009
2010 /*************** Type resolution of array constructors ***************/
2011
2012
2013 /* The symbol expr_is_sought_symbol_ref will try to find. */
2014 static const gfc_symbol *sought_symbol = NULL;
2015
2016
2017 /* Tells whether the expression E is a variable reference to the symbol
2018 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
2019 accordingly.
2020 To be used with gfc_expr_walker: if a reference is found we don't need
2021 to look further so we return 1 to skip any further walk. */
2022
2023 static int
expr_is_sought_symbol_ref(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * where)2024 expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2025 void *where)
2026 {
2027 gfc_expr *expr = *e;
2028 locus *sym_loc = (locus *)where;
2029
2030 if (expr->expr_type == EXPR_VARIABLE
2031 && expr->symtree->n.sym == sought_symbol)
2032 {
2033 *sym_loc = expr->where;
2034 return 1;
2035 }
2036
2037 return 0;
2038 }
2039
2040
2041 /* Tells whether the expression EXPR contains a reference to the symbol
2042 SYM and in that case sets the position SYM_LOC where the reference is. */
2043
2044 static bool
find_symbol_in_expr(gfc_symbol * sym,gfc_expr * expr,locus * sym_loc)2045 find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc)
2046 {
2047 int ret;
2048
2049 sought_symbol = sym;
2050 ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc);
2051 sought_symbol = NULL;
2052 return ret;
2053 }
2054
2055
2056 /* Recursive array list resolution function. All of the elements must
2057 be of the same type. */
2058
2059 static bool
resolve_array_list(gfc_constructor_base base)2060 resolve_array_list (gfc_constructor_base base)
2061 {
2062 bool t;
2063 gfc_constructor *c;
2064 gfc_iterator *iter;
2065
2066 t = true;
2067
2068 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2069 {
2070 iter = c->iterator;
2071 if (iter != NULL)
2072 {
2073 gfc_symbol *iter_var;
2074 locus iter_var_loc;
2075
2076 if (!gfc_resolve_iterator (iter, false, true))
2077 t = false;
2078
2079 /* Check for bounds referencing the iterator variable. */
2080 gcc_assert (iter->var->expr_type == EXPR_VARIABLE);
2081 iter_var = iter->var->symtree->n.sym;
2082 if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc))
2083 {
2084 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial "
2085 "expression references control variable "
2086 "at %L", &iter_var_loc))
2087 t = false;
2088 }
2089 if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc))
2090 {
2091 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final "
2092 "expression references control variable "
2093 "at %L", &iter_var_loc))
2094 t = false;
2095 }
2096 if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc))
2097 {
2098 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step "
2099 "expression references control variable "
2100 "at %L", &iter_var_loc))
2101 t = false;
2102 }
2103 }
2104
2105 if (!gfc_resolve_expr (c->expr))
2106 t = false;
2107
2108 if (UNLIMITED_POLY (c->expr))
2109 {
2110 gfc_error ("Array constructor value at %L shall not be unlimited "
2111 "polymorphic [F2008: C4106]", &c->expr->where);
2112 t = false;
2113 }
2114 }
2115
2116 return t;
2117 }
2118
2119 /* Resolve character array constructor. If it has a specified constant character
2120 length, pad/truncate the elements here; if the length is not specified and
2121 all elements are of compile-time known length, emit an error as this is
2122 invalid. */
2123
2124 bool
gfc_resolve_character_array_constructor(gfc_expr * expr)2125 gfc_resolve_character_array_constructor (gfc_expr *expr)
2126 {
2127 gfc_constructor *p;
2128 HOST_WIDE_INT found_length;
2129
2130 gcc_assert (expr->expr_type == EXPR_ARRAY);
2131 gcc_assert (expr->ts.type == BT_CHARACTER);
2132
2133 if (expr->ts.u.cl == NULL)
2134 {
2135 for (p = gfc_constructor_first (expr->value.constructor);
2136 p; p = gfc_constructor_next (p))
2137 if (p->expr->ts.u.cl != NULL)
2138 {
2139 /* Ensure that if there is a char_len around that it is
2140 used; otherwise the middle-end confuses them! */
2141 expr->ts.u.cl = p->expr->ts.u.cl;
2142 goto got_charlen;
2143 }
2144
2145 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2146 }
2147
2148 got_charlen:
2149
2150 /* Early exit for zero size arrays. */
2151 if (expr->shape)
2152 {
2153 mpz_t size;
2154 HOST_WIDE_INT arraysize;
2155
2156 gfc_array_size (expr, &size);
2157 arraysize = mpz_get_ui (size);
2158 mpz_clear (size);
2159
2160 if (arraysize == 0)
2161 return true;
2162 }
2163
2164 found_length = -1;
2165
2166 if (expr->ts.u.cl->length == NULL)
2167 {
2168 /* Check that all constant string elements have the same length until
2169 we reach the end or find a variable-length one. */
2170
2171 for (p = gfc_constructor_first (expr->value.constructor);
2172 p; p = gfc_constructor_next (p))
2173 {
2174 HOST_WIDE_INT current_length = -1;
2175 gfc_ref *ref;
2176 for (ref = p->expr->ref; ref; ref = ref->next)
2177 if (ref->type == REF_SUBSTRING
2178 && ref->u.ss.start
2179 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2180 && ref->u.ss.end
2181 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2182 break;
2183
2184 if (p->expr->expr_type == EXPR_CONSTANT)
2185 current_length = p->expr->value.character.length;
2186 else if (ref)
2187 current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer)
2188 - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1;
2189 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
2190 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2191 current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer);
2192 else
2193 return true;
2194
2195 if (current_length < 0)
2196 current_length = 0;
2197
2198 if (found_length == -1)
2199 found_length = current_length;
2200 else if (found_length != current_length)
2201 {
2202 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2203 " constructor at %L", (long) found_length,
2204 (long) current_length, &p->expr->where);
2205 return false;
2206 }
2207
2208 gcc_assert (found_length == current_length);
2209 }
2210
2211 gcc_assert (found_length != -1);
2212
2213 /* Update the character length of the array constructor. */
2214 expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2215 NULL, found_length);
2216 }
2217 else
2218 {
2219 /* We've got a character length specified. It should be an integer,
2220 otherwise an error is signalled elsewhere. */
2221 gcc_assert (expr->ts.u.cl->length);
2222
2223 /* If we've got a constant character length, pad according to this.
2224 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2225 max_length only if they pass. */
2226 gfc_extract_hwi (expr->ts.u.cl->length, &found_length);
2227
2228 /* Now pad/truncate the elements accordingly to the specified character
2229 length. This is ok inside this conditional, as in the case above
2230 (without typespec) all elements are verified to have the same length
2231 anyway. */
2232 if (found_length != -1)
2233 for (p = gfc_constructor_first (expr->value.constructor);
2234 p; p = gfc_constructor_next (p))
2235 if (p->expr->expr_type == EXPR_CONSTANT)
2236 {
2237 gfc_expr *cl = NULL;
2238 HOST_WIDE_INT current_length = -1;
2239 bool has_ts;
2240
2241 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
2242 {
2243 cl = p->expr->ts.u.cl->length;
2244 gfc_extract_hwi (cl, ¤t_length);
2245 }
2246
2247 /* If gfc_extract_int above set current_length, we implicitly
2248 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2249
2250 has_ts = expr->ts.u.cl->length_from_typespec;
2251
2252 if (! cl
2253 || (current_length != -1 && current_length != found_length))
2254 gfc_set_constant_character_len (found_length, p->expr,
2255 has_ts ? -1 : found_length);
2256 }
2257 }
2258
2259 return true;
2260 }
2261
2262
2263 /* Resolve all of the expressions in an array list. */
2264
2265 bool
gfc_resolve_array_constructor(gfc_expr * expr)2266 gfc_resolve_array_constructor (gfc_expr *expr)
2267 {
2268 bool t;
2269
2270 t = resolve_array_list (expr->value.constructor);
2271 if (t)
2272 t = gfc_check_constructor_type (expr);
2273
2274 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2275 the call to this function, so we don't need to call it here; if it was
2276 called twice, an error message there would be duplicated. */
2277
2278 return t;
2279 }
2280
2281
2282 /* Copy an iterator structure. */
2283
2284 gfc_iterator *
gfc_copy_iterator(gfc_iterator * src)2285 gfc_copy_iterator (gfc_iterator *src)
2286 {
2287 gfc_iterator *dest;
2288
2289 if (src == NULL)
2290 return NULL;
2291
2292 dest = gfc_get_iterator ();
2293
2294 dest->var = gfc_copy_expr (src->var);
2295 dest->start = gfc_copy_expr (src->start);
2296 dest->end = gfc_copy_expr (src->end);
2297 dest->step = gfc_copy_expr (src->step);
2298 dest->unroll = src->unroll;
2299 dest->ivdep = src->ivdep;
2300 dest->vector = src->vector;
2301 dest->novector = src->novector;
2302
2303 return dest;
2304 }
2305
2306
2307 /********* Subroutines for determining the size of an array *********/
2308
2309 /* These are needed just to accommodate RESHAPE(). There are no
2310 diagnostics here, we just return false if something goes wrong. */
2311
2312
2313 /* Get the size of single dimension of an array specification. The
2314 array is guaranteed to be one dimensional. */
2315
2316 bool
spec_dimen_size(gfc_array_spec * as,int dimen,mpz_t * result)2317 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2318 {
2319 if (as == NULL)
2320 return false;
2321
2322 if (dimen < 0 || dimen > as->rank - 1)
2323 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2324
2325 if (as->type != AS_EXPLICIT
2326 || !as->lower[dimen]
2327 || !as->upper[dimen])
2328 return false;
2329
2330 if (as->lower[dimen]->expr_type != EXPR_CONSTANT
2331 || as->upper[dimen]->expr_type != EXPR_CONSTANT
2332 || as->lower[dimen]->ts.type != BT_INTEGER
2333 || as->upper[dimen]->ts.type != BT_INTEGER)
2334 return false;
2335
2336 mpz_init (*result);
2337
2338 mpz_sub (*result, as->upper[dimen]->value.integer,
2339 as->lower[dimen]->value.integer);
2340
2341 mpz_add_ui (*result, *result, 1);
2342
2343 if (mpz_cmp_si (*result, 0) < 0)
2344 mpz_set_si (*result, 0);
2345
2346 return true;
2347 }
2348
2349
2350 bool
spec_size(gfc_array_spec * as,mpz_t * result)2351 spec_size (gfc_array_spec *as, mpz_t *result)
2352 {
2353 mpz_t size;
2354 int d;
2355
2356 if (!as || as->type == AS_ASSUMED_RANK)
2357 return false;
2358
2359 mpz_init_set_ui (*result, 1);
2360
2361 for (d = 0; d < as->rank; d++)
2362 {
2363 if (!spec_dimen_size (as, d, &size))
2364 {
2365 mpz_clear (*result);
2366 return false;
2367 }
2368
2369 mpz_mul (*result, *result, size);
2370 mpz_clear (size);
2371 }
2372
2373 return true;
2374 }
2375
2376
2377 /* Get the number of elements in an array section. Optionally, also supply
2378 the end value. */
2379
2380 bool
gfc_ref_dimen_size(gfc_array_ref * ar,int dimen,mpz_t * result,mpz_t * end)2381 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
2382 {
2383 mpz_t upper, lower, stride;
2384 mpz_t diff;
2385 bool t;
2386 gfc_expr *stride_expr = NULL;
2387
2388 if (dimen < 0 || ar == NULL)
2389 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2390
2391 if (dimen > ar->dimen - 1)
2392 {
2393 gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]);
2394 return false;
2395 }
2396
2397 switch (ar->dimen_type[dimen])
2398 {
2399 case DIMEN_ELEMENT:
2400 mpz_init (*result);
2401 mpz_set_ui (*result, 1);
2402 t = true;
2403 break;
2404
2405 case DIMEN_VECTOR:
2406 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2407 break;
2408
2409 case DIMEN_RANGE:
2410
2411 mpz_init (stride);
2412
2413 if (ar->stride[dimen] == NULL)
2414 mpz_set_ui (stride, 1);
2415 else
2416 {
2417 stride_expr = gfc_copy_expr(ar->stride[dimen]);
2418
2419 if (!gfc_simplify_expr (stride_expr, 1)
2420 || stride_expr->expr_type != EXPR_CONSTANT
2421 || mpz_cmp_ui (stride_expr->value.integer, 0) == 0)
2422 {
2423 gfc_free_expr (stride_expr);
2424 mpz_clear (stride);
2425 return false;
2426 }
2427 mpz_set (stride, stride_expr->value.integer);
2428 gfc_free_expr(stride_expr);
2429 }
2430
2431 /* Calculate the number of elements via gfc_dep_difference, but only if
2432 start and end are both supplied in the reference or the array spec.
2433 This is to guard against strange but valid code like
2434
2435 subroutine foo(a,n)
2436 real a(1:n)
2437 n = 3
2438 print *,size(a(n-1:))
2439
2440 where the user changes the value of a variable. If we have to
2441 determine end as well, we cannot do this using gfc_dep_difference.
2442 Fall back to the constants-only code then. */
2443
2444 if (end == NULL)
2445 {
2446 bool use_dep;
2447
2448 use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
2449 &diff);
2450 if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL)
2451 use_dep = gfc_dep_difference (ar->as->upper[dimen],
2452 ar->as->lower[dimen], &diff);
2453
2454 if (use_dep)
2455 {
2456 mpz_init (*result);
2457 mpz_add (*result, diff, stride);
2458 mpz_div (*result, *result, stride);
2459 if (mpz_cmp_ui (*result, 0) < 0)
2460 mpz_set_ui (*result, 0);
2461
2462 mpz_clear (stride);
2463 mpz_clear (diff);
2464 return true;
2465 }
2466
2467 }
2468
2469 /* Constant-only code here, which covers more cases
2470 like a(:4) etc. */
2471 mpz_init (upper);
2472 mpz_init (lower);
2473 t = false;
2474
2475 if (ar->start[dimen] == NULL)
2476 {
2477 if (ar->as->lower[dimen] == NULL
2478 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT
2479 || ar->as->lower[dimen]->ts.type != BT_INTEGER)
2480 goto cleanup;
2481 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2482 }
2483 else
2484 {
2485 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2486 goto cleanup;
2487 mpz_set (lower, ar->start[dimen]->value.integer);
2488 }
2489
2490 if (ar->end[dimen] == NULL)
2491 {
2492 if (ar->as->upper[dimen] == NULL
2493 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT
2494 || ar->as->upper[dimen]->ts.type != BT_INTEGER)
2495 goto cleanup;
2496 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2497 }
2498 else
2499 {
2500 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2501 goto cleanup;
2502 mpz_set (upper, ar->end[dimen]->value.integer);
2503 }
2504
2505 mpz_init (*result);
2506 mpz_sub (*result, upper, lower);
2507 mpz_add (*result, *result, stride);
2508 mpz_div (*result, *result, stride);
2509
2510 /* Zero stride caught earlier. */
2511 if (mpz_cmp_ui (*result, 0) < 0)
2512 mpz_set_ui (*result, 0);
2513 t = true;
2514
2515 if (end)
2516 {
2517 mpz_init (*end);
2518
2519 mpz_sub_ui (*end, *result, 1UL);
2520 mpz_mul (*end, *end, stride);
2521 mpz_add (*end, *end, lower);
2522 }
2523
2524 cleanup:
2525 mpz_clear (upper);
2526 mpz_clear (lower);
2527 mpz_clear (stride);
2528 return t;
2529
2530 default:
2531 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2532 }
2533
2534 return t;
2535 }
2536
2537
2538 static bool
ref_size(gfc_array_ref * ar,mpz_t * result)2539 ref_size (gfc_array_ref *ar, mpz_t *result)
2540 {
2541 mpz_t size;
2542 int d;
2543
2544 mpz_init_set_ui (*result, 1);
2545
2546 for (d = 0; d < ar->dimen; d++)
2547 {
2548 if (!gfc_ref_dimen_size (ar, d, &size, NULL))
2549 {
2550 mpz_clear (*result);
2551 return false;
2552 }
2553
2554 mpz_mul (*result, *result, size);
2555 mpz_clear (size);
2556 }
2557
2558 return true;
2559 }
2560
2561
2562 /* Given an array expression and a dimension, figure out how many
2563 elements it has along that dimension. Returns true if we were
2564 able to return a result in the 'result' variable, false
2565 otherwise. */
2566
2567 bool
gfc_array_dimen_size(gfc_expr * array,int dimen,mpz_t * result)2568 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2569 {
2570 gfc_ref *ref;
2571 int i;
2572
2573 gcc_assert (array != NULL);
2574
2575 if (array->ts.type == BT_CLASS)
2576 return false;
2577
2578 if (array->rank == -1)
2579 return false;
2580
2581 if (dimen < 0 || dimen > array->rank - 1)
2582 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2583
2584 switch (array->expr_type)
2585 {
2586 case EXPR_VARIABLE:
2587 case EXPR_FUNCTION:
2588 for (ref = array->ref; ref; ref = ref->next)
2589 {
2590 if (ref->type != REF_ARRAY)
2591 continue;
2592
2593 if (ref->u.ar.type == AR_FULL)
2594 return spec_dimen_size (ref->u.ar.as, dimen, result);
2595
2596 if (ref->u.ar.type == AR_SECTION)
2597 {
2598 for (i = 0; dimen >= 0; i++)
2599 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2600 dimen--;
2601
2602 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2603 }
2604 }
2605
2606 if (array->shape)
2607 {
2608 mpz_init_set (*result, array->shape[dimen]);
2609 return true;
2610 }
2611
2612 if (array->symtree->n.sym->attr.generic
2613 && array->value.function.esym != NULL)
2614 {
2615 if (!spec_dimen_size (array->value.function.esym->as, dimen, result))
2616 return false;
2617 }
2618 else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result))
2619 return false;
2620
2621 break;
2622
2623 case EXPR_ARRAY:
2624 if (array->shape == NULL) {
2625 /* Expressions with rank > 1 should have "shape" properly set */
2626 if ( array->rank != 1 )
2627 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2628 return gfc_array_size(array, result);
2629 }
2630
2631 /* Fall through */
2632 default:
2633 if (array->shape == NULL)
2634 return false;
2635
2636 mpz_init_set (*result, array->shape[dimen]);
2637
2638 break;
2639 }
2640
2641 return true;
2642 }
2643
2644
2645 /* Given an array expression, figure out how many elements are in the
2646 array. Returns true if this is possible, and sets the 'result'
2647 variable. Otherwise returns false. */
2648
2649 bool
gfc_array_size(gfc_expr * array,mpz_t * result)2650 gfc_array_size (gfc_expr *array, mpz_t *result)
2651 {
2652 expand_info expand_save;
2653 gfc_ref *ref;
2654 int i;
2655 bool t;
2656
2657 if (array->ts.type == BT_CLASS)
2658 return false;
2659
2660 switch (array->expr_type)
2661 {
2662 case EXPR_ARRAY:
2663 gfc_push_suppress_errors ();
2664
2665 expand_save = current_expand;
2666
2667 current_expand.count = result;
2668 mpz_init_set_ui (*result, 0);
2669
2670 current_expand.expand_work_function = count_elements;
2671 iter_stack = NULL;
2672
2673 t = expand_constructor (array->value.constructor);
2674
2675 gfc_pop_suppress_errors ();
2676
2677 if (!t)
2678 mpz_clear (*result);
2679 current_expand = expand_save;
2680 return t;
2681
2682 case EXPR_VARIABLE:
2683 for (ref = array->ref; ref; ref = ref->next)
2684 {
2685 if (ref->type != REF_ARRAY)
2686 continue;
2687
2688 if (ref->u.ar.type == AR_FULL)
2689 return spec_size (ref->u.ar.as, result);
2690
2691 if (ref->u.ar.type == AR_SECTION)
2692 return ref_size (&ref->u.ar, result);
2693 }
2694
2695 return spec_size (array->symtree->n.sym->as, result);
2696
2697
2698 default:
2699 if (array->rank == 0 || array->shape == NULL)
2700 return false;
2701
2702 mpz_init_set_ui (*result, 1);
2703
2704 for (i = 0; i < array->rank; i++)
2705 mpz_mul (*result, *result, array->shape[i]);
2706
2707 break;
2708 }
2709
2710 return true;
2711 }
2712
2713
2714 /* Given an array reference, return the shape of the reference in an
2715 array of mpz_t integers. */
2716
2717 bool
gfc_array_ref_shape(gfc_array_ref * ar,mpz_t * shape)2718 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2719 {
2720 int d;
2721 int i;
2722
2723 d = 0;
2724
2725 switch (ar->type)
2726 {
2727 case AR_FULL:
2728 for (; d < ar->as->rank; d++)
2729 if (!spec_dimen_size (ar->as, d, &shape[d]))
2730 goto cleanup;
2731
2732 return true;
2733
2734 case AR_SECTION:
2735 for (i = 0; i < ar->dimen; i++)
2736 {
2737 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2738 {
2739 if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL))
2740 goto cleanup;
2741 d++;
2742 }
2743 }
2744
2745 return true;
2746
2747 default:
2748 break;
2749 }
2750
2751 cleanup:
2752 gfc_clear_shape (shape, d);
2753 return false;
2754 }
2755
2756
2757 /* Given an array expression, find the array reference structure that
2758 characterizes the reference. */
2759
2760 gfc_array_ref *
gfc_find_array_ref(gfc_expr * e,bool allow_null)2761 gfc_find_array_ref (gfc_expr *e, bool allow_null)
2762 {
2763 gfc_ref *ref;
2764
2765 for (ref = e->ref; ref; ref = ref->next)
2766 if (ref->type == REF_ARRAY
2767 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2768 break;
2769
2770 if (ref == NULL)
2771 {
2772 if (allow_null)
2773 return NULL;
2774 else
2775 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2776 }
2777
2778 return &ref->u.ar;
2779 }
2780
2781
2782 /* Find out if an array shape is known at compile time. */
2783
2784 bool
gfc_is_compile_time_shape(gfc_array_spec * as)2785 gfc_is_compile_time_shape (gfc_array_spec *as)
2786 {
2787 if (as->type != AS_EXPLICIT)
2788 return false;
2789
2790 for (int i = 0; i < as->rank; i++)
2791 if (!gfc_is_constant_expr (as->lower[i])
2792 || !gfc_is_constant_expr (as->upper[i]))
2793 return false;
2794
2795 return true;
2796 }
2797