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