1 /* Array things
2 Copyright (C) 2000-2020 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 (e == NULL)
1802 return false;
1803
1804 if (empty_constructor)
1805 empty_ts = e->ts;
1806
1807 /* Simplify constant array expression/section within constructor. */
1808 if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref
1809 && e->symtree && e->symtree->n.sym
1810 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1811 gfc_simplify_expr (e, 0);
1812
1813 if (e->expr_type == EXPR_ARRAY)
1814 {
1815 if (!expand_constructor (e->value.constructor))
1816 return false;
1817
1818 continue;
1819 }
1820
1821 empty_constructor = false;
1822 e = gfc_copy_expr (e);
1823 if (!gfc_simplify_expr (e, 1))
1824 {
1825 gfc_free_expr (e);
1826 return false;
1827 }
1828 e->from_constructor = 1;
1829 current_expand.offset = &c->offset;
1830 current_expand.repeat = &c->repeat;
1831 current_expand.component = c->n.component;
1832 if (!current_expand.expand_work_function(e))
1833 return false;
1834 }
1835 return true;
1836 }
1837
1838
1839 /* Given an array expression and an element number (starting at zero),
1840 return a pointer to the array element. NULL is returned if the
1841 size of the array has been exceeded. The expression node returned
1842 remains a part of the array and should not be freed. Access is not
1843 efficient at all, but this is another place where things do not
1844 have to be particularly fast. */
1845
1846 static gfc_expr *
gfc_get_array_element(gfc_expr * array,int element)1847 gfc_get_array_element (gfc_expr *array, int element)
1848 {
1849 expand_info expand_save;
1850 gfc_expr *e;
1851 bool rc;
1852
1853 expand_save = current_expand;
1854 current_expand.extract_n = element;
1855 current_expand.expand_work_function = extract_element;
1856 current_expand.extracted = NULL;
1857 current_expand.extract_count = 0;
1858
1859 iter_stack = NULL;
1860
1861 rc = expand_constructor (array->value.constructor);
1862 e = current_expand.extracted;
1863 current_expand = expand_save;
1864
1865 if (!rc)
1866 return NULL;
1867
1868 return e;
1869 }
1870
1871
1872 /* Top level subroutine for expanding constructors. We only expand
1873 constructor if they are small enough. */
1874
1875 bool
gfc_expand_constructor(gfc_expr * e,bool fatal)1876 gfc_expand_constructor (gfc_expr *e, bool fatal)
1877 {
1878 expand_info expand_save;
1879 gfc_expr *f;
1880 bool rc;
1881
1882 if (gfc_is_size_zero_array (e))
1883 return true;
1884
1885 /* If we can successfully get an array element at the max array size then
1886 the array is too big to expand, so we just return. */
1887 f = gfc_get_array_element (e, flag_max_array_constructor);
1888 if (f != NULL)
1889 {
1890 gfc_free_expr (f);
1891 if (fatal)
1892 {
1893 gfc_error ("The number of elements in the array constructor "
1894 "at %L requires an increase of the allowed %d "
1895 "upper limit. See %<-fmax-array-constructor%> "
1896 "option", &e->where, flag_max_array_constructor);
1897 return false;
1898 }
1899 return true;
1900 }
1901
1902 /* We now know the array is not too big so go ahead and try to expand it. */
1903 expand_save = current_expand;
1904 current_expand.base = NULL;
1905
1906 iter_stack = NULL;
1907
1908 empty_constructor = true;
1909 gfc_clear_ts (&empty_ts);
1910 current_expand.expand_work_function = expand;
1911
1912 if (!expand_constructor (e->value.constructor))
1913 {
1914 gfc_constructor_free (current_expand.base);
1915 rc = false;
1916 goto done;
1917 }
1918
1919 /* If we don't have an explicit constructor type, and there
1920 were only empty constructors, then take the type from
1921 them. */
1922
1923 if (constructor_ts.type == BT_UNKNOWN && empty_constructor)
1924 e->ts = empty_ts;
1925
1926 gfc_constructor_free (e->value.constructor);
1927 e->value.constructor = current_expand.base;
1928
1929 rc = true;
1930
1931 done:
1932 current_expand = expand_save;
1933
1934 return rc;
1935 }
1936
1937
1938 /* Work function for checking that an element of a constructor is a
1939 constant, after removal of any iteration variables. We return
1940 false if not so. */
1941
1942 static bool
is_constant_element(gfc_expr * e)1943 is_constant_element (gfc_expr *e)
1944 {
1945 int rv;
1946
1947 rv = gfc_is_constant_expr (e);
1948 gfc_free_expr (e);
1949
1950 return rv ? true : false;
1951 }
1952
1953
1954 /* Given an array constructor, determine if the constructor is
1955 constant or not by expanding it and making sure that all elements
1956 are constants. This is a bit of a hack since something like (/ (i,
1957 i=1,100000000) /) will take a while as* opposed to a more clever
1958 function that traverses the expression tree. FIXME. */
1959
1960 int
gfc_constant_ac(gfc_expr * e)1961 gfc_constant_ac (gfc_expr *e)
1962 {
1963 expand_info expand_save;
1964 bool rc;
1965
1966 iter_stack = NULL;
1967 expand_save = current_expand;
1968 current_expand.expand_work_function = is_constant_element;
1969
1970 rc = expand_constructor (e->value.constructor);
1971
1972 current_expand = expand_save;
1973 if (!rc)
1974 return 0;
1975
1976 return 1;
1977 }
1978
1979
1980 /* Returns nonzero if an array constructor has been completely
1981 expanded (no iterators) and zero if iterators are present. */
1982
1983 int
gfc_expanded_ac(gfc_expr * e)1984 gfc_expanded_ac (gfc_expr *e)
1985 {
1986 gfc_constructor *c;
1987
1988 if (e->expr_type == EXPR_ARRAY)
1989 for (c = gfc_constructor_first (e->value.constructor);
1990 c; c = gfc_constructor_next (c))
1991 if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1992 return 0;
1993
1994 return 1;
1995 }
1996
1997
1998 /*************** Type resolution of array constructors ***************/
1999
2000
2001 /* The symbol expr_is_sought_symbol_ref will try to find. */
2002 static const gfc_symbol *sought_symbol = NULL;
2003
2004
2005 /* Tells whether the expression E is a variable reference to the symbol
2006 in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE
2007 accordingly.
2008 To be used with gfc_expr_walker: if a reference is found we don't need
2009 to look further so we return 1 to skip any further walk. */
2010
2011 static int
expr_is_sought_symbol_ref(gfc_expr ** e,int * walk_subtrees ATTRIBUTE_UNUSED,void * where)2012 expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2013 void *where)
2014 {
2015 gfc_expr *expr = *e;
2016 locus *sym_loc = (locus *)where;
2017
2018 if (expr->expr_type == EXPR_VARIABLE
2019 && expr->symtree->n.sym == sought_symbol)
2020 {
2021 *sym_loc = expr->where;
2022 return 1;
2023 }
2024
2025 return 0;
2026 }
2027
2028
2029 /* Tells whether the expression EXPR contains a reference to the symbol
2030 SYM and in that case sets the position SYM_LOC where the reference is. */
2031
2032 static bool
find_symbol_in_expr(gfc_symbol * sym,gfc_expr * expr,locus * sym_loc)2033 find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc)
2034 {
2035 int ret;
2036
2037 sought_symbol = sym;
2038 ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc);
2039 sought_symbol = NULL;
2040 return ret;
2041 }
2042
2043
2044 /* Recursive array list resolution function. All of the elements must
2045 be of the same type. */
2046
2047 static bool
resolve_array_list(gfc_constructor_base base)2048 resolve_array_list (gfc_constructor_base base)
2049 {
2050 bool t;
2051 gfc_constructor *c;
2052 gfc_iterator *iter;
2053
2054 t = true;
2055
2056 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2057 {
2058 iter = c->iterator;
2059 if (iter != NULL)
2060 {
2061 gfc_symbol *iter_var;
2062 locus iter_var_loc;
2063
2064 if (!gfc_resolve_iterator (iter, false, true))
2065 t = false;
2066
2067 /* Check for bounds referencing the iterator variable. */
2068 gcc_assert (iter->var->expr_type == EXPR_VARIABLE);
2069 iter_var = iter->var->symtree->n.sym;
2070 if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc))
2071 {
2072 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial "
2073 "expression references control variable "
2074 "at %L", &iter_var_loc))
2075 t = false;
2076 }
2077 if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc))
2078 {
2079 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final "
2080 "expression references control variable "
2081 "at %L", &iter_var_loc))
2082 t = false;
2083 }
2084 if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc))
2085 {
2086 if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step "
2087 "expression references control variable "
2088 "at %L", &iter_var_loc))
2089 t = false;
2090 }
2091 }
2092
2093 if (!gfc_resolve_expr (c->expr))
2094 t = false;
2095
2096 if (UNLIMITED_POLY (c->expr))
2097 {
2098 gfc_error ("Array constructor value at %L shall not be unlimited "
2099 "polymorphic [F2008: C4106]", &c->expr->where);
2100 t = false;
2101 }
2102 }
2103
2104 return t;
2105 }
2106
2107 /* Resolve character array constructor. If it has a specified constant character
2108 length, pad/truncate the elements here; if the length is not specified and
2109 all elements are of compile-time known length, emit an error as this is
2110 invalid. */
2111
2112 bool
gfc_resolve_character_array_constructor(gfc_expr * expr)2113 gfc_resolve_character_array_constructor (gfc_expr *expr)
2114 {
2115 gfc_constructor *p;
2116 HOST_WIDE_INT found_length;
2117
2118 gcc_assert (expr->expr_type == EXPR_ARRAY);
2119 gcc_assert (expr->ts.type == BT_CHARACTER);
2120
2121 if (expr->ts.u.cl == NULL)
2122 {
2123 for (p = gfc_constructor_first (expr->value.constructor);
2124 p; p = gfc_constructor_next (p))
2125 if (p->expr->ts.u.cl != NULL)
2126 {
2127 /* Ensure that if there is a char_len around that it is
2128 used; otherwise the middle-end confuses them! */
2129 expr->ts.u.cl = p->expr->ts.u.cl;
2130 goto got_charlen;
2131 }
2132
2133 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2134 }
2135
2136 got_charlen:
2137
2138 /* Early exit for zero size arrays. */
2139 if (expr->shape)
2140 {
2141 mpz_t size;
2142 HOST_WIDE_INT arraysize;
2143
2144 gfc_array_size (expr, &size);
2145 arraysize = mpz_get_ui (size);
2146 mpz_clear (size);
2147
2148 if (arraysize == 0)
2149 return true;
2150 }
2151
2152 found_length = -1;
2153
2154 if (expr->ts.u.cl->length == NULL)
2155 {
2156 /* Check that all constant string elements have the same length until
2157 we reach the end or find a variable-length one. */
2158
2159 for (p = gfc_constructor_first (expr->value.constructor);
2160 p; p = gfc_constructor_next (p))
2161 {
2162 HOST_WIDE_INT current_length = -1;
2163 gfc_ref *ref;
2164 for (ref = p->expr->ref; ref; ref = ref->next)
2165 if (ref->type == REF_SUBSTRING
2166 && ref->u.ss.start
2167 && ref->u.ss.start->expr_type == EXPR_CONSTANT
2168 && ref->u.ss.end
2169 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2170 break;
2171
2172 if (p->expr->expr_type == EXPR_CONSTANT)
2173 current_length = p->expr->value.character.length;
2174 else if (ref)
2175 current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer)
2176 - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1;
2177 else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
2178 && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2179 current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer);
2180 else
2181 return true;
2182
2183 if (current_length < 0)
2184 current_length = 0;
2185
2186 if (found_length == -1)
2187 found_length = current_length;
2188 else if (found_length != current_length)
2189 {
2190 gfc_error ("Different CHARACTER lengths (%ld/%ld) in array"
2191 " constructor at %L", (long) found_length,
2192 (long) current_length, &p->expr->where);
2193 return false;
2194 }
2195
2196 gcc_assert (found_length == current_length);
2197 }
2198
2199 gcc_assert (found_length != -1);
2200
2201 /* Update the character length of the array constructor. */
2202 expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2203 NULL, found_length);
2204 }
2205 else
2206 {
2207 /* We've got a character length specified. It should be an integer,
2208 otherwise an error is signalled elsewhere. */
2209 gcc_assert (expr->ts.u.cl->length);
2210
2211 /* If we've got a constant character length, pad according to this.
2212 gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2213 max_length only if they pass. */
2214 gfc_extract_hwi (expr->ts.u.cl->length, &found_length);
2215
2216 /* Now pad/truncate the elements accordingly to the specified character
2217 length. This is ok inside this conditional, as in the case above
2218 (without typespec) all elements are verified to have the same length
2219 anyway. */
2220 if (found_length != -1)
2221 for (p = gfc_constructor_first (expr->value.constructor);
2222 p; p = gfc_constructor_next (p))
2223 if (p->expr->expr_type == EXPR_CONSTANT)
2224 {
2225 gfc_expr *cl = NULL;
2226 HOST_WIDE_INT current_length = -1;
2227 bool has_ts;
2228
2229 if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
2230 {
2231 cl = p->expr->ts.u.cl->length;
2232 gfc_extract_hwi (cl, ¤t_length);
2233 }
2234
2235 /* If gfc_extract_int above set current_length, we implicitly
2236 know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2237
2238 has_ts = expr->ts.u.cl->length_from_typespec;
2239
2240 if (! cl
2241 || (current_length != -1 && current_length != found_length))
2242 gfc_set_constant_character_len (found_length, p->expr,
2243 has_ts ? -1 : found_length);
2244 }
2245 }
2246
2247 return true;
2248 }
2249
2250
2251 /* Resolve all of the expressions in an array list. */
2252
2253 bool
gfc_resolve_array_constructor(gfc_expr * expr)2254 gfc_resolve_array_constructor (gfc_expr *expr)
2255 {
2256 bool t;
2257
2258 t = resolve_array_list (expr->value.constructor);
2259 if (t)
2260 t = gfc_check_constructor_type (expr);
2261
2262 /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2263 the call to this function, so we don't need to call it here; if it was
2264 called twice, an error message there would be duplicated. */
2265
2266 return t;
2267 }
2268
2269
2270 /* Copy an iterator structure. */
2271
2272 gfc_iterator *
gfc_copy_iterator(gfc_iterator * src)2273 gfc_copy_iterator (gfc_iterator *src)
2274 {
2275 gfc_iterator *dest;
2276
2277 if (src == NULL)
2278 return NULL;
2279
2280 dest = gfc_get_iterator ();
2281
2282 dest->var = gfc_copy_expr (src->var);
2283 dest->start = gfc_copy_expr (src->start);
2284 dest->end = gfc_copy_expr (src->end);
2285 dest->step = gfc_copy_expr (src->step);
2286 dest->unroll = src->unroll;
2287 dest->ivdep = src->ivdep;
2288 dest->vector = src->vector;
2289 dest->novector = src->novector;
2290
2291 return dest;
2292 }
2293
2294
2295 /********* Subroutines for determining the size of an array *********/
2296
2297 /* These are needed just to accommodate RESHAPE(). There are no
2298 diagnostics here, we just return false if something goes wrong. */
2299
2300
2301 /* Get the size of single dimension of an array specification. The
2302 array is guaranteed to be one dimensional. */
2303
2304 bool
spec_dimen_size(gfc_array_spec * as,int dimen,mpz_t * result)2305 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2306 {
2307 if (as == NULL)
2308 return false;
2309
2310 if (dimen < 0 || dimen > as->rank - 1)
2311 gfc_internal_error ("spec_dimen_size(): Bad dimension");
2312
2313 if (as->type != AS_EXPLICIT
2314 || !as->lower[dimen]
2315 || !as->upper[dimen])
2316 return false;
2317
2318 if (as->lower[dimen]->expr_type != EXPR_CONSTANT
2319 || as->upper[dimen]->expr_type != EXPR_CONSTANT
2320 || as->lower[dimen]->ts.type != BT_INTEGER
2321 || as->upper[dimen]->ts.type != BT_INTEGER)
2322 return false;
2323
2324 mpz_init (*result);
2325
2326 mpz_sub (*result, as->upper[dimen]->value.integer,
2327 as->lower[dimen]->value.integer);
2328
2329 mpz_add_ui (*result, *result, 1);
2330
2331 if (mpz_cmp_si (*result, 0) < 0)
2332 mpz_set_si (*result, 0);
2333
2334 return true;
2335 }
2336
2337
2338 bool
spec_size(gfc_array_spec * as,mpz_t * result)2339 spec_size (gfc_array_spec *as, mpz_t *result)
2340 {
2341 mpz_t size;
2342 int d;
2343
2344 if (!as || as->type == AS_ASSUMED_RANK)
2345 return false;
2346
2347 mpz_init_set_ui (*result, 1);
2348
2349 for (d = 0; d < as->rank; d++)
2350 {
2351 if (!spec_dimen_size (as, d, &size))
2352 {
2353 mpz_clear (*result);
2354 return false;
2355 }
2356
2357 mpz_mul (*result, *result, size);
2358 mpz_clear (size);
2359 }
2360
2361 return true;
2362 }
2363
2364
2365 /* Get the number of elements in an array section. Optionally, also supply
2366 the end value. */
2367
2368 bool
gfc_ref_dimen_size(gfc_array_ref * ar,int dimen,mpz_t * result,mpz_t * end)2369 gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
2370 {
2371 mpz_t upper, lower, stride;
2372 mpz_t diff;
2373 bool t;
2374 gfc_expr *stride_expr = NULL;
2375
2376 if (dimen < 0 || ar == NULL)
2377 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2378
2379 if (dimen > ar->dimen - 1)
2380 {
2381 gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]);
2382 return false;
2383 }
2384
2385 switch (ar->dimen_type[dimen])
2386 {
2387 case DIMEN_ELEMENT:
2388 mpz_init (*result);
2389 mpz_set_ui (*result, 1);
2390 t = true;
2391 break;
2392
2393 case DIMEN_VECTOR:
2394 t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2395 break;
2396
2397 case DIMEN_RANGE:
2398
2399 mpz_init (stride);
2400
2401 if (ar->stride[dimen] == NULL)
2402 mpz_set_ui (stride, 1);
2403 else
2404 {
2405 stride_expr = gfc_copy_expr(ar->stride[dimen]);
2406
2407 if (!gfc_simplify_expr (stride_expr, 1)
2408 || stride_expr->expr_type != EXPR_CONSTANT
2409 || mpz_cmp_ui (stride_expr->value.integer, 0) == 0)
2410 {
2411 gfc_free_expr (stride_expr);
2412 mpz_clear (stride);
2413 return false;
2414 }
2415 mpz_set (stride, stride_expr->value.integer);
2416 gfc_free_expr(stride_expr);
2417 }
2418
2419 /* Calculate the number of elements via gfc_dep_differce, but only if
2420 start and end are both supplied in the reference or the array spec.
2421 This is to guard against strange but valid code like
2422
2423 subroutine foo(a,n)
2424 real a(1:n)
2425 n = 3
2426 print *,size(a(n-1:))
2427
2428 where the user changes the value of a variable. If we have to
2429 determine end as well, we cannot do this using gfc_dep_difference.
2430 Fall back to the constants-only code then. */
2431
2432 if (end == NULL)
2433 {
2434 bool use_dep;
2435
2436 use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
2437 &diff);
2438 if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL)
2439 use_dep = gfc_dep_difference (ar->as->upper[dimen],
2440 ar->as->lower[dimen], &diff);
2441
2442 if (use_dep)
2443 {
2444 mpz_init (*result);
2445 mpz_add (*result, diff, stride);
2446 mpz_div (*result, *result, stride);
2447 if (mpz_cmp_ui (*result, 0) < 0)
2448 mpz_set_ui (*result, 0);
2449
2450 mpz_clear (stride);
2451 mpz_clear (diff);
2452 return true;
2453 }
2454
2455 }
2456
2457 /* Constant-only code here, which covers more cases
2458 like a(:4) etc. */
2459 mpz_init (upper);
2460 mpz_init (lower);
2461 t = false;
2462
2463 if (ar->start[dimen] == NULL)
2464 {
2465 if (ar->as->lower[dimen] == NULL
2466 || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT
2467 || ar->as->lower[dimen]->ts.type != BT_INTEGER)
2468 goto cleanup;
2469 mpz_set (lower, ar->as->lower[dimen]->value.integer);
2470 }
2471 else
2472 {
2473 if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2474 goto cleanup;
2475 mpz_set (lower, ar->start[dimen]->value.integer);
2476 }
2477
2478 if (ar->end[dimen] == NULL)
2479 {
2480 if (ar->as->upper[dimen] == NULL
2481 || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT
2482 || ar->as->upper[dimen]->ts.type != BT_INTEGER)
2483 goto cleanup;
2484 mpz_set (upper, ar->as->upper[dimen]->value.integer);
2485 }
2486 else
2487 {
2488 if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2489 goto cleanup;
2490 mpz_set (upper, ar->end[dimen]->value.integer);
2491 }
2492
2493 mpz_init (*result);
2494 mpz_sub (*result, upper, lower);
2495 mpz_add (*result, *result, stride);
2496 mpz_div (*result, *result, stride);
2497
2498 /* Zero stride caught earlier. */
2499 if (mpz_cmp_ui (*result, 0) < 0)
2500 mpz_set_ui (*result, 0);
2501 t = true;
2502
2503 if (end)
2504 {
2505 mpz_init (*end);
2506
2507 mpz_sub_ui (*end, *result, 1UL);
2508 mpz_mul (*end, *end, stride);
2509 mpz_add (*end, *end, lower);
2510 }
2511
2512 cleanup:
2513 mpz_clear (upper);
2514 mpz_clear (lower);
2515 mpz_clear (stride);
2516 return t;
2517
2518 default:
2519 gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2520 }
2521
2522 return t;
2523 }
2524
2525
2526 static bool
ref_size(gfc_array_ref * ar,mpz_t * result)2527 ref_size (gfc_array_ref *ar, mpz_t *result)
2528 {
2529 mpz_t size;
2530 int d;
2531
2532 mpz_init_set_ui (*result, 1);
2533
2534 for (d = 0; d < ar->dimen; d++)
2535 {
2536 if (!gfc_ref_dimen_size (ar, d, &size, NULL))
2537 {
2538 mpz_clear (*result);
2539 return false;
2540 }
2541
2542 mpz_mul (*result, *result, size);
2543 mpz_clear (size);
2544 }
2545
2546 return true;
2547 }
2548
2549
2550 /* Given an array expression and a dimension, figure out how many
2551 elements it has along that dimension. Returns true if we were
2552 able to return a result in the 'result' variable, false
2553 otherwise. */
2554
2555 bool
gfc_array_dimen_size(gfc_expr * array,int dimen,mpz_t * result)2556 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2557 {
2558 gfc_ref *ref;
2559 int i;
2560
2561 gcc_assert (array != NULL);
2562
2563 if (array->ts.type == BT_CLASS)
2564 return false;
2565
2566 if (array->rank == -1)
2567 return false;
2568
2569 if (dimen < 0 || dimen > array->rank - 1)
2570 gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2571
2572 switch (array->expr_type)
2573 {
2574 case EXPR_VARIABLE:
2575 case EXPR_FUNCTION:
2576 for (ref = array->ref; ref; ref = ref->next)
2577 {
2578 if (ref->type != REF_ARRAY)
2579 continue;
2580
2581 if (ref->u.ar.type == AR_FULL)
2582 return spec_dimen_size (ref->u.ar.as, dimen, result);
2583
2584 if (ref->u.ar.type == AR_SECTION)
2585 {
2586 for (i = 0; dimen >= 0; i++)
2587 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2588 dimen--;
2589
2590 return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2591 }
2592 }
2593
2594 if (array->shape && array->shape[dimen])
2595 {
2596 mpz_init_set (*result, array->shape[dimen]);
2597 return true;
2598 }
2599
2600 if (array->symtree->n.sym->attr.generic
2601 && array->value.function.esym != NULL)
2602 {
2603 if (!spec_dimen_size (array->value.function.esym->as, dimen, result))
2604 return false;
2605 }
2606 else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result))
2607 return false;
2608
2609 break;
2610
2611 case EXPR_ARRAY:
2612 if (array->shape == NULL) {
2613 /* Expressions with rank > 1 should have "shape" properly set */
2614 if ( array->rank != 1 )
2615 gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2616 return gfc_array_size(array, result);
2617 }
2618
2619 /* Fall through */
2620 default:
2621 if (array->shape == NULL)
2622 return false;
2623
2624 mpz_init_set (*result, array->shape[dimen]);
2625
2626 break;
2627 }
2628
2629 return true;
2630 }
2631
2632
2633 /* Given an array expression, figure out how many elements are in the
2634 array. Returns true if this is possible, and sets the 'result'
2635 variable. Otherwise returns false. */
2636
2637 bool
gfc_array_size(gfc_expr * array,mpz_t * result)2638 gfc_array_size (gfc_expr *array, mpz_t *result)
2639 {
2640 expand_info expand_save;
2641 gfc_ref *ref;
2642 int i;
2643 bool t;
2644
2645 if (array->ts.type == BT_CLASS)
2646 return false;
2647
2648 switch (array->expr_type)
2649 {
2650 case EXPR_ARRAY:
2651 gfc_push_suppress_errors ();
2652
2653 expand_save = current_expand;
2654
2655 current_expand.count = result;
2656 mpz_init_set_ui (*result, 0);
2657
2658 current_expand.expand_work_function = count_elements;
2659 iter_stack = NULL;
2660
2661 t = expand_constructor (array->value.constructor);
2662
2663 gfc_pop_suppress_errors ();
2664
2665 if (!t)
2666 mpz_clear (*result);
2667 current_expand = expand_save;
2668 return t;
2669
2670 case EXPR_VARIABLE:
2671 for (ref = array->ref; ref; ref = ref->next)
2672 {
2673 if (ref->type != REF_ARRAY)
2674 continue;
2675
2676 if (ref->u.ar.type == AR_FULL)
2677 return spec_size (ref->u.ar.as, result);
2678
2679 if (ref->u.ar.type == AR_SECTION)
2680 return ref_size (&ref->u.ar, result);
2681 }
2682
2683 return spec_size (array->symtree->n.sym->as, result);
2684
2685
2686 default:
2687 if (array->rank == 0 || array->shape == NULL)
2688 return false;
2689
2690 mpz_init_set_ui (*result, 1);
2691
2692 for (i = 0; i < array->rank; i++)
2693 mpz_mul (*result, *result, array->shape[i]);
2694
2695 break;
2696 }
2697
2698 return true;
2699 }
2700
2701
2702 /* Given an array reference, return the shape of the reference in an
2703 array of mpz_t integers. */
2704
2705 bool
gfc_array_ref_shape(gfc_array_ref * ar,mpz_t * shape)2706 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2707 {
2708 int d;
2709 int i;
2710
2711 d = 0;
2712
2713 switch (ar->type)
2714 {
2715 case AR_FULL:
2716 for (; d < ar->as->rank; d++)
2717 if (!spec_dimen_size (ar->as, d, &shape[d]))
2718 goto cleanup;
2719
2720 return true;
2721
2722 case AR_SECTION:
2723 for (i = 0; i < ar->dimen; i++)
2724 {
2725 if (ar->dimen_type[i] != DIMEN_ELEMENT)
2726 {
2727 if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL))
2728 goto cleanup;
2729 d++;
2730 }
2731 }
2732
2733 return true;
2734
2735 default:
2736 break;
2737 }
2738
2739 cleanup:
2740 gfc_clear_shape (shape, d);
2741 return false;
2742 }
2743
2744
2745 /* Given an array expression, find the array reference structure that
2746 characterizes the reference. */
2747
2748 gfc_array_ref *
gfc_find_array_ref(gfc_expr * e,bool allow_null)2749 gfc_find_array_ref (gfc_expr *e, bool allow_null)
2750 {
2751 gfc_ref *ref;
2752
2753 for (ref = e->ref; ref; ref = ref->next)
2754 if (ref->type == REF_ARRAY
2755 && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2756 break;
2757
2758 if (ref == NULL)
2759 {
2760 if (allow_null)
2761 return NULL;
2762 else
2763 gfc_internal_error ("gfc_find_array_ref(): No ref found");
2764 }
2765
2766 return &ref->u.ar;
2767 }
2768
2769
2770 /* Find out if an array shape is known at compile time. */
2771
2772 bool
gfc_is_compile_time_shape(gfc_array_spec * as)2773 gfc_is_compile_time_shape (gfc_array_spec *as)
2774 {
2775 if (as->type != AS_EXPLICIT)
2776 return false;
2777
2778 for (int i = 0; i < as->rank; i++)
2779 if (!gfc_is_constant_expr (as->lower[i])
2780 || !gfc_is_constant_expr (as->upper[i]))
2781 return false;
2782
2783 return true;
2784 }
2785