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