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