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