Branch data Line data Source code
1 : : /* Array things
2 : : Copyright (C) 2000-2025 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 : 167158 : gfc_copy_array_ref (gfc_array_ref *src)
36 : : {
37 : 167158 : gfc_array_ref *dest;
38 : 167158 : int i;
39 : :
40 : 167158 : if (src == NULL)
41 : : return NULL;
42 : :
43 : 167158 : dest = gfc_get_array_ref ();
44 : :
45 : 167158 : *dest = *src;
46 : :
47 : 2674528 : for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
48 : : {
49 : 2507370 : dest->start[i] = gfc_copy_expr (src->start[i]);
50 : 2507370 : dest->end[i] = gfc_copy_expr (src->end[i]);
51 : 2507370 : dest->stride[i] = gfc_copy_expr (src->stride[i]);
52 : : }
53 : :
54 : 167158 : dest->stat = gfc_copy_expr (src->stat);
55 : 167158 : dest->team = gfc_copy_expr (src->team);
56 : :
57 : 167158 : 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 : 361399 : match_subscript (gfc_array_ref *ar, int init, bool match_star)
69 : : {
70 : 361399 : match m = MATCH_ERROR;
71 : 361399 : bool star = false;
72 : 361399 : int i;
73 : 361399 : bool saw_boz = false;
74 : :
75 : 361399 : i = ar->dimen + ar->codimen;
76 : :
77 : 361399 : gfc_gobble_whitespace ();
78 : 361399 : ar->c_where[i] = gfc_current_locus;
79 : 361399 : 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 : 361399 : ar->dimen_type[i] = DIMEN_UNKNOWN;
86 : :
87 : 361399 : if (gfc_match_char (':') == MATCH_YES)
88 : 43499 : goto end_element;
89 : :
90 : : /* Get start element. */
91 : 317900 : if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
92 : : star = true;
93 : :
94 : 317900 : if (!star && init)
95 : 1636 : m = gfc_match_init_expr (&ar->start[i]);
96 : 316264 : else if (!star)
97 : 315603 : m = gfc_match_expr (&ar->start[i]);
98 : :
99 : 317900 : 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 : 317900 : if (m == MATCH_NO)
106 : 4 : gfc_error ("Expected array subscript at %C");
107 : 317900 : if (m != MATCH_YES)
108 : : return MATCH_ERROR;
109 : :
110 : 317890 : if (gfc_match_char (':') == MATCH_NO)
111 : 283010 : goto matched;
112 : :
113 : 34880 : 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 : 34880 : end_element:
122 : 78379 : ar->dimen_type[i] = DIMEN_RANGE;
123 : :
124 : 78379 : if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
125 : : star = true;
126 : 78223 : else if (init)
127 : 371 : m = gfc_match_init_expr (&ar->end[i]);
128 : : else
129 : 77852 : m = gfc_match_expr (&ar->end[i]);
130 : :
131 : 78379 : 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 : 78379 : if (m == MATCH_ERROR)
138 : : return MATCH_ERROR;
139 : :
140 : 78379 : 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 : 78377 : if (gfc_match_char (':') == MATCH_YES)
149 : : {
150 : 16650 : if (star)
151 : : {
152 : 0 : gfc_error ("Strides not allowed in coarray subscript at %C");
153 : 0 : return MATCH_ERROR;
154 : : }
155 : :
156 : 16650 : m = init ? gfc_match_init_expr (&ar->stride[i])
157 : 16649 : : gfc_match_expr (&ar->stride[i]);
158 : :
159 : 16650 : 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 : 16650 : if (m == MATCH_NO)
166 : 0 : gfc_error ("Expected array subscript stride at %C");
167 : 16650 : if (m != MATCH_YES)
168 : : return MATCH_ERROR;
169 : : }
170 : :
171 : 61727 : matched:
172 : 361387 : if (star)
173 : 815 : ar->dimen_type[i] = DIMEN_STAR;
174 : :
175 : 361387 : return (saw_boz ? MATCH_ERROR : MATCH_YES);
176 : : }
177 : :
178 : : /** Match one of TEAM=, TEAM_NUMBER= or STAT=. */
179 : :
180 : : match
181 : 4860 : match_team_or_stat (gfc_array_ref *ar)
182 : : {
183 : 4860 : gfc_expr *tmp;
184 : 4860 : bool team_error = false;
185 : :
186 : 4860 : if (gfc_match (" team = %e", &tmp) == MATCH_YES)
187 : : {
188 : 50 : if (ar->team == NULL && ar->team_type == TEAM_UNSET)
189 : : {
190 : 46 : ar->team = tmp;
191 : 46 : ar->team_type = TEAM_TEAM;
192 : : }
193 : 4 : else if (ar->team_type == TEAM_TEAM)
194 : : {
195 : 2 : gfc_error ("Duplicate TEAM= attribute in %C");
196 : 2 : return MATCH_ERROR;
197 : : }
198 : : else
199 : : team_error = true;
200 : : }
201 : 4810 : else if (gfc_match (" team_number = %e", &tmp) == MATCH_YES)
202 : : {
203 : 68 : if (!gfc_notify_std (GFC_STD_F2018, "TEAM_NUMBER= not supported at %C"))
204 : : return MATCH_ERROR;
205 : 66 : if (ar->team == NULL && ar->team_type == TEAM_UNSET)
206 : : {
207 : 64 : ar->team = tmp;
208 : 64 : ar->team_type = TEAM_NUMBER;
209 : : }
210 : 2 : else if (ar->team_type == TEAM_NUMBER)
211 : : {
212 : 2 : gfc_error ("Duplicate TEAM_NUMBER= attribute in %C");
213 : 2 : return MATCH_ERROR;
214 : : }
215 : : else
216 : : team_error = true;
217 : : }
218 : 4742 : else if (gfc_match (" stat = %e", &tmp) == MATCH_YES)
219 : : {
220 : 79 : if (ar->stat == NULL)
221 : : {
222 : 75 : if (gfc_is_coindexed (tmp))
223 : : {
224 : 2 : gfc_error ("Expression in STAT= at %C must not be coindexed");
225 : 2 : gfc_free_expr (tmp);
226 : 2 : return MATCH_ERROR;
227 : : }
228 : 73 : ar->stat = tmp;
229 : : }
230 : : else
231 : : {
232 : 4 : gfc_error ("Duplicate STAT= attribute in %C");
233 : 4 : return MATCH_ERROR;
234 : : }
235 : : }
236 : : else
237 : : return MATCH_NO;
238 : :
239 : 185 : if (ar->team && team_error)
240 : : {
241 : 2 : gfc_error ("Only one of TEAM= or TEAM_NUMBER= may appear in a "
242 : : "coarray reference at %C");
243 : 2 : 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 : 722837 : gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
255 : : int corank, bool coarray_only)
256 : : {
257 : 722837 : match m;
258 : 722837 : bool matched_bracket = false;
259 : :
260 : 722837 : memset (ar, '\0', sizeof (*ar));
261 : :
262 : 722837 : ar->where = gfc_current_locus;
263 : 722837 : ar->as = as;
264 : 722837 : ar->type = AR_UNKNOWN;
265 : :
266 : 722837 : if (gfc_match_char ('[') == MATCH_YES)
267 : : {
268 : 3017 : matched_bracket = true;
269 : 3017 : goto coarray;
270 : : }
271 : 719820 : else if (coarray_only && corank != 0)
272 : 1236 : goto coarray;
273 : :
274 : 718584 : if (gfc_match_char ('(') != MATCH_YES)
275 : : {
276 : 443581 : ar->type = AR_FULL;
277 : 443581 : ar->dimen = 0;
278 : 443581 : if (corank != 0)
279 : : {
280 : 150704 : for (int i = 0; i < GFC_MAX_DIMENSIONS; ++i)
281 : 141285 : ar->dimen_type[i] = DIMEN_THIS_IMAGE;
282 : 9419 : ar->codimen = corank;
283 : : }
284 : 443581 : return MATCH_YES;
285 : : }
286 : :
287 : 356734 : for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
288 : : {
289 : 356734 : m = match_subscript (ar, init, false);
290 : 356734 : if (m == MATCH_ERROR)
291 : : return MATCH_ERROR;
292 : :
293 : 356721 : if (gfc_match_char (')') == MATCH_YES)
294 : : {
295 : 274982 : ar->dimen++;
296 : 274982 : goto coarray;
297 : : }
298 : :
299 : 81739 : if (gfc_match_char (',') != MATCH_YES)
300 : : {
301 : 8 : gfc_error ("Invalid form of array reference at %C");
302 : 8 : 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 : 279235 : coarray:
316 : 279235 : if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
317 : : {
318 : 275127 : int dim = coarray_only ? 0 : ar->dimen;
319 : 275127 : if (dim > 0 || coarray_only)
320 : : {
321 : 275127 : if (corank != 0)
322 : : {
323 : 70334 : for (int i = dim; i < GFC_MAX_DIMENSIONS; ++i)
324 : 65702 : ar->dimen_type[i] = DIMEN_THIS_IMAGE;
325 : 4632 : ar->codimen = corank;
326 : : }
327 : 275127 : return MATCH_YES;
328 : : }
329 : : else
330 : : return MATCH_ERROR;
331 : : }
332 : :
333 : 4108 : 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 : 4108 : if (corank == 0)
340 : : {
341 : 0 : gfc_error ("Unexpected coarray designator at %C");
342 : 0 : return MATCH_ERROR;
343 : : }
344 : :
345 : 4108 : ar->team_type = TEAM_UNSET;
346 : :
347 : 4665 : for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS;
348 : : ar->codimen++)
349 : : {
350 : 4665 : m = match_subscript (ar, init, true);
351 : 4665 : if (m == MATCH_ERROR)
352 : : return MATCH_ERROR;
353 : :
354 : 4663 : if (gfc_match_char (',') != MATCH_YES)
355 : : {
356 : 3957 : 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 : 3957 : goto image_selector;
362 : : }
363 : 0 : return MATCH_ERROR;
364 : : }
365 : 706 : 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 : 704 : m = match_team_or_stat (ar);
373 : 704 : if (m == MATCH_ERROR)
374 : : return MATCH_ERROR;
375 : 700 : else if (m == MATCH_YES)
376 : 139 : goto image_selector;
377 : :
378 : 561 : if (gfc_match_char (']') == MATCH_YES)
379 : 0 : goto rank_check;
380 : :
381 : 561 : 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 : 4156 : image_selector:
394 : 4156 : for (;;)
395 : : {
396 : 4156 : m = match_team_or_stat (ar);
397 : 4156 : if (m == MATCH_ERROR)
398 : : return MATCH_ERROR;
399 : :
400 : 4146 : if (gfc_match_char (']') == MATCH_YES)
401 : 4074 : goto rank_check;
402 : :
403 : 72 : if (gfc_match_char (',') != MATCH_YES)
404 : : {
405 : 12 : gfc_error ("Invalid form of coarray reference at %C");
406 : 12 : return MATCH_ERROR;
407 : : }
408 : : }
409 : :
410 : : return MATCH_ERROR;
411 : :
412 : 4074 : rank_check:
413 : 4074 : ar->codimen++;
414 : 4074 : 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 : 4056 : 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 : 7039140 : gfc_free_array_spec (gfc_array_spec *as)
437 : : {
438 : 7039140 : int i;
439 : :
440 : 7039140 : if (as == NULL)
441 : : return;
442 : :
443 : 423189 : if (as->corank == 0)
444 : : {
445 : 635775 : for (i = 0; i < as->rank; i++)
446 : : {
447 : 215443 : gfc_free_expr (as->lower[i]);
448 : 215443 : gfc_free_expr (as->upper[i]);
449 : : }
450 : : }
451 : : else
452 : : {
453 : 2857 : int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0);
454 : 6472 : for (i = 0; i < n; i++)
455 : : {
456 : 3615 : gfc_free_expr (as->lower[i]);
457 : 3615 : gfc_free_expr (as->upper[i]);
458 : : }
459 : : }
460 : :
461 : 423189 : 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 : 338137 : resolve_array_bound (gfc_expr *e, int check_constant)
470 : : {
471 : 338137 : if (e == NULL)
472 : : return true;
473 : :
474 : 194353 : if (!gfc_resolve_expr (e)
475 : 194353 : || !gfc_specification_expr (e))
476 : 36 : return false;
477 : :
478 : 194317 : 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 : 2793920 : gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
498 : : {
499 : 2793920 : gfc_expr *e;
500 : 2793920 : int i;
501 : :
502 : 2793920 : if (as == NULL)
503 : : return true;
504 : :
505 : 334785 : if (as->resolved)
506 : : return true;
507 : :
508 : 330860 : for (i = 0; i < as->rank + as->corank; i++)
509 : : {
510 : 169074 : if (i == GFC_MAX_DIMENSIONS)
511 : : return false;
512 : :
513 : 169071 : e = as->lower[i];
514 : 169071 : if (!resolve_array_bound (e, check_constant))
515 : : return false;
516 : :
517 : 169066 : e = as->upper[i];
518 : 169066 : if (!resolve_array_bound (e, check_constant))
519 : : return false;
520 : :
521 : 169035 : if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
522 : 97561 : continue;
523 : :
524 : : /* If the size is negative in this dimension, set it to zero. */
525 : 71474 : if (as->lower[i]->expr_type == EXPR_CONSTANT
526 : 70760 : && as->upper[i]->expr_type == EXPR_CONSTANT
527 : 62021 : && mpz_cmp (as->upper[i]->value.integer,
528 : 62021 : as->lower[i]->value.integer) < 0)
529 : : {
530 : 1239 : gfc_free_expr (as->upper[i]);
531 : 1239 : as->upper[i] = gfc_copy_expr (as->lower[i]);
532 : 1239 : mpz_sub_ui (as->upper[i]->value.integer,
533 : 1239 : as->upper[i]->value.integer, 1);
534 : : }
535 : : }
536 : :
537 : 161786 : as->resolved = true;
538 : :
539 : 161786 : 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 : 107125 : match_array_element_spec (gfc_array_spec *as)
565 : : {
566 : 107125 : gfc_expr **upper, **lower;
567 : 107125 : match m;
568 : 107125 : int rank;
569 : 107125 : bool is_pdt_template;
570 : :
571 : 107125 : rank = as->rank == -1 ? 0 : as->rank;
572 : 107125 : lower = &as->lower[rank + as->corank - 1];
573 : 107125 : upper = &as->upper[rank + as->corank - 1];
574 : :
575 : 107125 : if (gfc_match_char ('*') == MATCH_YES)
576 : : {
577 : 7900 : *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
578 : 7900 : return AS_ASSUMED_SIZE;
579 : : }
580 : :
581 : 99225 : if (gfc_match_char (':') == MATCH_YES)
582 : : {
583 : 38173 : locus old_loc = gfc_current_locus;
584 : 38173 : 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 : 61052 : m = gfc_match_expr (upper);
598 : 61052 : if (m == MATCH_NO)
599 : 1 : gfc_error ("Expected expression in array specification at %C");
600 : 61052 : if (m != MATCH_YES)
601 : : return AS_UNKNOWN;
602 : 61050 : if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
603 : : return AS_UNKNOWN;
604 : :
605 : 61043 : if (((*upper)->expr_type == EXPR_CONSTANT
606 : 61043 : && (*upper)->ts.type != BT_INTEGER) ||
607 : : ((*upper)->expr_type == EXPR_FUNCTION
608 : 679 : && (*upper)->ts.type == BT_UNKNOWN
609 : 678 : && (*upper)->symtree
610 : 678 : && 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 : 122076 : is_pdt_template = gfc_current_block ()
618 : 54829 : && gfc_current_block ()->attr.pdt_template
619 : 61265 : && gfc_current_block ()->f2k_derived;
620 : :
621 : 61038 : if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template)
622 : 210 : gfc_correct_parm_expr (gfc_current_block (), upper);
623 : :
624 : 61038 : if (gfc_match_char (':') == MATCH_NO)
625 : : {
626 : 53949 : *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
627 : 53949 : return AS_EXPLICIT;
628 : : }
629 : :
630 : 7089 : *lower = *upper;
631 : 7089 : *upper = NULL;
632 : :
633 : 7089 : if (gfc_match_char ('*') == MATCH_YES)
634 : : return AS_ASSUMED_SIZE;
635 : :
636 : 6609 : m = gfc_match_expr (upper);
637 : 6609 : if (m == MATCH_ERROR)
638 : : return AS_UNKNOWN;
639 : 6609 : if (m == MATCH_NO)
640 : : return AS_ASSUMED_SHAPE;
641 : 5760 : if (!gfc_expr_check_typed (*upper, gfc_current_ns, false))
642 : : return AS_UNKNOWN;
643 : :
644 : 5760 : if (((*upper)->expr_type == EXPR_CONSTANT
645 : 5760 : && (*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 : 5759 : 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 : 300601 : gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
669 : : {
670 : 300601 : array_type current_type;
671 : 300601 : gfc_array_spec *as;
672 : 300601 : int i;
673 : :
674 : 300601 : as = gfc_get_array_spec ();
675 : :
676 : 300601 : if (!match_dim)
677 : 73 : goto coarray;
678 : :
679 : 300528 : if (gfc_match_char ('(') != MATCH_YES)
680 : : {
681 : 218557 : if (!match_codim)
682 : 1160 : goto done;
683 : 217397 : goto coarray;
684 : : }
685 : :
686 : 81971 : 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 : 105127 : for (;;)
700 : : {
701 : 105127 : as->rank++;
702 : 105127 : current_type = match_array_element_spec (as);
703 : 105127 : 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 : 105110 : if (as->rank == 1)
713 : : {
714 : 77054 : as->type = current_type;
715 : : }
716 : : else
717 : 28056 : 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 : 17510 : case AS_EXPLICIT:
732 : 17510 : if (current_type == AS_ASSUMED_SIZE)
733 : : {
734 : 623 : as->type = AS_ASSUMED_SIZE;
735 : 623 : break;
736 : : }
737 : :
738 : 16887 : 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 : 10192 : case AS_DEFERRED:
756 : 10192 : 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 : 105104 : if (gfc_match_char (')') == MATCH_YES)
783 : : break;
784 : :
785 : 28063 : 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 : 28061 : 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 : 28059 : if (as->corank + as->rank >= 7
799 : 28059 : && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C "
800 : : "with more than 7 dimensions"))
801 : 2 : goto cleanup;
802 : : }
803 : :
804 : 77041 : if (!match_codim)
805 : 19127 : goto done;
806 : :
807 : 57914 : coarray:
808 : 278164 : if (gfc_match_char ('[') != MATCH_YES)
809 : 276712 : goto done;
810 : :
811 : 1452 : if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C"))
812 : 3 : goto cleanup;
813 : :
814 : 1449 : 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 : 1448 : 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 : 1998 : for (;;)
828 : : {
829 : 1998 : as->corank++;
830 : 1998 : current_type = match_array_element_spec (as);
831 : :
832 : 1998 : if (current_type == AS_UNKNOWN)
833 : 1 : goto cleanup;
834 : :
835 : 1997 : if (as->corank == 1)
836 : 1447 : as->cotype = current_type;
837 : : else
838 : 550 : 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 : 361 : case AS_EXPLICIT:
845 : 361 : if (current_type == AS_ASSUMED_SIZE)
846 : : {
847 : 186 : as->cotype = AS_ASSUMED_SIZE;
848 : 186 : break;
849 : : }
850 : :
851 : 175 : 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 : 189 : case AS_DEFERRED:
869 : 189 : 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 : 1997 : if (gfc_match_char (']') == MATCH_YES)
890 : : break;
891 : :
892 : 552 : 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 : 552 : 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 : 1445 : 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 : 1444 : if (as->cotype == AS_ASSUMED_SIZE)
913 : 837 : as->cotype = AS_EXPLICIT;
914 : :
915 : 1444 : if (as->rank == 0)
916 : 824 : as->type = as->cotype;
917 : :
918 : 620 : done:
919 : 300535 : if (as->rank == 0 && as->corank == 0)
920 : : {
921 : 217799 : *asp = NULL;
922 : 217799 : gfc_free_array_spec (as);
923 : 217799 : return MATCH_NO;
924 : : }
925 : :
926 : : /* If a lower bounds of an assumed shape array is blank, put in one. */
927 : 82736 : if (as->type == AS_ASSUMED_SHAPE)
928 : : {
929 : 1466 : for (i = 0; i < as->rank + as->corank; i++)
930 : : {
931 : 853 : if (as->lower[i] == NULL)
932 : 1 : as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
933 : : }
934 : : }
935 : :
936 : 82736 : *asp = as;
937 : :
938 : 82736 : 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 : 265565 : gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
952 : : {
953 : 265565 : int i;
954 : 265565 : symbol_attribute *attr;
955 : :
956 : 265565 : 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 : 79181 : attr = &sym->attr;
962 : 79181 : if (gfc_submodule_procedure(attr))
963 : : return true;
964 : :
965 : 79180 : if (as->rank
966 : 79180 : && !gfc_add_dimension (&sym->attr, sym->name, error_loc))
967 : : return false;
968 : :
969 : 79174 : if (as->corank
970 : 79174 : && !gfc_add_codimension (&sym->attr, sym->name, error_loc))
971 : : return false;
972 : :
973 : 79169 : if (sym->as == NULL)
974 : : {
975 : 79146 : sym->as = as;
976 : 79146 : return true;
977 : : }
978 : :
979 : 23 : if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
980 : 21 : || (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 : 19 : if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
989 : 2 : goto too_many;
990 : :
991 : 17 : 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 : 10 : gcc_assert (as->corank == 0 && sym->as->rank == 0);
1011 : :
1012 : 10 : sym->as->rank = as->rank;
1013 : 10 : sym->as->type = as->type;
1014 : 10 : sym->as->cray_pointee = as->cray_pointee;
1015 : 10 : sym->as->cp_was_assumed = as->cp_was_assumed;
1016 : :
1017 : : /* Check F2018:C822. */
1018 : 10 : if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS)
1019 : 1 : goto too_many;
1020 : :
1021 : 42 : for (i = sym->as->corank - 1; i >= 0; i--)
1022 : : {
1023 : 33 : sym->as->lower[as->rank + i] = sym->as->lower[i];
1024 : 33 : sym->as->upper[as->rank + i] = sym->as->upper[i];
1025 : : }
1026 : 31 : for (i = 0; i < as->rank; i++)
1027 : : {
1028 : 22 : sym->as->lower[i] = as->lower[i];
1029 : 22 : sym->as->upper[i] = as->upper[i];
1030 : : }
1031 : : }
1032 : :
1033 : 14 : free (as);
1034 : 14 : 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 : 288847 : gfc_copy_array_spec (gfc_array_spec *src)
1048 : : {
1049 : 288847 : gfc_array_spec *dest;
1050 : 288847 : int i;
1051 : :
1052 : 288847 : if (src == NULL)
1053 : : return NULL;
1054 : :
1055 : 45363 : dest = gfc_get_array_spec ();
1056 : :
1057 : 45363 : *dest = *src;
1058 : :
1059 : 90073 : for (i = 0; i < dest->rank + dest->corank; i++)
1060 : : {
1061 : 44710 : dest->lower[i] = gfc_copy_expr (dest->lower[i]);
1062 : 44710 : 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 : 698 : gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
1099 : : {
1100 : 698 : int i;
1101 : :
1102 : 698 : if (as1 == NULL && as2 == NULL)
1103 : : return 1;
1104 : :
1105 : 698 : if (as1 == NULL || as2 == NULL)
1106 : : return 0;
1107 : :
1108 : 698 : if (as1->rank != as2->rank)
1109 : : return 0;
1110 : :
1111 : 696 : if (as1->corank != as2->corank)
1112 : : return 0;
1113 : :
1114 : 696 : 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 : 8426 : check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
1147 : : {
1148 : 8426 : gfc_constructor *c;
1149 : 8426 : gfc_expr *e;
1150 : :
1151 : 17159 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1152 : : {
1153 : 8733 : e = c->expr;
1154 : :
1155 : 8733 : if (e->expr_type == EXPR_ARRAY
1156 : 8733 : && check_duplicate_iterator (e->value.constructor, master))
1157 : : return 1;
1158 : :
1159 : 8733 : if (c->iterator == NULL)
1160 : 8097 : 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 : 444109 : match_array_list (gfc_constructor_base *result)
1182 : : {
1183 : 444109 : gfc_constructor_base head;
1184 : 444109 : gfc_constructor *p;
1185 : 444109 : gfc_iterator iter;
1186 : 444109 : locus old_loc;
1187 : 444109 : gfc_expr *e;
1188 : 444109 : match m;
1189 : 444109 : int n;
1190 : :
1191 : 444109 : old_loc = gfc_current_locus;
1192 : :
1193 : 444109 : if (gfc_match_char ('(') == MATCH_NO)
1194 : : return MATCH_NO;
1195 : :
1196 : 10105 : memset (&iter, '\0', sizeof (gfc_iterator));
1197 : 10105 : head = NULL;
1198 : :
1199 : 10105 : m = match_array_cons_element (&head);
1200 : 10105 : if (m != MATCH_YES)
1201 : 159 : goto cleanup;
1202 : :
1203 : 9946 : if (gfc_match_char (',') != MATCH_YES)
1204 : : {
1205 : 575 : m = MATCH_NO;
1206 : 575 : goto cleanup;
1207 : : }
1208 : :
1209 : 58 : for (n = 1;; n++)
1210 : : {
1211 : 9429 : m = gfc_match_iterator (&iter, 0);
1212 : 9429 : 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 : 7683 : if (gfc_match_char (')') != MATCH_YES)
1238 : 0 : goto syntax;
1239 : :
1240 : 7683 : if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
1241 : : {
1242 : 0 : m = MATCH_ERROR;
1243 : 0 : goto cleanup;
1244 : : }
1245 : :
1246 : 7683 : e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
1247 : 7683 : e->value.constructor = head;
1248 : :
1249 : 7683 : p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
1250 : 7683 : p->iterator = gfc_get_iterator ();
1251 : 7683 : *p->iterator = iter;
1252 : :
1253 : 7683 : 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 : 2422 : cleanup:
1260 : 2422 : gfc_constructor_free (head);
1261 : 2422 : gfc_free_iterator (&iter, 0);
1262 : 2422 : gfc_current_locus = old_loc;
1263 : 2422 : 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 : 444109 : match_array_cons_element (gfc_constructor_base *result)
1272 : : {
1273 : 444109 : gfc_expr *expr;
1274 : 444109 : match m;
1275 : :
1276 : 444109 : m = match_array_list (result);
1277 : 444109 : if (m != MATCH_NO)
1278 : : return m;
1279 : :
1280 : 436424 : m = gfc_match_expr (&expr);
1281 : 436424 : if (m != MATCH_YES)
1282 : : return m;
1283 : :
1284 : 436257 : 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 : 436253 : if (expr->expr_type == EXPR_FUNCTION
1292 : 13531 : && expr->ts.type == BT_UNKNOWN
1293 : 13531 : && 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 : 436250 : gfc_constructor_append_expr (result, expr, &gfc_current_locus);
1300 : 436250 : 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 : 4291169 : gfc_match_array_constructor (gfc_expr **result)
1338 : : {
1339 : 4291169 : gfc_constructor *c;
1340 : 4291169 : gfc_constructor_base head;
1341 : 4291169 : gfc_expr *expr;
1342 : 4291169 : gfc_typespec ts;
1343 : 4291169 : locus where;
1344 : 4291169 : match m;
1345 : 4291169 : const char *end_delim;
1346 : 4291169 : bool seen_ts;
1347 : 4291169 : gfc_namespace *old_ns = gfc_current_ns;
1348 : :
1349 : 4291169 : head = NULL;
1350 : 4291169 : seen_ts = false;
1351 : :
1352 : 4291169 : if (gfc_match (" (/") == MATCH_NO)
1353 : : {
1354 : 4228992 : if (gfc_match (" [") == MATCH_NO)
1355 : : return MATCH_NO;
1356 : : else
1357 : : {
1358 : 66344 : 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 : 128521 : where = gfc_current_locus;
1368 : :
1369 : : /* Try to match an optional "type-spec ::" */
1370 : 128521 : gfc_clear_ts (&ts);
1371 : 128521 : m = gfc_match_type_spec (&ts);
1372 : 128521 : gfc_current_ns = old_ns;
1373 : :
1374 : 128521 : if (m == MATCH_YES)
1375 : : {
1376 : 6362 : seen_ts = (gfc_match (" ::") == MATCH_YES);
1377 : :
1378 : 6362 : if (seen_ts)
1379 : : {
1380 : 5113 : if (!gfc_notify_std (GFC_STD_F2003, "Array constructor "
1381 : : "including type specification at %C"))
1382 : 1 : goto cleanup;
1383 : :
1384 : 5112 : 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 : 5111 : if (ts.type == BT_CHARACTER
1392 : 968 : && 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 : 122159 : else if (m == MATCH_ERROR)
1401 : 21 : goto cleanup;
1402 : :
1403 : 6359 : if (!seen_ts)
1404 : 123387 : gfc_current_locus = where;
1405 : :
1406 : 128497 : if (gfc_match (end_delim) == MATCH_YES)
1407 : : {
1408 : 1641 : if (seen_ts)
1409 : 1640 : 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 : 432259 : for (;;)
1418 : : {
1419 : 432259 : m = match_array_cons_element (&head);
1420 : 432259 : if (m == MATCH_ERROR)
1421 : 17 : goto cleanup;
1422 : 432242 : if (m == MATCH_NO)
1423 : 0 : goto syntax;
1424 : :
1425 : 432242 : if (gfc_match_char (',') == MATCH_NO)
1426 : : break;
1427 : : }
1428 : :
1429 : 126839 : if (gfc_match (end_delim) == MATCH_NO)
1430 : 6 : goto syntax;
1431 : :
1432 : 128473 : done:
1433 : : /* Size must be calculated at resolution time. */
1434 : 128473 : if (seen_ts)
1435 : : {
1436 : 5105 : expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1437 : 5105 : expr->ts = ts;
1438 : :
1439 : : /* If the typespec is CHARACTER, check that array elements can
1440 : : be converted. See PR fortran/67803. */
1441 : 5105 : if (ts.type == BT_CHARACTER)
1442 : : {
1443 : 967 : c = gfc_constructor_first (head);
1444 : 3498 : for (; c; c = gfc_constructor_next (c))
1445 : : {
1446 : 1569 : if (gfc_numeric_ts (&c->expr->ts)
1447 : 1569 : || 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 : 1564 : 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 : 5100 : 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 : 123368 : expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1477 : :
1478 : 128461 : expr->value.constructor = head;
1479 : 128461 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
1480 : 962 : expr->ts.u.cl->length_from_typespec = seen_ts;
1481 : :
1482 : 128461 : *result = expr;
1483 : :
1484 : 128461 : return MATCH_YES;
1485 : :
1486 : 6 : syntax:
1487 : 6 : gfc_error ("Syntax error in array constructor at %C");
1488 : :
1489 : 48 : cleanup:
1490 : 48 : gfc_constructor_free (head);
1491 : 48 : 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 : 1038494 : check_element_type (gfc_expr *expr, bool convert)
1511 : : {
1512 : 1038494 : if (cons_state == CONS_BAD)
1513 : : return 0; /* Suppress further errors */
1514 : :
1515 : 1038494 : if (cons_state == CONS_START)
1516 : : {
1517 : 54537 : if (expr->ts.type == BT_UNKNOWN)
1518 : 0 : cons_state = CONS_BAD;
1519 : : else
1520 : : {
1521 : 54537 : cons_state = CONS_GOOD;
1522 : 54537 : constructor_ts = expr->ts;
1523 : : }
1524 : :
1525 : 54537 : return 0;
1526 : : }
1527 : :
1528 : 983957 : 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 : 92057 : check_constructor_type (gfc_constructor_base base, bool convert)
1547 : : {
1548 : 92057 : gfc_constructor *c;
1549 : 92057 : gfc_expr *e;
1550 : :
1551 : 1138243 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1552 : : {
1553 : 1046332 : 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 : 1046332 : if (convert && e->expr_type != EXPR_CONSTANT
1560 : 11008 : && e->expr_type != EXPR_ARRAY)
1561 : 9797 : gfc_simplify_expr (e, 0);
1562 : :
1563 : 1046332 : 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 : 7838 : if (!convert && e->ts.type == BT_CHARACTER
1576 : 397 : && e->ts.u.cl && e->ts.u.cl->length_from_typespec)
1577 : : {
1578 : 54 : if (!gfc_check_constructor_type (e))
1579 : : return false;
1580 : : }
1581 : : else
1582 : : {
1583 : 7784 : if (!check_constructor_type (e->value.constructor, convert))
1584 : : return false;
1585 : : }
1586 : :
1587 : 7781 : continue;
1588 : : }
1589 : :
1590 : 1038494 : 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 : 84273 : gfc_check_constructor_type (gfc_expr *e)
1603 : : {
1604 : 84273 : bool t;
1605 : :
1606 : 84273 : if (e->ts.type != BT_UNKNOWN)
1607 : : {
1608 : 29673 : cons_state = CONS_GOOD;
1609 : 29673 : constructor_ts = e->ts;
1610 : : }
1611 : : else
1612 : : {
1613 : 54600 : cons_state = CONS_START;
1614 : 54600 : 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 : 84273 : t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1620 : 84273 : if (t && e->ts.type == BT_UNKNOWN)
1621 : 54600 : e->ts = constructor_ts;
1622 : :
1623 : 84273 : 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 : 6405 : gfc_check_iter_variable (gfc_expr *expr)
1644 : : {
1645 : 6405 : gfc_symbol *sym;
1646 : 6405 : cons_stack *c;
1647 : :
1648 : 6405 : sym = expr->symtree->n.sym;
1649 : :
1650 : 6415 : 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 : 7088 : check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *))
1664 : : {
1665 : 7088 : cons_stack element;
1666 : 7088 : gfc_expr *e;
1667 : 7088 : bool t;
1668 : 7088 : gfc_constructor *c;
1669 : :
1670 : 354725 : for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1671 : : {
1672 : 347663 : e = c->expr;
1673 : :
1674 : 347663 : if (!e)
1675 : 0 : continue;
1676 : :
1677 : : /* Allow procedures as potential target of a procedure pointer. */
1678 : 347663 : if (e->expr_type == EXPR_VARIABLE
1679 : 211 : && e->ts.type == BT_PROCEDURE
1680 : 91 : && e->symtree->n.sym->attr.flavor == FL_PROCEDURE)
1681 : 91 : continue;
1682 : :
1683 : 347572 : if (e->expr_type != EXPR_ARRAY)
1684 : : {
1685 : 347375 : if (!(*check_function)(e))
1686 : : return false;
1687 : 347355 : continue;
1688 : : }
1689 : :
1690 : 197 : element.previous = base;
1691 : 197 : element.iterator = c->iterator;
1692 : :
1693 : 197 : base = &element;
1694 : 197 : t = check_constructor (e->value.constructor, check_function);
1695 : 197 : base = element.previous;
1696 : :
1697 : 197 : 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 : 6891 : gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *))
1712 : : {
1713 : 6891 : cons_stack *base_save;
1714 : 6891 : bool t;
1715 : :
1716 : 6891 : base_save = base;
1717 : 6891 : base = NULL;
1718 : :
1719 : 6891 : t = check_constructor (expr->value.constructor, check_function);
1720 : 6891 : base = base_save;
1721 : :
1722 : 6891 : 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 : 4348040 : count_elements (gfc_expr *e)
1756 : : {
1757 : 4348040 : mpz_t result;
1758 : :
1759 : 4348040 : if (e->rank == 0)
1760 : 4346420 : mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1761 : : else
1762 : : {
1763 : 1620 : if (!gfc_array_size (e, &result))
1764 : : {
1765 : 501 : gfc_free_expr (e);
1766 : 501 : return false;
1767 : : }
1768 : :
1769 : 1119 : mpz_add (*current_expand.count, *current_expand.count, result);
1770 : 1119 : mpz_clear (result);
1771 : : }
1772 : :
1773 : 4347539 : gfc_free_expr (e);
1774 : 4347539 : 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 : 4948248 : extract_element (gfc_expr *e)
1783 : : {
1784 : 4948248 : if (e->rank != 0)
1785 : : { /* Something unextractable */
1786 : 1175 : gfc_free_expr (e);
1787 : 1175 : return false;
1788 : : }
1789 : :
1790 : 4947073 : if (current_expand.extract_count == current_expand.extract_n)
1791 : 37 : current_expand.extracted = e;
1792 : : else
1793 : 4947036 : gfc_free_expr (e);
1794 : :
1795 : 4947073 : current_expand.extract_count++;
1796 : :
1797 : 4947073 : 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 : 1293471 : expand (gfc_expr *e)
1806 : : {
1807 : 1293471 : gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
1808 : : e, &e->where);
1809 : :
1810 : 1293471 : c->n.component = current_expand.component;
1811 : 1293471 : 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 : 13969263 : gfc_simplify_iterator_var (gfc_expr *e)
1820 : : {
1821 : 13969263 : iterator_stack *p;
1822 : :
1823 : 19231902 : for (p = iter_stack; p; p = p->prev)
1824 : 19114012 : if (e->symtree == p->variable)
1825 : : break;
1826 : :
1827 : 13969263 : if (p == NULL)
1828 : : return; /* Variable not found */
1829 : :
1830 : 13851373 : gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1831 : :
1832 : 13851373 : mpz_set (e->value.integer, p->value);
1833 : :
1834 : 13851373 : 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 : 11259015 : expand_expr (gfc_expr *e)
1843 : : {
1844 : 11259015 : if (e->expr_type == EXPR_ARRAY)
1845 : 11259015 : 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 : 27844 : expand_iterator (gfc_constructor *c)
1861 : : {
1862 : 27844 : gfc_expr *start, *end, *step;
1863 : 27844 : iterator_stack frame;
1864 : 27844 : mpz_t trip;
1865 : 27844 : bool t;
1866 : :
1867 : 27844 : end = step = NULL;
1868 : :
1869 : 27844 : t = false;
1870 : :
1871 : 27844 : mpz_init (trip);
1872 : 27844 : mpz_init (frame.value);
1873 : 27844 : frame.prev = NULL;
1874 : :
1875 : 27844 : start = gfc_copy_expr (c->iterator->start);
1876 : 27844 : if (!gfc_simplify_expr (start, 1))
1877 : 0 : goto cleanup;
1878 : :
1879 : 27844 : if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1880 : 936 : goto cleanup;
1881 : :
1882 : 26908 : end = gfc_copy_expr (c->iterator->end);
1883 : 26908 : if (!gfc_simplify_expr (end, 1))
1884 : 0 : goto cleanup;
1885 : :
1886 : 26908 : if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1887 : 2902 : goto cleanup;
1888 : :
1889 : 24006 : step = gfc_copy_expr (c->iterator->step);
1890 : 24006 : if (!gfc_simplify_expr (step, 1))
1891 : 0 : goto cleanup;
1892 : :
1893 : 24006 : if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1894 : 0 : goto cleanup;
1895 : :
1896 : 24006 : 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 : 24006 : mpz_sub (trip, end->value.integer, start->value.integer);
1904 : 24006 : mpz_add (trip, trip, step->value.integer);
1905 : 24006 : mpz_tdiv_q (trip, trip, step->value.integer);
1906 : :
1907 : 24006 : mpz_set (frame.value, start->value.integer);
1908 : :
1909 : 24006 : frame.prev = iter_stack;
1910 : 24006 : frame.variable = c->iterator->var->symtree;
1911 : 24006 : iter_stack = &frame;
1912 : :
1913 : 11281856 : while (mpz_sgn (trip) > 0)
1914 : : {
1915 : 11259015 : if (!expand_expr (c->expr))
1916 : 1165 : goto cleanup;
1917 : :
1918 : 11257850 : mpz_add (frame.value, frame.value, step->value.integer);
1919 : 11257850 : mpz_sub_ui (trip, trip, 1);
1920 : : }
1921 : :
1922 : : t = true;
1923 : :
1924 : 27844 : cleanup:
1925 : 27844 : gfc_free_expr (start);
1926 : 27844 : gfc_free_expr (end);
1927 : 27844 : gfc_free_expr (step);
1928 : :
1929 : 27844 : mpz_clear (trip);
1930 : 27844 : mpz_clear (frame.value);
1931 : :
1932 : 27844 : iter_stack = frame.prev;
1933 : :
1934 : 27844 : 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 : 11550280 : expand_constructor (gfc_constructor_base base)
1950 : : {
1951 : 11550280 : gfc_constructor *c;
1952 : 11550280 : gfc_expr *e;
1953 : :
1954 : 29250395 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1955 : : {
1956 : 17707961 : if (c->iterator != NULL)
1957 : : {
1958 : 27844 : if (!expand_iterator (c))
1959 : : return false;
1960 : 22841 : continue;
1961 : : }
1962 : :
1963 : 17680117 : e = c->expr;
1964 : :
1965 : 17680117 : if (e == NULL)
1966 : : return false;
1967 : :
1968 : 17680117 : if (empty_constructor)
1969 : 93183 : empty_ts = e->ts;
1970 : :
1971 : : /* Simplify constant array expression/section within constructor. */
1972 : 17680117 : if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref
1973 : 4235 : && e->symtree && e->symtree->n.sym
1974 : 4235 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1975 : 577 : gfc_simplify_expr (e, 0);
1976 : :
1977 : 17680117 : if (e->expr_type == EXPR_ARRAY)
1978 : : {
1979 : 10570 : if (!expand_constructor (e->value.constructor))
1980 : : return false;
1981 : :
1982 : 10539 : continue;
1983 : : }
1984 : :
1985 : 17669547 : empty_constructor = false;
1986 : 17669547 : e = gfc_copy_expr (e);
1987 : 17669547 : if (!gfc_simplify_expr (e, 1))
1988 : : {
1989 : 200 : gfc_free_expr (e);
1990 : 200 : return false;
1991 : : }
1992 : 17669347 : e->from_constructor = 1;
1993 : 17669347 : current_expand.offset = &c->offset;
1994 : 17669347 : current_expand.repeat = &c->repeat;
1995 : 17669347 : current_expand.component = c->n.component;
1996 : 17669347 : 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 : 91045 : gfc_get_array_element (gfc_expr *array, int element)
2012 : : {
2013 : 91045 : expand_info expand_save;
2014 : 91045 : gfc_expr *e;
2015 : 91045 : bool rc;
2016 : :
2017 : 91045 : expand_save = current_expand;
2018 : 91045 : current_expand.extract_n = element;
2019 : 91045 : current_expand.expand_work_function = extract_element;
2020 : 91045 : current_expand.extracted = NULL;
2021 : 91045 : current_expand.extract_count = 0;
2022 : :
2023 : 91045 : iter_stack = NULL;
2024 : :
2025 : 91045 : rc = expand_constructor (array->value.constructor);
2026 : 91045 : e = current_expand.extracted;
2027 : 91045 : current_expand = expand_save;
2028 : :
2029 : 91045 : if (!rc)
2030 : 1669 : 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 : 93205 : gfc_expand_constructor (gfc_expr *e, bool fatal)
2041 : : {
2042 : 93205 : expand_info expand_save;
2043 : 93205 : gfc_expr *f;
2044 : 93205 : bool rc;
2045 : :
2046 : 93205 : 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 : 91045 : f = gfc_get_array_element (e, flag_max_array_constructor);
2052 : 91045 : 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 : 91008 : expand_save = current_expand;
2068 : 91008 : current_expand.base = NULL;
2069 : :
2070 : 91008 : iter_stack = NULL;
2071 : :
2072 : 91008 : empty_constructor = true;
2073 : 91008 : gfc_clear_ts (&empty_ts);
2074 : 91008 : current_expand.expand_work_function = expand;
2075 : :
2076 : 91008 : if (!expand_constructor (e->value.constructor))
2077 : : {
2078 : 494 : gfc_constructor_free (current_expand.base);
2079 : 494 : rc = false;
2080 : 494 : 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 : 90514 : if (constructor_ts.type == BT_UNKNOWN && empty_constructor)
2088 : 8 : e->ts = empty_ts;
2089 : :
2090 : 90514 : gfc_constructor_free (e->value.constructor);
2091 : 90514 : e->value.constructor = current_expand.base;
2092 : :
2093 : 90514 : rc = true;
2094 : :
2095 : 91008 : done:
2096 : 91008 : current_expand = expand_save;
2097 : :
2098 : 91008 : 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 : 7079588 : is_constant_element (gfc_expr *e)
2108 : : {
2109 : 7079588 : int rv;
2110 : :
2111 : 7079588 : rv = gfc_is_constant_expr (e);
2112 : 7079588 : gfc_free_expr (e);
2113 : :
2114 : 7079588 : 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 : 5525 : gfc_constant_ac (gfc_expr *e)
2126 : : {
2127 : 5525 : expand_info expand_save;
2128 : 5525 : bool rc;
2129 : :
2130 : 5525 : iter_stack = NULL;
2131 : 5525 : expand_save = current_expand;
2132 : 5525 : current_expand.expand_work_function = is_constant_element;
2133 : :
2134 : 5525 : rc = expand_constructor (e->value.constructor);
2135 : :
2136 : 5525 : current_expand = expand_save;
2137 : 5525 : 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 : 27407 : gfc_expanded_ac (gfc_expr *e)
2149 : : {
2150 : 27407 : gfc_constructor *c;
2151 : :
2152 : 27407 : if (e->expr_type == EXPR_ARRAY)
2153 : 5831 : for (c = gfc_constructor_first (e->value.constructor);
2154 : 27859 : c; c = gfc_constructor_next (c))
2155 : 22028 : 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 : 14970 : expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
2177 : : void *where)
2178 : : {
2179 : 14970 : gfc_expr *expr = *e;
2180 : 14970 : locus *sym_loc = (locus *)where;
2181 : :
2182 : 14970 : if (expr->expr_type == EXPR_VARIABLE
2183 : 1305 : && 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 : 14388 : find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc)
2198 : : {
2199 : 14388 : int ret;
2200 : :
2201 : 14388 : sought_symbol = sym;
2202 : 0 : ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc);
2203 : 14388 : sought_symbol = NULL;
2204 : 14388 : 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 : 69016 : resolve_array_list (gfc_constructor_base base)
2213 : : {
2214 : 69016 : bool t;
2215 : 69016 : gfc_constructor *c;
2216 : 69016 : gfc_iterator *iter;
2217 : :
2218 : 69016 : t = true;
2219 : :
2220 : 619205 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
2221 : : {
2222 : 550189 : iter = c->iterator;
2223 : 550189 : if (iter != NULL)
2224 : : {
2225 : 4796 : gfc_symbol *iter_var;
2226 : 4796 : locus iter_var_loc;
2227 : :
2228 : 4796 : if (!gfc_resolve_iterator (iter, false, true))
2229 : 1 : t = false;
2230 : :
2231 : : /* Check for bounds referencing the iterator variable. */
2232 : 4796 : gcc_assert (iter->var->expr_type == EXPR_VARIABLE);
2233 : 4796 : iter_var = iter->var->symtree->n.sym;
2234 : 4796 : if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc))
2235 : : {
2236 : 1 : if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial "
2237 : : "expression references control variable "
2238 : : "at %L", &iter_var_loc))
2239 : 4796 : t = false;
2240 : : }
2241 : 4796 : if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc))
2242 : : {
2243 : 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final "
2244 : : "expression references control variable "
2245 : : "at %L", &iter_var_loc))
2246 : 4796 : t = false;
2247 : : }
2248 : 4796 : if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc))
2249 : : {
2250 : 1 : if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step "
2251 : : "expression references control variable "
2252 : : "at %L", &iter_var_loc))
2253 : 4796 : t = false;
2254 : : }
2255 : : }
2256 : :
2257 : 550189 : if (!gfc_resolve_expr (c->expr))
2258 : 59 : t = false;
2259 : :
2260 : 550189 : if (UNLIMITED_POLY (c->expr))
2261 : : {
2262 : 1 : gfc_error ("Array constructor value at %L shall not be unlimited "
2263 : : "polymorphic [F2008: C4106]", &c->expr->where);
2264 : 1 : t = false;
2265 : : }
2266 : :
2267 : : /* F2018:C7114 The declared type of an ac-value shall not be abstract. */
2268 : 550189 : if (c->expr->ts.type == BT_CLASS
2269 : 83 : && c->expr->ts.u.derived
2270 : 83 : && c->expr->ts.u.derived->attr.abstract
2271 : 5 : && CLASS_DATA (c->expr))
2272 : : {
2273 : 5 : gfc_error ("Array constructor value %qs at %L is of the ABSTRACT "
2274 : 5 : "type %qs", c->expr->symtree->name, &c->expr->where,
2275 : 5 : CLASS_DATA (c->expr)->ts.u.derived->name);
2276 : 5 : t = false;
2277 : : }
2278 : :
2279 : : }
2280 : :
2281 : 69016 : return t;
2282 : : }
2283 : :
2284 : : /* Resolve character array constructor. If it has a specified constant character
2285 : : length, pad/truncate the elements here; if the length is not specified and
2286 : : all elements are of compile-time known length, emit an error as this is
2287 : : invalid. */
2288 : :
2289 : : bool
2290 : 10796 : gfc_resolve_character_array_constructor (gfc_expr *expr)
2291 : : {
2292 : 10796 : gfc_constructor *p;
2293 : 10796 : HOST_WIDE_INT found_length;
2294 : 10796 : bool has_ts;
2295 : :
2296 : 10796 : gcc_assert (expr->expr_type == EXPR_ARRAY);
2297 : 10796 : gcc_assert (expr->ts.type == BT_CHARACTER);
2298 : :
2299 : : /* Check if we have an explicit type-spec with length. */
2300 : 10796 : has_ts = expr->ts.u.cl && expr->ts.u.cl->length_from_typespec;
2301 : :
2302 : 10796 : if (expr->ts.u.cl == NULL)
2303 : : {
2304 : 294 : for (p = gfc_constructor_first (expr->value.constructor);
2305 : 413 : p; p = gfc_constructor_next (p))
2306 : 333 : if (p->expr->ts.u.cl != NULL)
2307 : : {
2308 : : /* Ensure that if there is a char_len around that it is
2309 : : used; otherwise the middle-end confuses them! */
2310 : 214 : expr->ts.u.cl = p->expr->ts.u.cl;
2311 : 214 : goto got_charlen;
2312 : : }
2313 : :
2314 : 80 : expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2315 : : }
2316 : :
2317 : 10502 : got_charlen:
2318 : :
2319 : : /* Early exit for zero size arrays. */
2320 : 10796 : if (expr->shape)
2321 : : {
2322 : 10427 : mpz_t size;
2323 : 10427 : HOST_WIDE_INT arraysize;
2324 : :
2325 : 10427 : gfc_array_size (expr, &size);
2326 : 10427 : arraysize = mpz_get_ui (size);
2327 : 10427 : mpz_clear (size);
2328 : :
2329 : 10427 : if (arraysize == 0)
2330 : 362 : return true;
2331 : : }
2332 : :
2333 : 10434 : found_length = -1;
2334 : :
2335 : 10434 : if (expr->ts.u.cl->length == NULL)
2336 : : {
2337 : : /* Check that all constant string elements have the same length until
2338 : : we reach the end or find a variable-length one. */
2339 : :
2340 : 6951 : for (p = gfc_constructor_first (expr->value.constructor);
2341 : 32106 : p; p = gfc_constructor_next (p))
2342 : : {
2343 : 25507 : HOST_WIDE_INT current_length = -1;
2344 : 25507 : gfc_ref *ref;
2345 : 25743 : for (ref = p->expr->ref; ref; ref = ref->next)
2346 : 251 : if (ref->type == REF_SUBSTRING
2347 : 77 : && ref->u.ss.start
2348 : 77 : && ref->u.ss.start->expr_type == EXPR_CONSTANT
2349 : 52 : && ref->u.ss.end
2350 : 39 : && ref->u.ss.end->expr_type == EXPR_CONSTANT)
2351 : : break;
2352 : :
2353 : 25507 : if (p->expr->expr_type == EXPR_CONSTANT)
2354 : 25095 : current_length = p->expr->value.character.length;
2355 : 412 : else if (ref)
2356 : 15 : current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer)
2357 : 15 : - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1;
2358 : 397 : else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
2359 : 51 : && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2360 : 51 : current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer);
2361 : : else
2362 : : return true;
2363 : :
2364 : 25161 : if (current_length < 0)
2365 : : current_length = 0;
2366 : :
2367 : 25161 : if (found_length == -1)
2368 : 6623 : found_length = current_length;
2369 : 18538 : else if (found_length != current_length)
2370 : : {
2371 : 6 : gfc_error ("Different CHARACTER lengths (%wd/%wd) in array"
2372 : : " constructor at %L", found_length,
2373 : 6 : current_length, &p->expr->where);
2374 : 6 : return false;
2375 : : }
2376 : :
2377 : 25155 : gcc_assert (found_length == current_length);
2378 : : }
2379 : :
2380 : 6599 : gcc_assert (found_length != -1);
2381 : :
2382 : : /* Update the character length of the array constructor. */
2383 : 6599 : expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2384 : : NULL, found_length);
2385 : : }
2386 : : else
2387 : : {
2388 : : /* We've got a character length specified. It should be an integer,
2389 : : otherwise an error is signalled elsewhere. */
2390 : 3483 : gcc_assert (expr->ts.u.cl->length);
2391 : :
2392 : : /* If we've got a constant character length, pad according to this.
2393 : : gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
2394 : : max_length only if they pass. */
2395 : 3483 : gfc_extract_hwi (expr->ts.u.cl->length, &found_length);
2396 : :
2397 : : /* Now pad/truncate the elements accordingly to the specified character
2398 : : length. This is ok inside this conditional, as in the case above
2399 : : (without typespec) all elements are verified to have the same length
2400 : : anyway. */
2401 : 3483 : if (found_length != -1)
2402 : 3416 : for (p = gfc_constructor_first (expr->value.constructor);
2403 : 15136 : p; p = gfc_constructor_next (p))
2404 : : {
2405 : : /* For non-constant expressions (like EXPR_OP from concatenation),
2406 : : try to simplify them first so we can then pad/truncate. */
2407 : 11720 : if (p->expr->expr_type != EXPR_CONSTANT
2408 : 1657 : && p->expr->ts.type == BT_CHARACTER)
2409 : 1626 : gfc_simplify_expr (p->expr, 0);
2410 : :
2411 : 11720 : if (p->expr->expr_type == EXPR_CONSTANT)
2412 : : {
2413 : 10063 : gfc_expr *cl = NULL;
2414 : 10063 : HOST_WIDE_INT current_length = -1;
2415 : :
2416 : 10063 : if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
2417 : : {
2418 : 2022 : cl = p->expr->ts.u.cl->length;
2419 : 2022 : gfc_extract_hwi (cl, ¤t_length);
2420 : : }
2421 : :
2422 : : /* If gfc_extract_int above set current_length, we implicitly
2423 : : know the type is BT_INTEGER and it's EXPR_CONSTANT. */
2424 : :
2425 : 2022 : if (! cl
2426 : 2022 : || (current_length != -1 && current_length != found_length))
2427 : 8263 : gfc_set_constant_character_len (found_length, p->expr,
2428 : : has_ts ? -1 : found_length);
2429 : : }
2430 : 1657 : else if (p->expr->expr_type == EXPR_ARRAY)
2431 : : {
2432 : : /* For nested array constructors, propagate the type-spec and
2433 : : recursively resolve. This handles cases like
2434 : : [character(16) :: ['a','b']] // "|". The inner constructor
2435 : : may have BT_UNKNOWN type initially. */
2436 : 92 : if (p->expr->ts.type == BT_UNKNOWN
2437 : 61 : || p->expr->ts.type == BT_CHARACTER)
2438 : : {
2439 : 92 : if (p->expr->ts.type == BT_CHARACTER
2440 : 61 : && p->expr->ts.u.cl
2441 : 61 : && p->expr->ts.u.cl->length_from_typespec)
2442 : : {
2443 : : /* If the inner array has an explicit type-spec, we must
2444 : : honor it first (e.g. truncate/pad to its length),
2445 : : before coercing it to the outer length. */
2446 : 48 : gfc_resolve_character_array_constructor (p->expr);
2447 : : }
2448 : :
2449 : 92 : p->expr->ts = expr->ts;
2450 : 92 : gfc_resolve_character_array_constructor (p->expr);
2451 : : }
2452 : : }
2453 : : }
2454 : : }
2455 : :
2456 : : return true;
2457 : : }
2458 : :
2459 : :
2460 : : /* Resolve all of the expressions in an array list. */
2461 : :
2462 : : bool
2463 : 69016 : gfc_resolve_array_constructor (gfc_expr *expr)
2464 : : {
2465 : 69016 : bool t;
2466 : :
2467 : 69016 : t = resolve_array_list (expr->value.constructor);
2468 : 69016 : if (t)
2469 : 68949 : t = gfc_check_constructor_type (expr);
2470 : :
2471 : : /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
2472 : : the call to this function, so we don't need to call it here; if it was
2473 : : called twice, an error message there would be duplicated. */
2474 : :
2475 : 69016 : return t;
2476 : : }
2477 : :
2478 : :
2479 : : /* Copy an iterator structure. */
2480 : :
2481 : : gfc_iterator *
2482 : 847576 : gfc_copy_iterator (gfc_iterator *src)
2483 : : {
2484 : 847576 : gfc_iterator *dest;
2485 : :
2486 : 847576 : if (src == NULL)
2487 : : return NULL;
2488 : :
2489 : 499 : dest = gfc_get_iterator ();
2490 : :
2491 : 499 : dest->var = gfc_copy_expr (src->var);
2492 : 499 : dest->start = gfc_copy_expr (src->start);
2493 : 499 : dest->end = gfc_copy_expr (src->end);
2494 : 499 : dest->step = gfc_copy_expr (src->step);
2495 : 499 : dest->annot = src->annot;
2496 : :
2497 : 499 : return dest;
2498 : : }
2499 : :
2500 : :
2501 : : /********* Subroutines for determining the size of an array *********/
2502 : :
2503 : : /* These are needed just to accommodate RESHAPE(). There are no
2504 : : diagnostics here, we just return false if something goes wrong. */
2505 : :
2506 : :
2507 : : /* Get the size of single dimension of an array specification. The
2508 : : array is guaranteed to be one dimensional. */
2509 : :
2510 : : bool
2511 : 550675 : spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
2512 : : {
2513 : 550675 : if (as == NULL)
2514 : : return false;
2515 : :
2516 : 537252 : if (dimen < 0 || dimen > as->rank - 1)
2517 : 0 : gfc_internal_error ("spec_dimen_size(): Bad dimension");
2518 : :
2519 : 537252 : if (as->type != AS_EXPLICIT
2520 : 342588 : || !as->lower[dimen]
2521 : 342588 : || !as->upper[dimen])
2522 : : return false;
2523 : :
2524 : 342588 : if (as->lower[dimen]->expr_type != EXPR_CONSTANT
2525 : 341809 : || as->upper[dimen]->expr_type != EXPR_CONSTANT
2526 : 323624 : || as->lower[dimen]->ts.type != BT_INTEGER
2527 : 323624 : || as->upper[dimen]->ts.type != BT_INTEGER)
2528 : : return false;
2529 : :
2530 : 323618 : mpz_init (*result);
2531 : :
2532 : 323618 : mpz_sub (*result, as->upper[dimen]->value.integer,
2533 : 323618 : as->lower[dimen]->value.integer);
2534 : :
2535 : 323618 : mpz_add_ui (*result, *result, 1);
2536 : :
2537 : 323618 : if (mpz_cmp_si (*result, 0) < 0)
2538 : 0 : mpz_set_si (*result, 0);
2539 : :
2540 : : return true;
2541 : : }
2542 : :
2543 : :
2544 : : bool
2545 : 30068 : spec_size (gfc_array_spec *as, mpz_t *result)
2546 : : {
2547 : 30068 : mpz_t size;
2548 : 30068 : int d;
2549 : :
2550 : 30068 : if (!as || as->type == AS_ASSUMED_RANK)
2551 : : return false;
2552 : :
2553 : 28618 : mpz_init_set_ui (*result, 1);
2554 : :
2555 : 77884 : for (d = 0; d < as->rank; d++)
2556 : : {
2557 : 34548 : if (!spec_dimen_size (as, d, &size))
2558 : : {
2559 : 13900 : mpz_clear (*result);
2560 : 13900 : return false;
2561 : : }
2562 : :
2563 : 20648 : mpz_mul (*result, *result, size);
2564 : 20648 : mpz_clear (size);
2565 : : }
2566 : :
2567 : : return true;
2568 : : }
2569 : :
2570 : :
2571 : : /* Get the number of elements in an array section. Optionally, also supply
2572 : : the end value. */
2573 : :
2574 : : bool
2575 : 74957 : gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
2576 : : {
2577 : 74957 : mpz_t upper, lower, stride;
2578 : 74957 : mpz_t diff;
2579 : 74957 : bool t;
2580 : 74957 : gfc_expr *stride_expr = NULL;
2581 : :
2582 : 74957 : if (dimen < 0 || ar == NULL)
2583 : 0 : gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
2584 : :
2585 : 74957 : if (dimen > ar->dimen - 1)
2586 : : {
2587 : 1 : gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]);
2588 : 1 : return false;
2589 : : }
2590 : :
2591 : 74956 : switch (ar->dimen_type[dimen])
2592 : : {
2593 : 164 : case DIMEN_ELEMENT:
2594 : 164 : mpz_init (*result);
2595 : 164 : mpz_set_ui (*result, 1);
2596 : 164 : t = true;
2597 : 164 : break;
2598 : :
2599 : 1381 : case DIMEN_VECTOR:
2600 : 1381 : t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
2601 : 1381 : break;
2602 : :
2603 : 73411 : case DIMEN_RANGE:
2604 : :
2605 : 73411 : mpz_init (stride);
2606 : :
2607 : 73411 : if (ar->stride[dimen] == NULL)
2608 : 51407 : mpz_set_ui (stride, 1);
2609 : : else
2610 : : {
2611 : 22004 : stride_expr = gfc_copy_expr(ar->stride[dimen]);
2612 : :
2613 : 22004 : if (!gfc_simplify_expr (stride_expr, 1)
2614 : 22002 : || stride_expr->expr_type != EXPR_CONSTANT
2615 : 42297 : || mpz_cmp_ui (stride_expr->value.integer, 0) == 0)
2616 : : {
2617 : 1713 : gfc_free_expr (stride_expr);
2618 : 1713 : mpz_clear (stride);
2619 : 1713 : return false;
2620 : : }
2621 : 20291 : mpz_set (stride, stride_expr->value.integer);
2622 : 20291 : gfc_free_expr(stride_expr);
2623 : : }
2624 : :
2625 : : /* Calculate the number of elements via gfc_dep_difference, but only if
2626 : : start and end are both supplied in the reference or the array spec.
2627 : : This is to guard against strange but valid code like
2628 : :
2629 : : subroutine foo(a,n)
2630 : : real a(1:n)
2631 : : n = 3
2632 : : print *,size(a(n-1:))
2633 : :
2634 : : where the user changes the value of a variable. If we have to
2635 : : determine end as well, we cannot do this using gfc_dep_difference.
2636 : : Fall back to the constants-only code then. */
2637 : :
2638 : 71698 : if (end == NULL)
2639 : : {
2640 : 63634 : bool use_dep;
2641 : :
2642 : 63634 : use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen],
2643 : : &diff);
2644 : 63634 : if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL)
2645 : 28066 : use_dep = gfc_dep_difference (ar->as->upper[dimen],
2646 : 28066 : ar->as->lower[dimen], &diff);
2647 : :
2648 : 42389 : if (use_dep)
2649 : : {
2650 : 32319 : mpz_init (*result);
2651 : 32319 : mpz_add (*result, diff, stride);
2652 : 32319 : mpz_div (*result, *result, stride);
2653 : 32319 : if (mpz_cmp_ui (*result, 0) < 0)
2654 : 112 : mpz_set_ui (*result, 0);
2655 : :
2656 : 32319 : mpz_clear (stride);
2657 : 32319 : mpz_clear (diff);
2658 : 32319 : return true;
2659 : : }
2660 : :
2661 : : }
2662 : :
2663 : : /* Constant-only code here, which covers more cases
2664 : : like a(:4) etc. */
2665 : 39379 : mpz_init (upper);
2666 : 39379 : mpz_init (lower);
2667 : 39379 : t = false;
2668 : :
2669 : 39379 : if (ar->start[dimen] == NULL)
2670 : : {
2671 : 29316 : if (ar->as->lower[dimen] == NULL
2672 : 12202 : || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT
2673 : 12199 : || ar->as->lower[dimen]->ts.type != BT_INTEGER)
2674 : 17117 : goto cleanup;
2675 : 12199 : mpz_set (lower, ar->as->lower[dimen]->value.integer);
2676 : : }
2677 : : else
2678 : : {
2679 : 10063 : if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2680 : 2376 : goto cleanup;
2681 : 7687 : mpz_set (lower, ar->start[dimen]->value.integer);
2682 : : }
2683 : :
2684 : 19886 : if (ar->end[dimen] == NULL)
2685 : : {
2686 : 6383 : if (ar->as->upper[dimen] == NULL
2687 : 4954 : || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT
2688 : 4424 : || ar->as->upper[dimen]->ts.type != BT_INTEGER)
2689 : 1960 : goto cleanup;
2690 : 4423 : mpz_set (upper, ar->as->upper[dimen]->value.integer);
2691 : : }
2692 : : else
2693 : : {
2694 : 13503 : if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2695 : 4401 : goto cleanup;
2696 : 9102 : mpz_set (upper, ar->end[dimen]->value.integer);
2697 : : }
2698 : :
2699 : 13525 : mpz_init (*result);
2700 : 13525 : mpz_sub (*result, upper, lower);
2701 : 13525 : mpz_add (*result, *result, stride);
2702 : 13525 : mpz_div (*result, *result, stride);
2703 : :
2704 : : /* Zero stride caught earlier. */
2705 : 13525 : if (mpz_cmp_ui (*result, 0) < 0)
2706 : 8 : mpz_set_ui (*result, 0);
2707 : 13525 : t = true;
2708 : :
2709 : 13525 : if (end)
2710 : : {
2711 : 6360 : mpz_init (*end);
2712 : :
2713 : 6360 : mpz_sub_ui (*end, *result, 1UL);
2714 : 6360 : mpz_mul (*end, *end, stride);
2715 : 6360 : mpz_add (*end, *end, lower);
2716 : : }
2717 : :
2718 : 7165 : cleanup:
2719 : 39379 : mpz_clear (upper);
2720 : 39379 : mpz_clear (lower);
2721 : 39379 : mpz_clear (stride);
2722 : 39379 : return t;
2723 : :
2724 : 0 : default:
2725 : 0 : gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2726 : : }
2727 : :
2728 : : return t;
2729 : : }
2730 : :
2731 : :
2732 : : static bool
2733 : 3426 : ref_size (gfc_array_ref *ar, mpz_t *result)
2734 : : {
2735 : 3426 : mpz_t size;
2736 : 3426 : int d;
2737 : :
2738 : 3426 : mpz_init_set_ui (*result, 1);
2739 : :
2740 : 10438 : for (d = 0; d < ar->dimen; d++)
2741 : : {
2742 : 3982 : if (!gfc_ref_dimen_size (ar, d, &size, NULL))
2743 : : {
2744 : 396 : mpz_clear (*result);
2745 : 396 : return false;
2746 : : }
2747 : :
2748 : 3586 : mpz_mul (*result, *result, size);
2749 : 3586 : mpz_clear (size);
2750 : : }
2751 : :
2752 : : return true;
2753 : : }
2754 : :
2755 : :
2756 : : /* Given an array expression and a dimension, figure out how many
2757 : : elements it has along that dimension. Returns true if we were
2758 : : able to return a result in the 'result' variable, false
2759 : : otherwise. */
2760 : :
2761 : : bool
2762 : 699115 : gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2763 : : {
2764 : 699115 : gfc_ref *ref;
2765 : 699115 : int i;
2766 : :
2767 : 699115 : gcc_assert (array != NULL);
2768 : :
2769 : 699115 : if (array->ts.type == BT_CLASS)
2770 : : return false;
2771 : :
2772 : 687173 : if (array->rank == -1)
2773 : : return false;
2774 : :
2775 : 687173 : if (dimen < 0 || dimen > array->rank - 1)
2776 : 0 : gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2777 : :
2778 : 687173 : switch (array->expr_type)
2779 : : {
2780 : 574113 : case EXPR_VARIABLE:
2781 : 574113 : case EXPR_FUNCTION:
2782 : 622002 : for (ref = array->ref; ref; ref = ref->next)
2783 : : {
2784 : : /* Ultimate component is a procedure pointer. */
2785 : 578954 : if (ref->type == REF_COMPONENT
2786 : 35608 : && !ref->next
2787 : 1053 : && ref->u.c.component->attr.function
2788 : 91 : && IS_PROC_POINTER (ref->u.c.component))
2789 : : return false;
2790 : :
2791 : 578863 : if (ref->type != REF_ARRAY)
2792 : 35517 : continue;
2793 : :
2794 : 543346 : if (ref->u.ar.type == AR_FULL)
2795 : 469356 : return spec_dimen_size (ref->u.ar.as, dimen, result);
2796 : :
2797 : 73990 : if (ref->u.ar.type == AR_SECTION)
2798 : : {
2799 : 144303 : for (i = 0; dimen >= 0; i++)
2800 : 82685 : if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2801 : 77387 : dimen--;
2802 : :
2803 : 61618 : return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2804 : : }
2805 : : }
2806 : :
2807 : 43048 : if (array->shape)
2808 : : {
2809 : 11894 : mpz_init_set (*result, array->shape[dimen]);
2810 : 11894 : return true;
2811 : : }
2812 : :
2813 : 31154 : if (array->symtree->n.sym->attr.generic
2814 : 26 : && array->value.function.esym != NULL)
2815 : : {
2816 : 25 : if (!spec_dimen_size (array->value.function.esym->as, dimen, result))
2817 : : return false;
2818 : : }
2819 : 31129 : else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result))
2820 : : return false;
2821 : :
2822 : : break;
2823 : :
2824 : 99650 : case EXPR_ARRAY:
2825 : 99650 : if (array->shape == NULL) {
2826 : : /* Expressions with rank > 1 should have "shape" properly set */
2827 : 59522 : if ( array->rank != 1 )
2828 : 0 : gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2829 : 59522 : return gfc_array_size(array, result);
2830 : : }
2831 : :
2832 : : /* Fall through */
2833 : 53538 : default:
2834 : 53538 : if (array->shape == NULL)
2835 : : return false;
2836 : :
2837 : 46261 : mpz_init_set (*result, array->shape[dimen]);
2838 : :
2839 : 46261 : break;
2840 : : }
2841 : :
2842 : : return true;
2843 : : }
2844 : :
2845 : :
2846 : : /* Given an array expression, figure out how many elements are in the
2847 : : array. Returns true if this is possible, and sets the 'result'
2848 : : variable. Otherwise returns false. */
2849 : :
2850 : : bool
2851 : 124849 : gfc_array_size (gfc_expr *array, mpz_t *result)
2852 : : {
2853 : 124849 : expand_info expand_save;
2854 : 124849 : gfc_ref *ref;
2855 : 124849 : int i;
2856 : 124849 : bool t;
2857 : :
2858 : 124849 : if (array->ts.type == BT_CLASS)
2859 : : return false;
2860 : :
2861 : 123816 : switch (array->expr_type)
2862 : : {
2863 : 93117 : case EXPR_ARRAY:
2864 : 93117 : gfc_push_suppress_errors ();
2865 : :
2866 : 93117 : expand_save = current_expand;
2867 : :
2868 : 93117 : current_expand.count = result;
2869 : 93117 : mpz_init_set_ui (*result, 0);
2870 : :
2871 : 93117 : current_expand.expand_work_function = count_elements;
2872 : 93117 : iter_stack = NULL;
2873 : :
2874 : 93117 : t = expand_constructor (array->value.constructor);
2875 : :
2876 : 93117 : gfc_pop_suppress_errors ();
2877 : :
2878 : 93117 : if (!t)
2879 : 2038 : mpz_clear (*result);
2880 : 93117 : current_expand = expand_save;
2881 : 93117 : return t;
2882 : :
2883 : 25842 : case EXPR_VARIABLE:
2884 : 28071 : for (ref = array->ref; ref; ref = ref->next)
2885 : : {
2886 : 28069 : if (ref->type != REF_ARRAY)
2887 : 1772 : continue;
2888 : :
2889 : 26297 : if (ref->u.ar.type == AR_FULL)
2890 : 22414 : return spec_size (ref->u.ar.as, result);
2891 : :
2892 : 3883 : if (ref->u.ar.type == AR_SECTION)
2893 : 3426 : return ref_size (&ref->u.ar, result);
2894 : : }
2895 : :
2896 : 2 : return spec_size (array->symtree->n.sym->as, result);
2897 : :
2898 : :
2899 : 4857 : default:
2900 : 4857 : if (array->rank == 0 || array->shape == NULL)
2901 : : return false;
2902 : :
2903 : 3437 : mpz_init_set_ui (*result, 1);
2904 : :
2905 : 10685 : for (i = 0; i < array->rank; i++)
2906 : 3811 : mpz_mul (*result, *result, array->shape[i]);
2907 : :
2908 : : break;
2909 : : }
2910 : :
2911 : : return true;
2912 : : }
2913 : :
2914 : :
2915 : : /* Given an array reference, return the shape of the reference in an
2916 : : array of mpz_t integers. */
2917 : :
2918 : : bool
2919 : 10933 : gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2920 : : {
2921 : 10933 : int d;
2922 : 10933 : int i;
2923 : :
2924 : 10933 : d = 0;
2925 : :
2926 : 10933 : switch (ar->type)
2927 : : {
2928 : : case AR_FULL:
2929 : 17292 : for (; d < ar->as->rank; d++)
2930 : 15021 : if (!spec_dimen_size (ar->as, d, &shape[d]))
2931 : 8583 : goto cleanup;
2932 : :
2933 : : return true;
2934 : :
2935 : : case AR_SECTION:
2936 : 199 : for (i = 0; i < ar->dimen; i++)
2937 : : {
2938 : 157 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
2939 : : {
2940 : 129 : if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL))
2941 : 37 : goto cleanup;
2942 : 92 : d++;
2943 : : }
2944 : : }
2945 : :
2946 : : return true;
2947 : :
2948 : : default:
2949 : : break;
2950 : : }
2951 : :
2952 : 8620 : cleanup:
2953 : 8620 : gfc_clear_shape (shape, d);
2954 : 8620 : return false;
2955 : : }
2956 : :
2957 : :
2958 : : /* Given an array expression, find the array reference structure that
2959 : : characterizes the reference. */
2960 : :
2961 : : gfc_array_ref *
2962 : 95985 : gfc_find_array_ref (gfc_expr *e, bool allow_null)
2963 : : {
2964 : 95985 : gfc_ref *ref;
2965 : :
2966 : 106879 : for (ref = e->ref; ref; ref = ref->next)
2967 : 99823 : if (ref->type == REF_ARRAY
2968 : 93802 : && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2969 : : break;
2970 : :
2971 : 95985 : if (ref == NULL)
2972 : : {
2973 : 7056 : if (allow_null)
2974 : : return NULL;
2975 : : else
2976 : 0 : gfc_internal_error ("gfc_find_array_ref(): No ref found");
2977 : : }
2978 : :
2979 : 88929 : return &ref->u.ar;
2980 : : }
2981 : :
2982 : :
2983 : : /* Find out if an array shape is known at compile time. */
2984 : :
2985 : : bool
2986 : 71 : gfc_is_compile_time_shape (gfc_array_spec *as)
2987 : : {
2988 : 71 : if (as->type != AS_EXPLICIT)
2989 : : return false;
2990 : :
2991 : 148 : for (int i = 0; i < as->rank; i++)
2992 : 88 : if (!gfc_is_constant_expr (as->lower[i])
2993 : 88 : || !gfc_is_constant_expr (as->upper[i]))
2994 : 9 : return false;
2995 : :
2996 : : return true;
2997 : : }
|
