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