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