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