Branch data Line data Source code
1 : : /* Routines for manipulation of expression nodes.
2 : : Copyright (C) 2000-2025 Free Software Foundation, Inc.
3 : : Contributed by Andy Vaught
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "options.h"
25 : : #include "gfortran.h"
26 : : #include "arith.h"
27 : : #include "match.h"
28 : : #include "target-memory.h" /* for gfc_convert_boz */
29 : : #include "constructor.h"
30 : : #include "tree.h"
31 : :
32 : :
33 : : /* The following set of functions provide access to gfc_expr* of
34 : : various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35 : :
36 : : There are two functions available elsewhere that provide
37 : : slightly different flavours of variables. Namely:
38 : : expr.cc (gfc_get_variable_expr)
39 : : symbol.cc (gfc_lval_expr_from_sym)
40 : : TODO: Merge these functions, if possible. */
41 : :
42 : : /* Get a new expression node. */
43 : :
44 : : gfc_expr *
45 : 88288208 : gfc_get_expr (void)
46 : : {
47 : 88288208 : gfc_expr *e;
48 : :
49 : 88288208 : e = XCNEW (gfc_expr);
50 : 88288208 : gfc_clear_ts (&e->ts);
51 : 88288208 : e->shape = NULL;
52 : 88288208 : e->ref = NULL;
53 : 88288208 : e->symtree = NULL;
54 : 88288208 : return e;
55 : : }
56 : :
57 : :
58 : : /* Get a new expression node that is an array constructor
59 : : of given type and kind. */
60 : :
61 : : gfc_expr *
62 : 166175 : gfc_get_array_expr (bt type, int kind, locus *where)
63 : : {
64 : 166175 : gfc_expr *e;
65 : :
66 : 166175 : e = gfc_get_expr ();
67 : 166175 : e->expr_type = EXPR_ARRAY;
68 : 166175 : e->value.constructor = NULL;
69 : 166175 : e->rank = 1;
70 : 166175 : e->shape = NULL;
71 : :
72 : 166175 : e->ts.type = type;
73 : 166175 : e->ts.kind = kind;
74 : 166175 : if (where)
75 : 164983 : e->where = *where;
76 : :
77 : 166175 : return e;
78 : : }
79 : :
80 : :
81 : : /* Get a new expression node that is the NULL expression. */
82 : :
83 : : gfc_expr *
84 : 48372 : gfc_get_null_expr (locus *where)
85 : : {
86 : 48372 : gfc_expr *e;
87 : :
88 : 48372 : e = gfc_get_expr ();
89 : 48372 : e->expr_type = EXPR_NULL;
90 : 48372 : e->ts.type = BT_UNKNOWN;
91 : :
92 : 48372 : if (where)
93 : 13538 : e->where = *where;
94 : :
95 : 48372 : return e;
96 : : }
97 : :
98 : :
99 : : /* Get a new expression node that is an operator expression node. */
100 : :
101 : : gfc_expr *
102 : 1565641 : gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
103 : : gfc_expr *op1, gfc_expr *op2)
104 : : {
105 : 1565641 : gfc_expr *e;
106 : :
107 : 1565641 : e = gfc_get_expr ();
108 : 1565641 : e->expr_type = EXPR_OP;
109 : 1565641 : e->value.op.op = op;
110 : 1565641 : e->value.op.op1 = op1;
111 : 1565641 : e->value.op.op2 = op2;
112 : :
113 : 1565641 : if (where)
114 : 1565641 : e->where = *where;
115 : :
116 : 1565641 : return e;
117 : : }
118 : :
119 : : /* Get a new expression node that is an conditional expression node. */
120 : :
121 : : gfc_expr *
122 : 222 : gfc_get_conditional_expr (locus *where, gfc_expr *condition,
123 : : gfc_expr *true_expr, gfc_expr *false_expr)
124 : : {
125 : 222 : gfc_expr *e;
126 : :
127 : 222 : e = gfc_get_expr ();
128 : 222 : e->expr_type = EXPR_CONDITIONAL;
129 : 222 : e->value.conditional.condition = condition;
130 : 222 : e->value.conditional.true_expr = true_expr;
131 : 222 : e->value.conditional.false_expr = false_expr;
132 : :
133 : 222 : if (where)
134 : 222 : e->where = *where;
135 : :
136 : 222 : return e;
137 : : }
138 : :
139 : : /* Get a new expression node that is an structure constructor
140 : : of given type and kind. */
141 : :
142 : : gfc_expr *
143 : 31923 : gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
144 : : {
145 : 31923 : gfc_expr *e;
146 : :
147 : 31923 : e = gfc_get_expr ();
148 : 31923 : e->expr_type = EXPR_STRUCTURE;
149 : 31923 : e->value.constructor = NULL;
150 : :
151 : 31923 : e->ts.type = type;
152 : 31923 : e->ts.kind = kind;
153 : 31923 : if (where)
154 : 31923 : e->where = *where;
155 : :
156 : 31923 : return e;
157 : : }
158 : :
159 : :
160 : : /* Get a new expression node that is an constant of given type and kind. */
161 : :
162 : : gfc_expr *
163 : 31348462 : gfc_get_constant_expr (bt type, int kind, locus *where)
164 : : {
165 : 31348462 : gfc_expr *e;
166 : :
167 : 31348462 : if (!where)
168 : 0 : gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
169 : : "NULL");
170 : :
171 : 31348462 : e = gfc_get_expr ();
172 : :
173 : 31348462 : e->expr_type = EXPR_CONSTANT;
174 : 31348462 : e->ts.type = type;
175 : 31348462 : e->ts.kind = kind;
176 : 31348462 : e->where = *where;
177 : :
178 : 31348462 : switch (type)
179 : : {
180 : 30417806 : case BT_INTEGER:
181 : 30417806 : case BT_UNSIGNED:
182 : 30417806 : mpz_init (e->value.integer);
183 : 30417806 : break;
184 : :
185 : 402067 : case BT_REAL:
186 : 402067 : gfc_set_model_kind (kind);
187 : 402067 : mpfr_init (e->value.real);
188 : 402067 : break;
189 : :
190 : 19112 : case BT_COMPLEX:
191 : 19112 : gfc_set_model_kind (kind);
192 : 19112 : mpc_init2 (e->value.complex, mpfr_get_default_prec());
193 : 19112 : break;
194 : :
195 : : default:
196 : : break;
197 : : }
198 : :
199 : 31348462 : return e;
200 : : }
201 : :
202 : :
203 : : /* Get a new expression node that is an string constant.
204 : : If no string is passed, a string of len is allocated,
205 : : blanked and null-terminated. */
206 : :
207 : : gfc_expr *
208 : 342919 : gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len)
209 : : {
210 : 342919 : gfc_expr *e;
211 : 342919 : gfc_char_t *dest;
212 : :
213 : 342919 : if (!src)
214 : : {
215 : 341244 : dest = gfc_get_wide_string (len + 1);
216 : 341244 : gfc_wide_memset (dest, ' ', len);
217 : 341244 : dest[len] = '\0';
218 : : }
219 : : else
220 : 1675 : dest = gfc_char_to_widechar (src);
221 : :
222 : 344640 : e = gfc_get_constant_expr (BT_CHARACTER, kind,
223 : : where ? where : &gfc_current_locus);
224 : 342919 : e->value.character.string = dest;
225 : 342919 : e->value.character.length = len;
226 : :
227 : 342919 : return e;
228 : : }
229 : :
230 : :
231 : : /* Get a new expression node that is an integer constant. */
232 : :
233 : : gfc_expr *
234 : 14381060 : gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value)
235 : : {
236 : 14381060 : gfc_expr *p;
237 : 28720770 : p = gfc_get_constant_expr (BT_INTEGER, kind,
238 : : where ? where : &gfc_current_locus);
239 : :
240 : 14381060 : const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT);
241 : 14381060 : wi::to_mpz (w, p->value.integer, SIGNED);
242 : :
243 : 14381060 : return p;
244 : 14381060 : }
245 : :
246 : : /* Get a new expression node that is an unsigned constant. */
247 : :
248 : : gfc_expr *
249 : 66 : gfc_get_unsigned_expr (int kind, locus *where, HOST_WIDE_INT value)
250 : : {
251 : 66 : gfc_expr *p;
252 : 132 : p = gfc_get_constant_expr (BT_UNSIGNED, kind,
253 : : where ? where : &gfc_current_locus);
254 : 66 : const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT);
255 : 66 : wi::to_mpz (w, p->value.integer, UNSIGNED);
256 : :
257 : 66 : return p;
258 : 66 : }
259 : :
260 : : /* Get a new expression node that is a logical constant. */
261 : :
262 : : gfc_expr *
263 : 74811 : gfc_get_logical_expr (int kind, locus *where, bool value)
264 : : {
265 : 74811 : gfc_expr *p;
266 : 86179 : p = gfc_get_constant_expr (BT_LOGICAL, kind,
267 : : where ? where : &gfc_current_locus);
268 : :
269 : 74811 : p->value.logical = value;
270 : :
271 : 74811 : return p;
272 : : }
273 : :
274 : :
275 : : gfc_expr *
276 : 32239 : gfc_get_iokind_expr (locus *where, io_kind k)
277 : : {
278 : 32239 : gfc_expr *e;
279 : :
280 : : /* Set the types to something compatible with iokind. This is needed to
281 : : get through gfc_free_expr later since iokind really has no Basic Type,
282 : : BT, of its own. */
283 : :
284 : 32239 : e = gfc_get_expr ();
285 : 32239 : e->expr_type = EXPR_CONSTANT;
286 : 32239 : e->ts.type = BT_LOGICAL;
287 : 32239 : e->value.iokind = k;
288 : 32239 : e->where = *where;
289 : :
290 : 32239 : return e;
291 : : }
292 : :
293 : :
294 : : /* Given an expression pointer, return a copy of the expression. This
295 : : subroutine is recursive. */
296 : :
297 : : gfc_expr *
298 : 55963339 : gfc_copy_expr (gfc_expr *p)
299 : : {
300 : 55963339 : gfc_expr *q;
301 : 55963339 : gfc_char_t *s;
302 : 55963339 : char *c;
303 : :
304 : 55963339 : if (p == NULL)
305 : : return NULL;
306 : :
307 : 48104649 : q = gfc_get_expr ();
308 : 48104649 : *q = *p;
309 : :
310 : 48104649 : switch (q->expr_type)
311 : : {
312 : 977 : case EXPR_SUBSTRING:
313 : 977 : s = gfc_get_wide_string (p->value.character.length + 1);
314 : 977 : q->value.character.string = s;
315 : 977 : memcpy (s, p->value.character.string,
316 : 977 : (p->value.character.length + 1) * sizeof (gfc_char_t));
317 : 977 : break;
318 : :
319 : 16852237 : case EXPR_CONSTANT:
320 : : /* Copy target representation, if it exists. */
321 : 16852237 : if (p->representation.string)
322 : : {
323 : 3478 : c = XCNEWVEC (char, p->representation.length + 1);
324 : 3478 : q->representation.string = c;
325 : 3478 : memcpy (c, p->representation.string, (p->representation.length + 1));
326 : : }
327 : :
328 : : /* Copy the values of any pointer components of p->value. */
329 : 16852237 : switch (q->ts.type)
330 : : {
331 : 15087315 : case BT_INTEGER:
332 : 15087315 : case BT_UNSIGNED:
333 : 15087315 : mpz_init_set (q->value.integer, p->value.integer);
334 : 15087315 : break;
335 : :
336 : 341695 : case BT_REAL:
337 : 341695 : gfc_set_model_kind (q->ts.kind);
338 : 341695 : mpfr_init (q->value.real);
339 : 341695 : mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
340 : 341695 : break;
341 : :
342 : 27536 : case BT_COMPLEX:
343 : 27536 : gfc_set_model_kind (q->ts.kind);
344 : 27536 : mpc_init2 (q->value.complex, mpfr_get_default_prec());
345 : 27536 : mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
346 : 27536 : break;
347 : :
348 : 294060 : case BT_CHARACTER:
349 : 294060 : if (p->representation.string
350 : 784 : && p->ts.kind == gfc_default_character_kind)
351 : 778 : q->value.character.string
352 : 778 : = gfc_char_to_widechar (q->representation.string);
353 : : else
354 : : {
355 : 293282 : s = gfc_get_wide_string (p->value.character.length + 1);
356 : 293282 : q->value.character.string = s;
357 : :
358 : : /* This is the case for the C_NULL_CHAR named constant. */
359 : 293282 : if (p->value.character.length == 0
360 : 2395 : && (p->ts.is_c_interop || p->ts.is_iso_c))
361 : : {
362 : 0 : *s = '\0';
363 : : /* Need to set the length to 1 to make sure the NUL
364 : : terminator is copied. */
365 : 0 : q->value.character.length = 1;
366 : : }
367 : : else
368 : 293282 : memcpy (s, p->value.character.string,
369 : 293282 : (p->value.character.length + 1) * sizeof (gfc_char_t));
370 : : }
371 : : break;
372 : :
373 : : case BT_HOLLERITH:
374 : : case BT_LOGICAL:
375 : : case_bt_struct:
376 : : case BT_CLASS:
377 : : case BT_ASSUMED:
378 : : break; /* Already done. */
379 : :
380 : 0 : case BT_BOZ:
381 : 0 : q->boz.len = p->boz.len;
382 : 0 : q->boz.rdx = p->boz.rdx;
383 : 0 : q->boz.str = XCNEWVEC (char, q->boz.len + 1);
384 : 0 : strncpy (q->boz.str, p->boz.str, p->boz.len);
385 : 0 : break;
386 : :
387 : 0 : case BT_PROCEDURE:
388 : 0 : case BT_VOID:
389 : : /* Should never be reached. */
390 : 0 : case BT_UNKNOWN:
391 : 0 : gfc_internal_error ("gfc_copy_expr(): Bad expr node");
392 : : /* Not reached. */
393 : : }
394 : :
395 : : break;
396 : :
397 : 16415563 : case EXPR_OP:
398 : 16415563 : switch (q->value.op.op)
399 : : {
400 : 5269339 : case INTRINSIC_NOT:
401 : 5269339 : case INTRINSIC_PARENTHESES:
402 : 5269339 : case INTRINSIC_UPLUS:
403 : 5269339 : case INTRINSIC_UMINUS:
404 : 5269339 : q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
405 : 5269339 : break;
406 : :
407 : 11146224 : default: /* Binary operators. */
408 : 11146224 : q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
409 : 11146224 : q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
410 : 11146224 : break;
411 : : }
412 : :
413 : : break;
414 : :
415 : 2 : case EXPR_CONDITIONAL:
416 : 2 : q->value.conditional.condition
417 : 2 : = gfc_copy_expr (p->value.conditional.condition);
418 : 2 : q->value.conditional.true_expr
419 : 2 : = gfc_copy_expr (p->value.conditional.true_expr);
420 : 2 : q->value.conditional.false_expr
421 : 2 : = gfc_copy_expr (p->value.conditional.false_expr);
422 : 2 : break;
423 : :
424 : 388754 : case EXPR_FUNCTION:
425 : 777508 : q->value.function.actual =
426 : 388754 : gfc_copy_actual_arglist (p->value.function.actual);
427 : 388754 : break;
428 : :
429 : 90 : case EXPR_COMPCALL:
430 : 90 : case EXPR_PPC:
431 : 180 : q->value.compcall.actual =
432 : 90 : gfc_copy_actual_arglist (p->value.compcall.actual);
433 : 90 : q->value.compcall.tbp = p->value.compcall.tbp;
434 : 90 : break;
435 : :
436 : 107230 : case EXPR_STRUCTURE:
437 : 107230 : case EXPR_ARRAY:
438 : 107230 : q->value.constructor = gfc_constructor_copy (p->value.constructor);
439 : 107230 : break;
440 : :
441 : : case EXPR_VARIABLE:
442 : : case EXPR_NULL:
443 : : break;
444 : :
445 : 0 : case EXPR_UNKNOWN:
446 : 0 : gcc_unreachable ();
447 : : }
448 : :
449 : 48104649 : q->shape = gfc_copy_shape (p->shape, p->rank);
450 : :
451 : 48104649 : q->ref = gfc_copy_ref (p->ref);
452 : :
453 : 48104649 : if (p->param_list)
454 : 176 : q->param_list = gfc_copy_actual_arglist (p->param_list);
455 : :
456 : : return q;
457 : : }
458 : :
459 : :
460 : : void
461 : 436603 : gfc_clear_shape (mpz_t *shape, int rank)
462 : : {
463 : 436603 : int i;
464 : :
465 : 1002467 : for (i = 0; i < rank; i++)
466 : 565864 : mpz_clear (shape[i]);
467 : 436603 : }
468 : :
469 : :
470 : : void
471 : 88075464 : gfc_free_shape (mpz_t **shape, int rank)
472 : : {
473 : 88075464 : if (*shape == NULL)
474 : : return;
475 : :
476 : 422735 : gfc_clear_shape (*shape, rank);
477 : 422735 : free (*shape);
478 : 422735 : *shape = NULL;
479 : : }
480 : :
481 : :
482 : : /* Workhorse function for gfc_free_expr() that frees everything
483 : : beneath an expression node, but not the node itself. This is
484 : : useful when we want to simplify a node and replace it with
485 : : something else or the expression node belongs to another structure. */
486 : :
487 : : static void
488 : 88054505 : free_expr0 (gfc_expr *e)
489 : : {
490 : 88054505 : switch (e->expr_type)
491 : : {
492 : 48448899 : case EXPR_CONSTANT:
493 : : /* Free any parts of the value that need freeing. */
494 : 48448899 : switch (e->ts.type)
495 : : {
496 : 45718365 : case BT_INTEGER:
497 : 45718365 : case BT_UNSIGNED:
498 : 45718365 : mpz_clear (e->value.integer);
499 : 45718365 : break;
500 : :
501 : 743942 : case BT_REAL:
502 : 743942 : mpfr_clear (e->value.real);
503 : 743942 : break;
504 : :
505 : 654079 : case BT_CHARACTER:
506 : 654079 : free (e->value.character.string);
507 : 654079 : break;
508 : :
509 : 46581 : case BT_COMPLEX:
510 : 46581 : mpc_clear (e->value.complex);
511 : 46581 : break;
512 : :
513 : 1670 : case BT_BOZ:
514 : 1670 : free (e->boz.str);
515 : 1670 : break;
516 : :
517 : : default:
518 : : break;
519 : : }
520 : :
521 : : /* Free the representation. */
522 : 48448899 : free (e->representation.string);
523 : :
524 : 48448899 : break;
525 : :
526 : 18009061 : case EXPR_OP:
527 : 18009061 : if (e->value.op.op1 != NULL)
528 : 1620592 : gfc_free_expr (e->value.op.op1);
529 : 18009061 : if (e->value.op.op2 != NULL)
530 : 1467866 : gfc_free_expr (e->value.op.op2);
531 : : break;
532 : :
533 : 224 : case EXPR_CONDITIONAL:
534 : 224 : gfc_free_expr (e->value.conditional.condition);
535 : 224 : gfc_free_expr (e->value.conditional.true_expr);
536 : 224 : gfc_free_expr (e->value.conditional.false_expr);
537 : 224 : break;
538 : :
539 : 1865089 : case EXPR_FUNCTION:
540 : 1865089 : gfc_free_actual_arglist (e->value.function.actual);
541 : 1865089 : break;
542 : :
543 : 3497 : case EXPR_COMPCALL:
544 : 3497 : case EXPR_PPC:
545 : 3497 : gfc_free_actual_arglist (e->value.compcall.actual);
546 : 3497 : break;
547 : :
548 : : case EXPR_VARIABLE:
549 : : break;
550 : :
551 : 331049 : case EXPR_ARRAY:
552 : 331049 : case EXPR_STRUCTURE:
553 : 331049 : gfc_constructor_free (e->value.constructor);
554 : 331049 : break;
555 : :
556 : 1196 : case EXPR_SUBSTRING:
557 : 1196 : free (e->value.character.string);
558 : 1196 : break;
559 : :
560 : : case EXPR_NULL:
561 : : break;
562 : :
563 : 0 : default:
564 : 0 : gfc_internal_error ("free_expr0(): Bad expr type");
565 : : }
566 : :
567 : : /* Free a shape array. */
568 : 88054505 : gfc_free_shape (&e->shape, e->rank);
569 : :
570 : 88054505 : gfc_free_ref_list (e->ref);
571 : :
572 : 88054505 : gfc_free_actual_arglist (e->param_list);
573 : :
574 : 88054505 : memset (e, '\0', sizeof (gfc_expr));
575 : 88054505 : }
576 : :
577 : :
578 : : /* Free an expression node and everything beneath it. */
579 : :
580 : : void
581 : 119490434 : gfc_free_expr (gfc_expr *e)
582 : : {
583 : 119490434 : if (e == NULL)
584 : : return;
585 : 57215446 : free_expr0 (e);
586 : 57215446 : free (e);
587 : : }
588 : :
589 : :
590 : : /* Free an argument list and everything below it. */
591 : :
592 : : void
593 : 90060659 : gfc_free_actual_arglist (gfc_actual_arglist *a1)
594 : : {
595 : 90060659 : gfc_actual_arglist *a2;
596 : :
597 : 93211983 : while (a1)
598 : : {
599 : 3151324 : a2 = a1->next;
600 : 3151324 : if (a1->expr)
601 : 2870124 : gfc_free_expr (a1->expr);
602 : 3151324 : free (a1->associated_dummy);
603 : 3151324 : free (a1);
604 : 3151324 : a1 = a2;
605 : : }
606 : 90060659 : }
607 : :
608 : :
609 : : /* Copy an arglist structure and all of the arguments. */
610 : :
611 : : gfc_actual_arglist *
612 : 392394 : gfc_copy_actual_arglist (gfc_actual_arglist *p)
613 : : {
614 : 392394 : gfc_actual_arglist *head, *tail, *new_arg;
615 : :
616 : 392394 : head = tail = NULL;
617 : :
618 : 1148414 : for (; p; p = p->next)
619 : : {
620 : 756020 : new_arg = gfc_get_actual_arglist ();
621 : 756020 : *new_arg = *p;
622 : :
623 : 756020 : if (p->associated_dummy != NULL)
624 : : {
625 : 682766 : new_arg->associated_dummy = gfc_get_dummy_arg ();
626 : 682766 : *new_arg->associated_dummy = *p->associated_dummy;
627 : : }
628 : :
629 : 756020 : new_arg->expr = gfc_copy_expr (p->expr);
630 : 756020 : new_arg->next = NULL;
631 : :
632 : 756020 : if (head == NULL)
633 : : head = new_arg;
634 : : else
635 : 365674 : tail->next = new_arg;
636 : :
637 : 756020 : tail = new_arg;
638 : : }
639 : :
640 : 392394 : return head;
641 : : }
642 : :
643 : :
644 : : /* Free a list of reference structures. */
645 : :
646 : : void
647 : 88154709 : gfc_free_ref_list (gfc_ref *p)
648 : : {
649 : 88154709 : gfc_ref *q;
650 : 88154709 : int i;
651 : :
652 : 89432653 : for (; p; p = q)
653 : : {
654 : 1277944 : q = p->next;
655 : :
656 : 1277944 : switch (p->type)
657 : : {
658 : : case REF_ARRAY:
659 : 15429472 : for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
660 : : {
661 : 14465130 : gfc_free_expr (p->u.ar.start[i]);
662 : 14465130 : gfc_free_expr (p->u.ar.end[i]);
663 : 14465130 : gfc_free_expr (p->u.ar.stride[i]);
664 : : }
665 : :
666 : 964342 : gfc_free_expr (p->u.ar.stat);
667 : 964342 : gfc_free_expr (p->u.ar.team);
668 : 964342 : break;
669 : :
670 : 20803 : case REF_SUBSTRING:
671 : 20803 : gfc_free_expr (p->u.ss.start);
672 : 20803 : gfc_free_expr (p->u.ss.end);
673 : 20803 : break;
674 : :
675 : : case REF_COMPONENT:
676 : : case REF_INQUIRY:
677 : : break;
678 : : }
679 : :
680 : 1277944 : free (p);
681 : : }
682 : 88154709 : }
683 : :
684 : :
685 : : /* Graft the *src expression onto the *dest subexpression. */
686 : :
687 : : void
688 : 30838631 : gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
689 : : {
690 : 30838631 : free_expr0 (dest);
691 : 30838631 : *dest = *src;
692 : 30838631 : free (src);
693 : 30838631 : }
694 : :
695 : :
696 : : /* Try to extract an integer constant from the passed expression node.
697 : : Return true if some error occurred, false on success. If REPORT_ERROR
698 : : is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
699 : : for negative using gfc_error_now. */
700 : :
701 : : bool
702 : 461576 : gfc_extract_int (gfc_expr *expr, int *result, int report_error)
703 : : {
704 : 461576 : gfc_ref *ref;
705 : :
706 : : /* A KIND component is a parameter too. The expression for it
707 : : is stored in the initializer and should be consistent with
708 : : the tests below. */
709 : 461576 : if (gfc_expr_attr(expr).pdt_kind)
710 : : {
711 : 16 : for (ref = expr->ref; ref; ref = ref->next)
712 : : {
713 : 8 : if (ref->u.c.component->attr.pdt_kind)
714 : 8 : expr = ref->u.c.component->initializer;
715 : : }
716 : : }
717 : :
718 : 461576 : if (expr->expr_type != EXPR_CONSTANT)
719 : : {
720 : 906 : if (report_error > 0)
721 : 893 : gfc_error ("Constant expression required at %C");
722 : 13 : else if (report_error < 0)
723 : 4 : gfc_error_now ("Constant expression required at %C");
724 : 906 : return true;
725 : : }
726 : :
727 : 460670 : if (expr->ts.type != BT_INTEGER)
728 : : {
729 : 418 : if (report_error > 0)
730 : 418 : gfc_error ("Integer expression required at %C");
731 : 0 : else if (report_error < 0)
732 : 0 : gfc_error_now ("Integer expression required at %C");
733 : 418 : return true;
734 : : }
735 : :
736 : 460252 : if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
737 : 460252 : || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
738 : : {
739 : 0 : if (report_error > 0)
740 : 0 : gfc_error ("Integer value too large in expression at %C");
741 : 0 : else if (report_error < 0)
742 : 0 : gfc_error_now ("Integer value too large in expression at %C");
743 : 0 : return true;
744 : : }
745 : :
746 : 460252 : *result = (int) mpz_get_si (expr->value.integer);
747 : :
748 : 460252 : return false;
749 : : }
750 : :
751 : : /* Same as gfc_extract_int, but use a HWI. */
752 : :
753 : : bool
754 : 10177 : gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error)
755 : : {
756 : 10177 : gfc_ref *ref;
757 : :
758 : : /* A KIND component is a parameter too. The expression for it is
759 : : stored in the initializer and should be consistent with the tests
760 : : below. */
761 : 10177 : if (gfc_expr_attr(expr).pdt_kind)
762 : : {
763 : 0 : for (ref = expr->ref; ref; ref = ref->next)
764 : : {
765 : 0 : if (ref->u.c.component->attr.pdt_kind)
766 : 0 : expr = ref->u.c.component->initializer;
767 : : }
768 : : }
769 : :
770 : 10177 : if (expr->expr_type != EXPR_CONSTANT)
771 : : {
772 : 67 : if (report_error > 0)
773 : 0 : gfc_error ("Constant expression required at %C");
774 : 67 : else if (report_error < 0)
775 : 0 : gfc_error_now ("Constant expression required at %C");
776 : 67 : return true;
777 : : }
778 : :
779 : 10110 : if (expr->ts.type != BT_INTEGER)
780 : : {
781 : 0 : if (report_error > 0)
782 : 0 : gfc_error ("Integer expression required at %C");
783 : 0 : else if (report_error < 0)
784 : 0 : gfc_error_now ("Integer expression required at %C");
785 : 0 : return true;
786 : : }
787 : :
788 : : /* Use long_long_integer_type_node to determine when to saturate. */
789 : 10110 : const wide_int val = wi::from_mpz (long_long_integer_type_node,
790 : 10110 : expr->value.integer, false);
791 : :
792 : 10110 : if (!wi::fits_shwi_p (val))
793 : : {
794 : 0 : if (report_error > 0)
795 : 0 : gfc_error ("Integer value too large in expression at %C");
796 : 0 : else if (report_error < 0)
797 : 0 : gfc_error_now ("Integer value too large in expression at %C");
798 : 0 : return true;
799 : : }
800 : :
801 : 10110 : *result = val.to_shwi ();
802 : :
803 : 10110 : return false;
804 : 10110 : }
805 : :
806 : :
807 : : /* Recursively copy a list of reference structures. */
808 : :
809 : : gfc_ref *
810 : 48361755 : gfc_copy_ref (gfc_ref *src)
811 : : {
812 : 48361755 : gfc_array_ref *ar;
813 : 48361755 : gfc_ref *dest;
814 : :
815 : 48361755 : if (src == NULL)
816 : : return NULL;
817 : :
818 : 230382 : dest = gfc_get_ref ();
819 : 230382 : dest->type = src->type;
820 : :
821 : 230382 : switch (src->type)
822 : : {
823 : 167134 : case REF_ARRAY:
824 : 167134 : ar = gfc_copy_array_ref (&src->u.ar);
825 : 167134 : dest->u.ar = *ar;
826 : 167134 : free (ar);
827 : 167134 : break;
828 : :
829 : 55162 : case REF_COMPONENT:
830 : 55162 : dest->u.c = src->u.c;
831 : 55162 : break;
832 : :
833 : 2221 : case REF_INQUIRY:
834 : 2221 : dest->u.i = src->u.i;
835 : 2221 : break;
836 : :
837 : 5865 : case REF_SUBSTRING:
838 : 5865 : dest->u.ss = src->u.ss;
839 : 5865 : dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
840 : 5865 : dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
841 : 5865 : break;
842 : : }
843 : :
844 : 230382 : dest->next = gfc_copy_ref (src->next);
845 : :
846 : 230382 : return dest;
847 : : }
848 : :
849 : :
850 : : /* Detect whether an expression has any vector index array references. */
851 : :
852 : : bool
853 : 35647 : gfc_has_vector_index (gfc_expr *e)
854 : : {
855 : 35647 : gfc_ref *ref;
856 : 35647 : int i;
857 : 42888 : for (ref = e->ref; ref; ref = ref->next)
858 : 7251 : if (ref->type == REF_ARRAY)
859 : 12289 : for (i = 0; i < ref->u.ar.dimen; i++)
860 : 6636 : if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
861 : : return 1;
862 : : return 0;
863 : : }
864 : :
865 : :
866 : : bool
867 : 2203 : gfc_is_ptr_fcn (gfc_expr *e)
868 : : {
869 : 2203 : return e != NULL && e->expr_type == EXPR_FUNCTION
870 : 2653 : && gfc_expr_attr (e).pointer;
871 : : }
872 : :
873 : :
874 : : /* Copy a shape array. */
875 : :
876 : : mpz_t *
877 : 48363453 : gfc_copy_shape (mpz_t *shape, int rank)
878 : : {
879 : 48363453 : mpz_t *new_shape;
880 : 48363453 : int n;
881 : :
882 : 48363453 : if (shape == NULL)
883 : : return NULL;
884 : :
885 : 148487 : new_shape = gfc_get_shape (rank);
886 : :
887 : 500856 : for (n = 0; n < rank; n++)
888 : 203882 : mpz_init_set (new_shape[n], shape[n]);
889 : :
890 : : return new_shape;
891 : : }
892 : :
893 : :
894 : : /* Copy a shape array excluding dimension N, where N is an integer
895 : : constant expression. Dimensions are numbered in Fortran style --
896 : : starting with ONE.
897 : :
898 : : So, if the original shape array contains R elements
899 : : { s1 ... sN-1 sN sN+1 ... sR-1 sR}
900 : : the result contains R-1 elements:
901 : : { s1 ... sN-1 sN+1 ... sR-1}
902 : :
903 : : If anything goes wrong -- N is not a constant, its value is out
904 : : of range -- or anything else, just returns NULL. */
905 : :
906 : : mpz_t *
907 : 2990 : gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
908 : : {
909 : 2990 : mpz_t *new_shape, *s;
910 : 2990 : int i, n;
911 : :
912 : 2990 : if (shape == NULL
913 : 2990 : || rank <= 1
914 : 2424 : || dim == NULL
915 : 2424 : || dim->expr_type != EXPR_CONSTANT
916 : 2151 : || dim->ts.type != BT_INTEGER)
917 : : return NULL;
918 : :
919 : 2151 : n = mpz_get_si (dim->value.integer);
920 : 2151 : n--; /* Convert to zero based index. */
921 : 2151 : if (n < 0 || n >= rank)
922 : : return NULL;
923 : :
924 : 2151 : s = new_shape = gfc_get_shape (rank - 1);
925 : :
926 : 9177 : for (i = 0; i < rank; i++)
927 : : {
928 : 4875 : if (i == n)
929 : 2151 : continue;
930 : 2724 : mpz_init_set (*s, shape[i]);
931 : 2724 : s++;
932 : : }
933 : :
934 : : return new_shape;
935 : : }
936 : :
937 : :
938 : : /* Return the maximum kind of two expressions. In general, higher
939 : : kind numbers mean more precision for numeric types. */
940 : :
941 : : int
942 : 94453 : gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
943 : : {
944 : 94453 : return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
945 : : }
946 : :
947 : :
948 : : /* Returns nonzero if the type is numeric, zero otherwise. */
949 : :
950 : : static bool
951 : 25481883 : numeric_type (bt type)
952 : : {
953 : 0 : return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER
954 : 0 : || type == BT_UNSIGNED;
955 : : }
956 : :
957 : :
958 : : /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
959 : :
960 : : bool
961 : 25477356 : gfc_numeric_ts (gfc_typespec *ts)
962 : : {
963 : 25477356 : return numeric_type (ts->type);
964 : : }
965 : :
966 : :
967 : : /* Return an expression node with an optional argument list attached.
968 : : A variable number of gfc_expr pointers are strung together in an
969 : : argument list with a NULL pointer terminating the list. */
970 : :
971 : : gfc_expr *
972 : 131327 : gfc_build_conversion (gfc_expr *e)
973 : : {
974 : 131327 : gfc_expr *p;
975 : :
976 : 131327 : p = gfc_get_expr ();
977 : 131327 : p->expr_type = EXPR_FUNCTION;
978 : 131327 : p->symtree = NULL;
979 : 131327 : p->value.function.actual = gfc_get_actual_arglist ();
980 : 131327 : p->value.function.actual->expr = e;
981 : :
982 : 131327 : return p;
983 : : }
984 : :
985 : :
986 : : /* Given an expression node with some sort of numeric binary
987 : : expression, insert type conversions required to make the operands
988 : : have the same type. Conversion warnings are disabled if wconversion
989 : : is set to 0.
990 : :
991 : : The exception is that the operands of an exponential don't have to
992 : : have the same type. If possible, the base is promoted to the type
993 : : of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
994 : : 1.0**2 stays as it is. */
995 : :
996 : : void
997 : 12184181 : gfc_type_convert_binary (gfc_expr *e, int wconversion)
998 : : {
999 : 12184181 : gfc_expr *op1, *op2;
1000 : :
1001 : 12184181 : op1 = e->value.op.op1;
1002 : 12184181 : op2 = e->value.op.op2;
1003 : :
1004 : 12184181 : if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
1005 : : {
1006 : 0 : gfc_clear_ts (&e->ts);
1007 : 0 : return;
1008 : : }
1009 : :
1010 : : /* Kind conversions of same type. */
1011 : 12184181 : if (op1->ts.type == op2->ts.type)
1012 : : {
1013 : 12164193 : if (op1->ts.kind == op2->ts.kind)
1014 : : {
1015 : : /* No type conversions. */
1016 : 12051519 : e->ts = op1->ts;
1017 : 12051519 : goto done;
1018 : : }
1019 : :
1020 : : /* Unsigned exponentiation is special, we need the type of the first
1021 : : argument here because of modulo arithmetic. */
1022 : 112674 : if (op1->ts.type == BT_UNSIGNED && e->value.op.op == INTRINSIC_POWER)
1023 : : {
1024 : 84378 : e->ts = op1->ts;
1025 : 84378 : goto done;
1026 : : }
1027 : :
1028 : 28296 : if (op1->ts.kind > op2->ts.kind)
1029 : 21396 : gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
1030 : : else
1031 : 6900 : gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
1032 : :
1033 : 28296 : e->ts = op1->ts;
1034 : 28296 : goto done;
1035 : : }
1036 : :
1037 : : /* Integer combined with real or complex. */
1038 : 19988 : if (op2->ts.type == BT_INTEGER)
1039 : : {
1040 : 14969 : e->ts = op1->ts;
1041 : :
1042 : : /* Special case for ** operator. */
1043 : 14969 : if (e->value.op.op == INTRINSIC_POWER)
1044 : 3186 : goto done;
1045 : :
1046 : 11783 : gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
1047 : 11783 : goto done;
1048 : : }
1049 : :
1050 : 5019 : if (op1->ts.type == BT_INTEGER)
1051 : : {
1052 : 4425 : e->ts = op2->ts;
1053 : 4425 : gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
1054 : 4425 : goto done;
1055 : : }
1056 : :
1057 : : /* Real combined with complex. */
1058 : 594 : e->ts.type = BT_COMPLEX;
1059 : 594 : if (op1->ts.kind > op2->ts.kind)
1060 : 25 : e->ts.kind = op1->ts.kind;
1061 : : else
1062 : 569 : e->ts.kind = op2->ts.kind;
1063 : 594 : if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
1064 : 116 : gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
1065 : 594 : if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
1066 : 490 : gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
1067 : :
1068 : 104 : done:
1069 : : return;
1070 : : }
1071 : :
1072 : :
1073 : : /* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in
1074 : : constant expressions, except TRANSFER (c.f. item (8)), which would need
1075 : : separate treatment. */
1076 : :
1077 : : static bool
1078 : 279360 : is_non_constant_intrinsic (gfc_expr *e)
1079 : : {
1080 : 279360 : if (e->expr_type == EXPR_FUNCTION
1081 : 279360 : && e->value.function.isym)
1082 : : {
1083 : 279360 : switch (e->value.function.isym->id)
1084 : : {
1085 : : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
1086 : : case GFC_ISYM_GET_TEAM:
1087 : : case GFC_ISYM_NULL:
1088 : : case GFC_ISYM_NUM_IMAGES:
1089 : : case GFC_ISYM_TEAM_NUMBER:
1090 : : case GFC_ISYM_THIS_IMAGE:
1091 : : return true;
1092 : :
1093 : 277261 : default:
1094 : 277261 : return false;
1095 : : }
1096 : : }
1097 : : return false;
1098 : : }
1099 : :
1100 : :
1101 : : /* Determine if an expression is constant in the sense of F08:7.1.12.
1102 : : * This function expects that the expression has already been simplified. */
1103 : :
1104 : : bool
1105 : 45000193 : gfc_is_constant_expr (gfc_expr *e)
1106 : : {
1107 : 45000193 : gfc_constructor *c;
1108 : 45000193 : gfc_actual_arglist *arg;
1109 : :
1110 : 45000193 : if (e == NULL)
1111 : : return true;
1112 : :
1113 : 44981167 : switch (e->expr_type)
1114 : : {
1115 : 1099981 : case EXPR_OP:
1116 : 1099981 : return (gfc_is_constant_expr (e->value.op.op1)
1117 : 1099981 : && (e->value.op.op2 == NULL
1118 : 101629 : || gfc_is_constant_expr (e->value.op.op2)));
1119 : :
1120 : 3 : case EXPR_CONDITIONAL:
1121 : 3 : return gfc_is_constant_expr (e->value.conditional.condition)
1122 : 0 : && gfc_is_constant_expr (e->value.conditional.true_expr)
1123 : 3 : && gfc_is_constant_expr (e->value.conditional.false_expr);
1124 : :
1125 : 1459613 : case EXPR_VARIABLE:
1126 : : /* The only context in which this can occur is in a parameterized
1127 : : derived type declaration, so returning true is OK. */
1128 : 1459613 : if (e->symtree->n.sym->attr.pdt_len
1129 : 1457757 : || e->symtree->n.sym->attr.pdt_kind)
1130 : : return true;
1131 : : return false;
1132 : :
1133 : 342804 : case EXPR_FUNCTION:
1134 : 342804 : case EXPR_PPC:
1135 : 342804 : case EXPR_COMPCALL:
1136 : 342804 : gcc_assert (e->symtree || e->value.function.esym
1137 : : || e->value.function.isym);
1138 : :
1139 : : /* Check for intrinsics excluded in constant expressions. */
1140 : 342804 : if (e->value.function.isym && is_non_constant_intrinsic (e))
1141 : : return false;
1142 : :
1143 : : /* Call to intrinsic with at least one argument. */
1144 : 340705 : if (e->value.function.isym && e->value.function.actual)
1145 : : {
1146 : 284714 : for (arg = e->value.function.actual; arg; arg = arg->next)
1147 : 281484 : if (!gfc_is_constant_expr (arg->expr))
1148 : : return false;
1149 : : }
1150 : :
1151 : 66834 : if (e->value.function.isym
1152 : 3390 : && (e->value.function.isym->elemental
1153 : 3326 : || e->value.function.isym->pure
1154 : 3170 : || e->value.function.isym->inquiry
1155 : 3170 : || e->value.function.isym->transformational))
1156 : : return true;
1157 : :
1158 : : return false;
1159 : :
1160 : : case EXPR_CONSTANT:
1161 : : case EXPR_NULL:
1162 : : return true;
1163 : :
1164 : 2018 : case EXPR_SUBSTRING:
1165 : 2018 : return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
1166 : 813 : && gfc_is_constant_expr (e->ref->u.ss.end));
1167 : :
1168 : 141835 : case EXPR_ARRAY:
1169 : 141835 : case EXPR_STRUCTURE:
1170 : 141835 : c = gfc_constructor_first (e->value.constructor);
1171 : 141835 : if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
1172 : 5525 : return gfc_constant_ac (e);
1173 : :
1174 : 1693234 : for (; c; c = gfc_constructor_next (c))
1175 : 1567417 : if (!gfc_is_constant_expr (c->expr))
1176 : : return false;
1177 : :
1178 : : return true;
1179 : :
1180 : :
1181 : 0 : default:
1182 : 0 : gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1183 : : return false;
1184 : : }
1185 : : }
1186 : :
1187 : :
1188 : : /* Is true if the expression or symbol is a passed CFI descriptor. */
1189 : : bool
1190 : 698032 : is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
1191 : : {
1192 : 698032 : if (sym == NULL
1193 : 698032 : && e && e->expr_type == EXPR_VARIABLE)
1194 : 176257 : sym = e->symtree->n.sym;
1195 : :
1196 : 698032 : if (sym && sym->attr.dummy
1197 : 296463 : && sym->ns->proc_name->attr.is_bind_c
1198 : 77362 : && (sym->attr.pointer
1199 : 72976 : || sym->attr.allocatable
1200 : 69713 : || (sym->attr.dimension
1201 : 42474 : && (sym->as->type == AS_ASSUMED_SHAPE
1202 : 26194 : || sym->as->type == AS_ASSUMED_RANK))
1203 : 42568 : || (sym->ts.type == BT_CHARACTER
1204 : 14661 : && (!sym->ts.u.cl || !sym->ts.u.cl->length))))
1205 : 47241 : return true;
1206 : :
1207 : : return false;
1208 : : }
1209 : :
1210 : :
1211 : : /* Is true if an array reference is followed by a component or substring
1212 : : reference. */
1213 : : bool
1214 : 228636 : is_subref_array (gfc_expr * e)
1215 : : {
1216 : 228636 : gfc_ref * ref;
1217 : 228636 : bool seen_array;
1218 : 228636 : gfc_symbol *sym;
1219 : :
1220 : 228636 : if (e->expr_type != EXPR_VARIABLE)
1221 : : return false;
1222 : :
1223 : 227613 : sym = e->symtree->n.sym;
1224 : :
1225 : 227613 : if (sym->attr.subref_array_pointer)
1226 : : return true;
1227 : :
1228 : 223986 : seen_array = false;
1229 : :
1230 : 471162 : for (ref = e->ref; ref; ref = ref->next)
1231 : : {
1232 : : /* If we haven't seen the array reference and this is an intrinsic,
1233 : : what follows cannot be a subreference array, unless there is a
1234 : : substring reference. */
1235 : 249720 : if (!seen_array && ref->type == REF_COMPONENT
1236 : 29106 : && ref->next == NULL
1237 : 4387 : && ref->u.c.component->ts.type != BT_CHARACTER
1238 : 4360 : && ref->u.c.component->ts.type != BT_CLASS
1239 : 4010 : && !gfc_bt_struct (ref->u.c.component->ts.type))
1240 : : return false;
1241 : :
1242 : 249585 : if (ref->type == REF_ARRAY
1243 : 218005 : && ref->u.ar.type != AR_ELEMENT)
1244 : : seen_array = true;
1245 : :
1246 : 34986 : if (seen_array
1247 : 217008 : && ref->type != REF_ARRAY)
1248 : : return seen_array;
1249 : : }
1250 : :
1251 : 221442 : if (sym->ts.type == BT_CLASS
1252 : 20415 : && sym->attr.dummy
1253 : 6304 : && CLASS_DATA (sym)->attr.dimension
1254 : 3967 : && CLASS_DATA (sym)->attr.class_pointer)
1255 : 628 : return true;
1256 : :
1257 : : return false;
1258 : : }
1259 : :
1260 : :
1261 : : /* Try to collapse intrinsic expressions. */
1262 : :
1263 : : static bool
1264 : 17276208 : simplify_intrinsic_op (gfc_expr *p, int type)
1265 : : {
1266 : 17276208 : gfc_intrinsic_op op;
1267 : 17276208 : gfc_expr *op1, *op2, *result;
1268 : :
1269 : 17276208 : if (p->value.op.op == INTRINSIC_USER)
1270 : : return true;
1271 : :
1272 : 17276205 : op1 = p->value.op.op1;
1273 : 17276205 : op2 = p->value.op.op2;
1274 : 17276205 : op = p->value.op.op;
1275 : :
1276 : 17276205 : if (!gfc_simplify_expr (op1, type))
1277 : : return false;
1278 : 17275967 : if (!gfc_simplify_expr (op2, type))
1279 : : return false;
1280 : :
1281 : 17275919 : if (!gfc_is_constant_expr (op1)
1282 : 17275919 : || (op2 != NULL && !gfc_is_constant_expr (op2)))
1283 : 887428 : return true;
1284 : :
1285 : : /* Rip p apart. */
1286 : 16388491 : p->value.op.op1 = NULL;
1287 : 16388491 : p->value.op.op2 = NULL;
1288 : :
1289 : 16388491 : switch (op)
1290 : : {
1291 : 5256793 : case INTRINSIC_PARENTHESES:
1292 : 5256793 : result = gfc_parentheses (op1);
1293 : 5256793 : break;
1294 : :
1295 : 31 : case INTRINSIC_UPLUS:
1296 : 31 : result = gfc_uplus (op1);
1297 : 31 : break;
1298 : :
1299 : 13078 : case INTRINSIC_UMINUS:
1300 : 13078 : result = gfc_uminus (op1);
1301 : 13078 : break;
1302 : :
1303 : 10280023 : case INTRINSIC_PLUS:
1304 : 10280023 : result = gfc_add (op1, op2);
1305 : 10280023 : break;
1306 : :
1307 : 502505 : case INTRINSIC_MINUS:
1308 : 502505 : result = gfc_subtract (op1, op2);
1309 : 502505 : break;
1310 : :
1311 : 296356 : case INTRINSIC_TIMES:
1312 : 296356 : result = gfc_multiply (op1, op2);
1313 : 296356 : break;
1314 : :
1315 : 5763 : case INTRINSIC_DIVIDE:
1316 : 5763 : result = gfc_divide (op1, op2);
1317 : 5763 : break;
1318 : :
1319 : 5433 : case INTRINSIC_POWER:
1320 : 5433 : result = gfc_power (op1, op2);
1321 : 5433 : break;
1322 : :
1323 : 2427 : case INTRINSIC_CONCAT:
1324 : 2427 : result = gfc_concat (op1, op2);
1325 : 2427 : break;
1326 : :
1327 : 1189 : case INTRINSIC_EQ:
1328 : 1189 : case INTRINSIC_EQ_OS:
1329 : 1189 : result = gfc_eq (op1, op2, op);
1330 : 1189 : break;
1331 : :
1332 : 20442 : case INTRINSIC_NE:
1333 : 20442 : case INTRINSIC_NE_OS:
1334 : 20442 : result = gfc_ne (op1, op2, op);
1335 : 20442 : break;
1336 : :
1337 : 597 : case INTRINSIC_GT:
1338 : 597 : case INTRINSIC_GT_OS:
1339 : 597 : result = gfc_gt (op1, op2, op);
1340 : 597 : break;
1341 : :
1342 : 70 : case INTRINSIC_GE:
1343 : 70 : case INTRINSIC_GE_OS:
1344 : 70 : result = gfc_ge (op1, op2, op);
1345 : 70 : break;
1346 : :
1347 : 90 : case INTRINSIC_LT:
1348 : 90 : case INTRINSIC_LT_OS:
1349 : 90 : result = gfc_lt (op1, op2, op);
1350 : 90 : break;
1351 : :
1352 : 412 : case INTRINSIC_LE:
1353 : 412 : case INTRINSIC_LE_OS:
1354 : 412 : result = gfc_le (op1, op2, op);
1355 : 412 : break;
1356 : :
1357 : 490 : case INTRINSIC_NOT:
1358 : 490 : result = gfc_not (op1);
1359 : 490 : break;
1360 : :
1361 : 1010 : case INTRINSIC_AND:
1362 : 1010 : result = gfc_and (op1, op2);
1363 : 1010 : break;
1364 : :
1365 : 437 : case INTRINSIC_OR:
1366 : 437 : result = gfc_or (op1, op2);
1367 : 437 : break;
1368 : :
1369 : 12 : case INTRINSIC_EQV:
1370 : 12 : result = gfc_eqv (op1, op2);
1371 : 12 : break;
1372 : :
1373 : 1333 : case INTRINSIC_NEQV:
1374 : 1333 : result = gfc_neqv (op1, op2);
1375 : 1333 : break;
1376 : :
1377 : 0 : default:
1378 : 0 : gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1379 : : }
1380 : :
1381 : 16388491 : if (result == NULL)
1382 : : {
1383 : 55 : gfc_free_expr (op1);
1384 : 55 : gfc_free_expr (op2);
1385 : 55 : return false;
1386 : : }
1387 : :
1388 : 16388436 : result->rank = p->rank;
1389 : 16388436 : result->corank = p->corank;
1390 : 16388436 : result->where = p->where;
1391 : 16388436 : gfc_replace_expr (p, result);
1392 : :
1393 : 16388436 : return true;
1394 : : }
1395 : :
1396 : : /* Try to collapse conditional expressions. */
1397 : :
1398 : : static bool
1399 : 27 : simplify_conditional (gfc_expr *p, int type)
1400 : : {
1401 : 27 : gfc_expr *condition, *true_expr, *false_expr;
1402 : :
1403 : 27 : condition = p->value.conditional.condition;
1404 : 27 : true_expr = p->value.conditional.true_expr;
1405 : 27 : false_expr = p->value.conditional.false_expr;
1406 : :
1407 : 27 : if (!gfc_simplify_expr (condition, type)
1408 : 27 : || !gfc_simplify_expr (true_expr, type)
1409 : 54 : || !gfc_simplify_expr (false_expr, type))
1410 : 0 : return false;
1411 : :
1412 : 27 : if (!gfc_is_constant_expr (condition))
1413 : : return true;
1414 : :
1415 : 0 : p->value.conditional.condition = NULL;
1416 : 0 : p->value.conditional.true_expr = NULL;
1417 : 0 : p->value.conditional.false_expr = NULL;
1418 : :
1419 : 0 : if (condition->value.logical)
1420 : : {
1421 : 0 : gfc_replace_expr (p, true_expr);
1422 : 0 : gfc_free_expr (false_expr);
1423 : : }
1424 : : else
1425 : : {
1426 : 0 : gfc_replace_expr (p, false_expr);
1427 : 0 : gfc_free_expr (true_expr);
1428 : : }
1429 : 0 : gfc_free_expr (condition);
1430 : :
1431 : 0 : return true;
1432 : : }
1433 : :
1434 : : /* Subroutine to simplify constructor expressions. Mutually recursive
1435 : : with gfc_simplify_expr(). */
1436 : :
1437 : : static bool
1438 : 127669 : simplify_constructor (gfc_constructor_base base, int type)
1439 : : {
1440 : 127669 : gfc_constructor *c;
1441 : 127669 : gfc_expr *p;
1442 : :
1443 : 799565 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1444 : : {
1445 : 671896 : if (c->iterator
1446 : 671896 : && (!gfc_simplify_expr(c->iterator->start, type)
1447 : 762 : || !gfc_simplify_expr (c->iterator->end, type)
1448 : 762 : || !gfc_simplify_expr (c->iterator->step, type)))
1449 : 0 : return false;
1450 : :
1451 : 671896 : if (c->expr && c->expr->expr_type != EXPR_CONSTANT)
1452 : : {
1453 : : /* Try and simplify a copy. Replace the original if successful
1454 : : but keep going through the constructor at all costs. Not
1455 : : doing so can make a dog's dinner of complicated things. */
1456 : 36768 : p = gfc_copy_expr (c->expr);
1457 : :
1458 : 36768 : if (!gfc_simplify_expr (p, type))
1459 : : {
1460 : 10 : gfc_free_expr (p);
1461 : 10 : continue;
1462 : : }
1463 : :
1464 : 36758 : gfc_replace_expr (c->expr, p);
1465 : : }
1466 : : }
1467 : :
1468 : : return true;
1469 : : }
1470 : :
1471 : :
1472 : : /* Pull a single array element out of an array constructor. */
1473 : :
1474 : : static bool
1475 : 4686 : find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1476 : : gfc_constructor **rval)
1477 : : {
1478 : 4686 : unsigned long nelemen;
1479 : 4686 : int i;
1480 : 4686 : mpz_t delta;
1481 : 4686 : mpz_t offset;
1482 : 4686 : mpz_t span;
1483 : 4686 : mpz_t tmp;
1484 : 4686 : gfc_constructor *cons;
1485 : 4686 : gfc_expr *e;
1486 : 4686 : bool t;
1487 : :
1488 : 4686 : t = true;
1489 : 4686 : e = NULL;
1490 : :
1491 : 4686 : mpz_init_set_ui (offset, 0);
1492 : 4686 : mpz_init (delta);
1493 : 4686 : mpz_init (tmp);
1494 : 4686 : mpz_init_set_ui (span, 1);
1495 : 12183 : for (i = 0; i < ar->dimen; i++)
1496 : : {
1497 : 4753 : if (!gfc_reduce_init_expr (ar->as->lower[i])
1498 : 4748 : || !gfc_reduce_init_expr (ar->as->upper[i])
1499 : 4748 : || ar->as->upper[i]->expr_type != EXPR_CONSTANT
1500 : 9497 : || ar->as->lower[i]->expr_type != EXPR_CONSTANT)
1501 : : {
1502 : 9 : t = false;
1503 : 9 : cons = NULL;
1504 : 9 : goto depart;
1505 : : }
1506 : :
1507 : 4744 : e = ar->start[i];
1508 : 4744 : if (e->expr_type != EXPR_CONSTANT)
1509 : : {
1510 : 1924 : cons = NULL;
1511 : 1924 : goto depart;
1512 : : }
1513 : :
1514 : : /* Check the bounds. */
1515 : 2820 : if ((ar->as->upper[i]
1516 : 2820 : && mpz_cmp (e->value.integer,
1517 : 2820 : ar->as->upper[i]->value.integer) > 0)
1518 : 2811 : || (mpz_cmp (e->value.integer,
1519 : 2811 : ar->as->lower[i]->value.integer) < 0))
1520 : : {
1521 : 9 : gfc_error ("Index in dimension %d is out of bounds "
1522 : : "at %L", i + 1, &ar->c_where[i]);
1523 : 9 : cons = NULL;
1524 : 9 : t = false;
1525 : 9 : goto depart;
1526 : : }
1527 : :
1528 : 2811 : mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1529 : 2811 : mpz_mul (delta, delta, span);
1530 : 2811 : mpz_add (offset, offset, delta);
1531 : :
1532 : 2811 : mpz_set_ui (tmp, 1);
1533 : 2811 : mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1534 : 2811 : mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1535 : 2811 : mpz_mul (span, span, tmp);
1536 : : }
1537 : :
1538 : 2744 : for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
1539 : 11926 : cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1540 : : {
1541 : 9182 : if (cons->iterator)
1542 : : {
1543 : 0 : cons = NULL;
1544 : 0 : goto depart;
1545 : : }
1546 : : }
1547 : :
1548 : 2744 : depart:
1549 : 4686 : mpz_clear (delta);
1550 : 4686 : mpz_clear (offset);
1551 : 4686 : mpz_clear (span);
1552 : 4686 : mpz_clear (tmp);
1553 : 4686 : *rval = cons;
1554 : 4686 : return t;
1555 : : }
1556 : :
1557 : :
1558 : : /* Find a component of a structure constructor. */
1559 : :
1560 : : static gfc_constructor *
1561 : 1766 : find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1562 : : {
1563 : 1766 : gfc_component *pick = ref->u.c.component;
1564 : 1766 : gfc_constructor *c = gfc_constructor_first (base);
1565 : :
1566 : 1766 : gfc_symbol *dt = ref->u.c.sym;
1567 : 1766 : int ext = dt->attr.extension;
1568 : :
1569 : : /* For extended types, check if the desired component is in one of the
1570 : : * parent types. */
1571 : 1856 : while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
1572 : : pick->name, true, true, NULL))
1573 : : {
1574 : 90 : dt = dt->components->ts.u.derived;
1575 : 90 : c = gfc_constructor_first (c->expr->value.constructor);
1576 : 90 : ext--;
1577 : : }
1578 : :
1579 : 1766 : gfc_component *comp = dt->components;
1580 : 1904 : while (comp != pick)
1581 : : {
1582 : 138 : comp = comp->next;
1583 : 138 : c = gfc_constructor_next (c);
1584 : : }
1585 : :
1586 : 1766 : return c;
1587 : : }
1588 : :
1589 : :
1590 : : /* Replace an expression with the contents of a constructor, removing
1591 : : the subobject reference in the process. */
1592 : :
1593 : : static void
1594 : 4528 : remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1595 : : {
1596 : 4528 : gfc_expr *e;
1597 : :
1598 : 4528 : if (cons)
1599 : : {
1600 : 4510 : e = cons->expr;
1601 : 4510 : cons->expr = NULL;
1602 : : }
1603 : : else
1604 : 18 : e = gfc_copy_expr (p);
1605 : 4528 : e->ref = p->ref->next;
1606 : 4528 : p->ref->next = NULL;
1607 : 4528 : gfc_replace_expr (p, e);
1608 : 4528 : }
1609 : :
1610 : :
1611 : : /* Pull an array section out of an array constructor. */
1612 : :
1613 : : static bool
1614 : 1315 : find_array_section (gfc_expr *expr, gfc_ref *ref)
1615 : : {
1616 : 1315 : int idx;
1617 : 1315 : int rank;
1618 : 1315 : int d;
1619 : 1315 : int shape_i;
1620 : 1315 : int limit;
1621 : 1315 : long unsigned one = 1;
1622 : 1315 : bool incr_ctr;
1623 : 1315 : mpz_t start[GFC_MAX_DIMENSIONS];
1624 : 1315 : mpz_t end[GFC_MAX_DIMENSIONS];
1625 : 1315 : mpz_t stride[GFC_MAX_DIMENSIONS];
1626 : 1315 : mpz_t delta[GFC_MAX_DIMENSIONS];
1627 : 1315 : mpz_t ctr[GFC_MAX_DIMENSIONS];
1628 : 1315 : mpz_t delta_mpz;
1629 : 1315 : mpz_t tmp_mpz;
1630 : 1315 : mpz_t nelts;
1631 : 1315 : mpz_t ptr;
1632 : 1315 : gfc_constructor_base base;
1633 : 1315 : gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
1634 : 1315 : gfc_expr *begin;
1635 : 1315 : gfc_expr *finish;
1636 : 1315 : gfc_expr *step;
1637 : 1315 : gfc_expr *upper;
1638 : 1315 : gfc_expr *lower;
1639 : 1315 : bool t;
1640 : :
1641 : 1315 : t = true;
1642 : :
1643 : 1315 : base = expr->value.constructor;
1644 : 1315 : expr->value.constructor = NULL;
1645 : :
1646 : 1315 : rank = ref->u.ar.as->rank;
1647 : :
1648 : 1315 : if (expr->shape == NULL)
1649 : 243 : expr->shape = gfc_get_shape (rank);
1650 : :
1651 : 1315 : mpz_init_set_ui (delta_mpz, one);
1652 : 1315 : mpz_init_set_ui (nelts, one);
1653 : 1315 : mpz_init (tmp_mpz);
1654 : 1315 : mpz_init (ptr);
1655 : :
1656 : : /* Do the initialization now, so that we can cleanup without
1657 : : keeping track of where we were. */
1658 : 4472 : for (d = 0; d < rank; d++)
1659 : : {
1660 : 1842 : mpz_init (delta[d]);
1661 : 1842 : mpz_init (start[d]);
1662 : 1842 : mpz_init (end[d]);
1663 : 1842 : mpz_init (ctr[d]);
1664 : 1842 : mpz_init (stride[d]);
1665 : 1842 : vecsub[d] = NULL;
1666 : : }
1667 : :
1668 : : /* Build the counters to clock through the array reference. */
1669 : : shape_i = 0;
1670 : 2467 : for (d = 0; d < rank; d++)
1671 : : {
1672 : : /* Make this stretch of code easier on the eye! */
1673 : 1595 : begin = ref->u.ar.start[d];
1674 : 1595 : finish = ref->u.ar.end[d];
1675 : 1595 : step = ref->u.ar.stride[d];
1676 : 1595 : lower = ref->u.ar.as->lower[d];
1677 : 1595 : upper = ref->u.ar.as->upper[d];
1678 : :
1679 : 1595 : if (!lower || !upper
1680 : 1585 : || lower->expr_type != EXPR_CONSTANT
1681 : 1585 : || upper->expr_type != EXPR_CONSTANT
1682 : 1585 : || lower->ts.type != BT_INTEGER
1683 : 1585 : || upper->ts.type != BT_INTEGER)
1684 : : {
1685 : 11 : t = false;
1686 : 11 : goto cleanup;
1687 : : }
1688 : :
1689 : 1584 : if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1690 : : {
1691 : 70 : gfc_constructor *ci;
1692 : 70 : gcc_assert (begin);
1693 : :
1694 : 70 : if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1695 : : {
1696 : 6 : t = false;
1697 : 6 : goto cleanup;
1698 : : }
1699 : :
1700 : 64 : gcc_assert (begin->rank == 1);
1701 : : /* Zero-sized arrays have no shape and no elements, stop early. */
1702 : 64 : if (!begin->shape)
1703 : : {
1704 : 0 : mpz_set_ui (nelts, 0);
1705 : 0 : break;
1706 : : }
1707 : :
1708 : 64 : vecsub[d] = gfc_constructor_first (begin->value.constructor);
1709 : 64 : mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1710 : 64 : mpz_mul (nelts, nelts, begin->shape[0]);
1711 : 64 : mpz_set (expr->shape[shape_i++], begin->shape[0]);
1712 : :
1713 : : /* Check bounds. */
1714 : 296 : for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1715 : : {
1716 : 170 : if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1717 : 168 : || mpz_cmp (ci->expr->value.integer,
1718 : 168 : lower->value.integer) < 0)
1719 : : {
1720 : 2 : gfc_error ("index in dimension %d is out of bounds "
1721 : : "at %L", d + 1, &ref->u.ar.c_where[d]);
1722 : 2 : t = false;
1723 : 2 : goto cleanup;
1724 : : }
1725 : : }
1726 : : }
1727 : : else
1728 : : {
1729 : 1514 : if ((begin && begin->expr_type != EXPR_CONSTANT)
1730 : 1154 : || (finish && finish->expr_type != EXPR_CONSTANT)
1731 : 1124 : || (step && step->expr_type != EXPR_CONSTANT))
1732 : : {
1733 : 390 : t = false;
1734 : 390 : goto cleanup;
1735 : : }
1736 : :
1737 : : /* Obtain the stride. */
1738 : 1124 : if (step)
1739 : 118 : mpz_set (stride[d], step->value.integer);
1740 : : else
1741 : 1006 : mpz_set_ui (stride[d], one);
1742 : :
1743 : 1124 : if (mpz_cmp_ui (stride[d], 0) == 0)
1744 : 0 : mpz_set_ui (stride[d], one);
1745 : :
1746 : : /* Obtain the start value for the index. */
1747 : 1124 : if (begin)
1748 : 854 : mpz_set (start[d], begin->value.integer);
1749 : : else
1750 : 270 : mpz_set (start[d], lower->value.integer);
1751 : :
1752 : 1124 : mpz_set (ctr[d], start[d]);
1753 : :
1754 : : /* Obtain the end value for the index. */
1755 : 1124 : if (finish)
1756 : 625 : mpz_set (end[d], finish->value.integer);
1757 : : else
1758 : 499 : mpz_set (end[d], upper->value.integer);
1759 : :
1760 : : /* Separate 'if' because elements sometimes arrive with
1761 : : non-null end. */
1762 : 1124 : if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1763 : 248 : mpz_set (end [d], begin->value.integer);
1764 : :
1765 : : /* Check the bounds. */
1766 : 1124 : if (mpz_cmp (ctr[d], upper->value.integer) > 0
1767 : 1105 : || mpz_cmp (end[d], upper->value.integer) > 0
1768 : 1105 : || mpz_cmp (ctr[d], lower->value.integer) < 0
1769 : 1090 : || mpz_cmp (end[d], lower->value.integer) < 0)
1770 : : {
1771 : 34 : gfc_error ("index in dimension %d is out of bounds "
1772 : : "at %L", d + 1, &ref->u.ar.c_where[d]);
1773 : 34 : t = false;
1774 : 34 : goto cleanup;
1775 : : }
1776 : :
1777 : : /* Calculate the number of elements and the shape. */
1778 : 1090 : mpz_set (tmp_mpz, stride[d]);
1779 : 1090 : mpz_add (tmp_mpz, end[d], tmp_mpz);
1780 : 1090 : mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1781 : 1090 : mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1782 : 1090 : mpz_mul (nelts, nelts, tmp_mpz);
1783 : :
1784 : : /* An element reference reduces the rank of the expression; don't
1785 : : add anything to the shape array. */
1786 : 1090 : if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1787 : 842 : mpz_set (expr->shape[shape_i++], tmp_mpz);
1788 : : }
1789 : :
1790 : : /* Calculate the 'stride' (=delta) for conversion of the
1791 : : counter values into the index along the constructor. */
1792 : 1152 : mpz_set (delta[d], delta_mpz);
1793 : 1152 : mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1794 : 1152 : mpz_add_ui (tmp_mpz, tmp_mpz, one);
1795 : 1152 : mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1796 : : }
1797 : :
1798 : 872 : cons = gfc_constructor_first (base);
1799 : :
1800 : : /* Now clock through the array reference, calculating the index in
1801 : : the source constructor and transferring the elements to the new
1802 : : constructor. */
1803 : 14220 : for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1804 : : {
1805 : 12477 : mpz_set_ui (ptr, 0);
1806 : :
1807 : 12477 : incr_ctr = true;
1808 : 38376 : for (d = 0; d < rank; d++)
1809 : : {
1810 : 13422 : mpz_set (tmp_mpz, ctr[d]);
1811 : 13422 : mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1812 : 13422 : mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1813 : 13422 : mpz_add (ptr, ptr, tmp_mpz);
1814 : :
1815 : 13422 : if (!incr_ctr) continue;
1816 : :
1817 : 13057 : if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1818 : : {
1819 : 203 : gcc_assert(vecsub[d]);
1820 : :
1821 : 203 : if (!gfc_constructor_next (vecsub[d]))
1822 : 74 : vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1823 : : else
1824 : : {
1825 : 129 : vecsub[d] = gfc_constructor_next (vecsub[d]);
1826 : 129 : incr_ctr = false;
1827 : : }
1828 : 203 : mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1829 : : }
1830 : : else
1831 : : {
1832 : 12854 : mpz_add (ctr[d], ctr[d], stride[d]);
1833 : :
1834 : 25708 : if (mpz_cmp_ui (stride[d], 0) > 0
1835 : 12503 : ? mpz_cmp (ctr[d], end[d]) > 0
1836 : 351 : : mpz_cmp (ctr[d], end[d]) < 0)
1837 : 1377 : mpz_set (ctr[d], start[d]);
1838 : : else
1839 : : incr_ctr = false;
1840 : : }
1841 : : }
1842 : :
1843 : 12477 : limit = mpz_get_ui (ptr);
1844 : 12477 : if (limit >= flag_max_array_constructor)
1845 : : {
1846 : 0 : gfc_error ("The number of elements in the array constructor "
1847 : : "at %L requires an increase of the allowed %d "
1848 : : "upper limit. See %<-fmax-array-constructor%> "
1849 : : "option", &expr->where, flag_max_array_constructor);
1850 : 0 : t = false;
1851 : 0 : goto cleanup;
1852 : : }
1853 : :
1854 : 12477 : cons = gfc_constructor_lookup (base, limit);
1855 : 12477 : if (cons == NULL)
1856 : : {
1857 : 1 : gfc_error ("Error in array constructor referenced at %L",
1858 : : &ref->u.ar.where);
1859 : 1 : t = false;
1860 : 1 : goto cleanup;
1861 : : }
1862 : 12476 : gfc_constructor_append_expr (&expr->value.constructor,
1863 : : gfc_copy_expr (cons->expr), NULL);
1864 : : }
1865 : :
1866 : 871 : cleanup:
1867 : :
1868 : 1315 : mpz_clear (delta_mpz);
1869 : 1315 : mpz_clear (tmp_mpz);
1870 : 1315 : mpz_clear (nelts);
1871 : 4472 : for (d = 0; d < rank; d++)
1872 : : {
1873 : 1842 : mpz_clear (delta[d]);
1874 : 1842 : mpz_clear (start[d]);
1875 : 1842 : mpz_clear (end[d]);
1876 : 1842 : mpz_clear (ctr[d]);
1877 : 1842 : mpz_clear (stride[d]);
1878 : : }
1879 : 1315 : mpz_clear (ptr);
1880 : 1315 : gfc_constructor_free (base);
1881 : 1315 : return t;
1882 : : }
1883 : :
1884 : : /* Pull a substring out of an expression. */
1885 : :
1886 : : static bool
1887 : 1258 : find_substring_ref (gfc_expr *p, gfc_expr **newp)
1888 : : {
1889 : 1258 : gfc_charlen_t end;
1890 : 1258 : gfc_charlen_t start;
1891 : 1258 : gfc_charlen_t length;
1892 : 1258 : gfc_char_t *chr;
1893 : :
1894 : 1258 : if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1895 : 1258 : || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1896 : : return false;
1897 : :
1898 : 1258 : *newp = gfc_copy_expr (p);
1899 : 1258 : free ((*newp)->value.character.string);
1900 : :
1901 : 1258 : end = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.end->value.integer);
1902 : 1258 : start = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.start->value.integer);
1903 : 1258 : if (end >= start)
1904 : 1237 : length = end - start + 1;
1905 : : else
1906 : : length = 0;
1907 : :
1908 : 1258 : chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1909 : 1258 : (*newp)->value.character.length = length;
1910 : 1258 : memcpy (chr, &p->value.character.string[start - 1],
1911 : 1258 : length * sizeof (gfc_char_t));
1912 : 1258 : chr[length] = '\0';
1913 : 1258 : return true;
1914 : : }
1915 : :
1916 : :
1917 : : /* Simplify inquiry references (%re/%im) of constant complex arrays.
1918 : : Used by find_inquiry_ref. */
1919 : :
1920 : : static gfc_expr *
1921 : 60 : simplify_complex_array_inquiry_ref (gfc_expr *p, inquiry_type inquiry)
1922 : : {
1923 : 60 : gfc_expr *e, *r, *result;
1924 : 60 : gfc_constructor_base base;
1925 : 60 : gfc_constructor *c;
1926 : :
1927 : 60 : if ((inquiry != INQUIRY_RE && inquiry != INQUIRY_IM)
1928 : 60 : || p->expr_type != EXPR_ARRAY
1929 : 60 : || p->ts.type != BT_COMPLEX
1930 : 60 : || p->rank <= 0
1931 : 60 : || p->value.constructor == NULL
1932 : 120 : || !gfc_is_constant_array_expr (p))
1933 : 0 : return NULL;
1934 : :
1935 : : /* Simplify array sections. */
1936 : 60 : gfc_simplify_expr (p, 0);
1937 : :
1938 : 60 : result = gfc_get_array_expr (BT_REAL, p->ts.kind, &p->where);
1939 : 60 : result->rank = p->rank;
1940 : 60 : result->shape = gfc_copy_shape (p->shape, p->rank);
1941 : :
1942 : 60 : base = p->value.constructor;
1943 : 312 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1944 : : {
1945 : 252 : e = c->expr;
1946 : 252 : if (e->expr_type != EXPR_CONSTANT)
1947 : 0 : goto fail;
1948 : :
1949 : 252 : r = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1950 : 252 : if (inquiry == INQUIRY_RE)
1951 : 126 : mpfr_set (r->value.real, mpc_realref (e->value.complex), GFC_RND_MODE);
1952 : : else
1953 : 126 : mpfr_set (r->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
1954 : :
1955 : 252 : gfc_constructor_append_expr (&result->value.constructor, r, &e->where);
1956 : : }
1957 : :
1958 : : return result;
1959 : :
1960 : 0 : fail:
1961 : 0 : gfc_free_expr (result);
1962 : 0 : return NULL;
1963 : : }
1964 : :
1965 : :
1966 : : /* Pull an inquiry result out of an expression. */
1967 : :
1968 : : static bool
1969 : 2037 : find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
1970 : : {
1971 : 2037 : gfc_ref *ref;
1972 : 2037 : gfc_ref *inquiry = NULL;
1973 : 2037 : gfc_ref *inquiry_head;
1974 : 2037 : gfc_ref *ref_ss = NULL;
1975 : 2037 : gfc_expr *tmp;
1976 : 2037 : bool nofail = false;
1977 : :
1978 : 2037 : tmp = gfc_copy_expr (p);
1979 : :
1980 : 2037 : if (tmp->ref && tmp->ref->type == REF_INQUIRY)
1981 : : {
1982 : 560 : inquiry = tmp->ref;
1983 : 560 : tmp->ref = NULL;
1984 : : }
1985 : : else
1986 : : {
1987 : 1636 : for (ref = tmp->ref; ref; ref = ref->next)
1988 : 1636 : if (ref->next && ref->next->type == REF_INQUIRY)
1989 : : {
1990 : 1477 : inquiry = ref->next;
1991 : 1477 : ref->next = NULL;
1992 : 1477 : if (ref->type == REF_SUBSTRING)
1993 : 14 : ref_ss = ref;
1994 : : break;
1995 : : }
1996 : : }
1997 : :
1998 : 2037 : if (!inquiry)
1999 : : {
2000 : 0 : gfc_free_expr (tmp);
2001 : 0 : return false;
2002 : : }
2003 : :
2004 : 2037 : inquiry_head = inquiry;
2005 : 2037 : gfc_resolve_expr (tmp);
2006 : :
2007 : : /* Leave these to the backend since the type and kind is not confirmed until
2008 : : resolution. */
2009 : 2037 : if (IS_INFERRED_TYPE (tmp))
2010 : 282 : goto cleanup;
2011 : :
2012 : : /* In principle there can be more than one inquiry reference. */
2013 : 2174 : for (; inquiry; inquiry = inquiry->next)
2014 : : {
2015 : 1755 : switch (inquiry->u.i)
2016 : : {
2017 : 194 : case INQUIRY_LEN:
2018 : 194 : if (tmp->ts.type != BT_CHARACTER)
2019 : 12 : goto cleanup;
2020 : :
2021 : 182 : if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
2022 : 0 : goto cleanup;
2023 : :
2024 : : /* Inquire length of substring? */
2025 : 182 : if (ref_ss)
2026 : : {
2027 : 8 : if (ref_ss->u.ss.start->expr_type == EXPR_CONSTANT
2028 : 8 : && ref_ss->u.ss.end->expr_type == EXPR_CONSTANT)
2029 : : {
2030 : 8 : HOST_WIDE_INT istart, iend, length;
2031 : 8 : istart = gfc_mpz_get_hwi (ref_ss->u.ss.start->value.integer);
2032 : 8 : iend = gfc_mpz_get_hwi (ref_ss->u.ss.end->value.integer);
2033 : :
2034 : 8 : if (istart <= iend)
2035 : 8 : length = iend - istart + 1;
2036 : : else
2037 : : length = 0;
2038 : 8 : *newp = gfc_get_int_expr (gfc_default_integer_kind,
2039 : : NULL, length);
2040 : 8 : break;
2041 : : }
2042 : : else
2043 : 0 : goto cleanup;
2044 : : }
2045 : :
2046 : 174 : if (tmp->ts.u.cl->length
2047 : 99 : && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2048 : 63 : *newp = gfc_copy_expr (tmp->ts.u.cl->length);
2049 : 111 : else if (tmp->expr_type == EXPR_CONSTANT)
2050 : 12 : *newp = gfc_get_int_expr (gfc_default_integer_kind,
2051 : 12 : NULL, tmp->value.character.length);
2052 : 99 : else if (gfc_init_expr_flag
2053 : 6 : && tmp->ts.u.cl->length->symtree->n.sym->attr.pdt_len)
2054 : 6 : *newp = gfc_pdt_find_component_copy_initializer (tmp->symtree->n
2055 : : .sym,
2056 : : tmp->ts.u.cl
2057 : : ->length->symtree
2058 : : ->n.sym->name);
2059 : : else
2060 : 93 : goto cleanup;
2061 : :
2062 : : break;
2063 : :
2064 : 186 : case INQUIRY_KIND:
2065 : 186 : if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS)
2066 : 0 : goto cleanup;
2067 : :
2068 : 186 : if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
2069 : 0 : goto cleanup;
2070 : :
2071 : 372 : *newp = gfc_get_int_expr (gfc_default_integer_kind,
2072 : 186 : NULL, tmp->ts.kind);
2073 : 186 : break;
2074 : :
2075 : 822 : case INQUIRY_RE:
2076 : 822 : if (tmp->ts.type != BT_COMPLEX)
2077 : 77 : goto cleanup;
2078 : :
2079 : 745 : if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C"))
2080 : 0 : goto cleanup;
2081 : :
2082 : 745 : if (tmp->expr_type == EXPR_ARRAY)
2083 : : {
2084 : 30 : *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_RE);
2085 : 30 : if (*newp != NULL)
2086 : : {
2087 : : nofail = true;
2088 : : break;
2089 : : }
2090 : : }
2091 : :
2092 : 715 : if (tmp->expr_type != EXPR_CONSTANT)
2093 : 661 : goto cleanup;
2094 : :
2095 : 54 : *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
2096 : 54 : mpfr_set ((*newp)->value.real,
2097 : : mpc_realref (tmp->value.complex), GFC_RND_MODE);
2098 : 54 : break;
2099 : :
2100 : 553 : case INQUIRY_IM:
2101 : 553 : if (tmp->ts.type != BT_COMPLEX)
2102 : 74 : goto cleanup;
2103 : :
2104 : 479 : if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C"))
2105 : 0 : goto cleanup;
2106 : :
2107 : 479 : if (tmp->expr_type == EXPR_ARRAY)
2108 : : {
2109 : 30 : *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_IM);
2110 : 30 : if (*newp != NULL)
2111 : : {
2112 : : nofail = true;
2113 : : break;
2114 : : }
2115 : : }
2116 : :
2117 : 449 : if (tmp->expr_type != EXPR_CONSTANT)
2118 : 419 : goto cleanup;
2119 : :
2120 : 30 : *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
2121 : 30 : mpfr_set ((*newp)->value.real,
2122 : : mpc_imagref (tmp->value.complex), GFC_RND_MODE);
2123 : 30 : break;
2124 : : }
2125 : :
2126 : 419 : if (inquiry->next)
2127 : 0 : gfc_replace_expr (tmp, *newp);
2128 : : }
2129 : :
2130 : 419 : if (!(*newp))
2131 : 0 : goto cleanup;
2132 : 419 : else if ((*newp)->expr_type != EXPR_CONSTANT && !nofail)
2133 : : {
2134 : 0 : gfc_free_expr (*newp);
2135 : 0 : goto cleanup;
2136 : : }
2137 : :
2138 : 419 : gfc_free_expr (tmp);
2139 : 419 : gfc_free_ref_list (inquiry_head);
2140 : 419 : return true;
2141 : :
2142 : 1618 : cleanup:
2143 : 1618 : gfc_free_expr (tmp);
2144 : 1618 : gfc_free_ref_list (inquiry_head);
2145 : 1618 : return false;
2146 : : }
2147 : :
2148 : :
2149 : :
2150 : : /* Simplify a subobject reference of a constructor. This occurs when
2151 : : parameter variable values are substituted. */
2152 : :
2153 : : static bool
2154 : 130283 : simplify_const_ref (gfc_expr *p)
2155 : : {
2156 : 130283 : gfc_constructor *cons, *c;
2157 : 130283 : gfc_expr *newp = NULL;
2158 : 130283 : gfc_ref *last_ref;
2159 : :
2160 : 275310 : while (p->ref)
2161 : : {
2162 : 17130 : switch (p->ref->type)
2163 : : {
2164 : 14106 : case REF_ARRAY:
2165 : 14106 : switch (p->ref->u.ar.type)
2166 : : {
2167 : 4704 : case AR_ELEMENT:
2168 : : /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
2169 : : will generate this. */
2170 : 4704 : if (p->expr_type != EXPR_ARRAY)
2171 : : {
2172 : 18 : remove_subobject_ref (p, NULL);
2173 : 18 : break;
2174 : : }
2175 : 4686 : if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
2176 : : return false;
2177 : :
2178 : 4668 : if (!cons)
2179 : : return true;
2180 : :
2181 : 2744 : remove_subobject_ref (p, cons);
2182 : 2744 : break;
2183 : :
2184 : 1315 : case AR_SECTION:
2185 : 1315 : if (!find_array_section (p, p->ref))
2186 : : return false;
2187 : 871 : p->ref->u.ar.type = AR_FULL;
2188 : :
2189 : : /* Fall through. */
2190 : :
2191 : 8958 : case AR_FULL:
2192 : 8958 : if (p->ref->next != NULL
2193 : 336 : && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type)))
2194 : : {
2195 : 336 : for (c = gfc_constructor_first (p->value.constructor);
2196 : 2950 : c; c = gfc_constructor_next (c))
2197 : : {
2198 : 2614 : c->expr->ref = gfc_copy_ref (p->ref->next);
2199 : 2614 : if (!simplify_const_ref (c->expr))
2200 : : return false;
2201 : : }
2202 : :
2203 : 75 : if (gfc_bt_struct (p->ts.type)
2204 : 261 : && p->ref->next
2205 : 597 : && (c = gfc_constructor_first (p->value.constructor)))
2206 : : {
2207 : : /* There may have been component references. */
2208 : 261 : p->ts = c->expr->ts;
2209 : : }
2210 : :
2211 : 336 : last_ref = p->ref;
2212 : 690 : for (; last_ref->next; last_ref = last_ref->next) {};
2213 : :
2214 : 336 : if (p->ts.type == BT_CHARACTER
2215 : 97 : && last_ref->type == REF_SUBSTRING)
2216 : : {
2217 : : /* If this is a CHARACTER array and we possibly took
2218 : : a substring out of it, update the type-spec's
2219 : : character length according to the first element
2220 : : (as all should have the same length). */
2221 : 75 : gfc_charlen_t string_len;
2222 : 75 : if ((c = gfc_constructor_first (p->value.constructor)))
2223 : : {
2224 : 75 : const gfc_expr* first = c->expr;
2225 : 75 : gcc_assert (first->expr_type == EXPR_CONSTANT);
2226 : 75 : gcc_assert (first->ts.type == BT_CHARACTER);
2227 : 75 : string_len = first->value.character.length;
2228 : : }
2229 : : else
2230 : : string_len = 0;
2231 : :
2232 : 75 : if (!p->ts.u.cl)
2233 : : {
2234 : 0 : if (p->symtree)
2235 : 0 : p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
2236 : : NULL);
2237 : : else
2238 : 0 : p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
2239 : : NULL);
2240 : : }
2241 : : else
2242 : 75 : gfc_free_expr (p->ts.u.cl->length);
2243 : :
2244 : 75 : p->ts.u.cl->length
2245 : 75 : = gfc_get_int_expr (gfc_charlen_int_kind,
2246 : : NULL, string_len);
2247 : : }
2248 : : }
2249 : 8958 : gfc_free_ref_list (p->ref);
2250 : 8958 : p->ref = NULL;
2251 : 8958 : break;
2252 : :
2253 : : default:
2254 : : return true;
2255 : : }
2256 : :
2257 : : break;
2258 : :
2259 : 1766 : case REF_COMPONENT:
2260 : 1766 : cons = find_component_ref (p->value.constructor, p->ref);
2261 : 1766 : remove_subobject_ref (p, cons);
2262 : 1766 : break;
2263 : :
2264 : 0 : case REF_INQUIRY:
2265 : 0 : if (!find_inquiry_ref (p, &newp))
2266 : : return false;
2267 : :
2268 : 0 : gfc_replace_expr (p, newp);
2269 : 0 : gfc_free_ref_list (p->ref);
2270 : 0 : p->ref = NULL;
2271 : 0 : break;
2272 : :
2273 : 1258 : case REF_SUBSTRING:
2274 : 1258 : if (!find_substring_ref (p, &newp))
2275 : : return false;
2276 : :
2277 : 1258 : gfc_replace_expr (p, newp);
2278 : 1258 : gfc_free_ref_list (p->ref);
2279 : 1258 : p->ref = NULL;
2280 : 1258 : break;
2281 : : }
2282 : : }
2283 : :
2284 : : return true;
2285 : : }
2286 : :
2287 : :
2288 : : /* Simplify a chain of references. */
2289 : :
2290 : : static bool
2291 : 15090286 : simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
2292 : : {
2293 : 15090286 : int n;
2294 : 15090286 : gfc_expr *newp = NULL;
2295 : :
2296 : 15417162 : for (; ref; ref = ref->next)
2297 : : {
2298 : 328914 : switch (ref->type)
2299 : : {
2300 : : case REF_ARRAY:
2301 : 577502 : for (n = 0; n < ref->u.ar.dimen; n++)
2302 : : {
2303 : 322129 : if (!gfc_simplify_expr (ref->u.ar.start[n], type))
2304 : : return false;
2305 : 322129 : if (!gfc_simplify_expr (ref->u.ar.end[n], type))
2306 : : return false;
2307 : 322129 : if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
2308 : : return false;
2309 : : }
2310 : : break;
2311 : :
2312 : 9716 : case REF_SUBSTRING:
2313 : 9716 : if (!gfc_simplify_expr (ref->u.ss.start, type))
2314 : : return false;
2315 : 9716 : if (!gfc_simplify_expr (ref->u.ss.end, type))
2316 : : return false;
2317 : : break;
2318 : :
2319 : 2037 : case REF_INQUIRY:
2320 : 2037 : if (!find_inquiry_ref (*p, &newp))
2321 : : return false;
2322 : :
2323 : 419 : gfc_replace_expr (*p, newp);
2324 : 419 : gfc_free_ref_list ((*p)->ref);
2325 : 419 : (*p)->ref = NULL;
2326 : 419 : return true;
2327 : :
2328 : : default:
2329 : : break;
2330 : : }
2331 : : }
2332 : : return true;
2333 : : }
2334 : :
2335 : :
2336 : : /* Try to substitute the value of a parameter variable. */
2337 : :
2338 : : static bool
2339 : 14836 : simplify_parameter_variable (gfc_expr *p, int type)
2340 : : {
2341 : 14836 : gfc_expr *e;
2342 : 14836 : bool t;
2343 : :
2344 : : /* Set rank and check array ref; as resolve_variable calls
2345 : : gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
2346 : 14836 : if (!gfc_resolve_ref (p))
2347 : : {
2348 : 1 : gfc_error_check ();
2349 : 1 : return false;
2350 : : }
2351 : 14835 : gfc_expression_rank (p);
2352 : :
2353 : : /* Is this an inquiry? */
2354 : 14835 : bool inquiry = false;
2355 : 14835 : gfc_ref* ref = p->ref;
2356 : 30481 : while (ref)
2357 : : {
2358 : 15774 : if (ref->type == REF_INQUIRY)
2359 : : break;
2360 : 15646 : ref = ref->next;
2361 : : }
2362 : 14835 : if (ref && ref->type == REF_INQUIRY)
2363 : 128 : inquiry = ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND;
2364 : :
2365 : 14835 : if (gfc_is_size_zero_array (p))
2366 : : {
2367 : 690 : if (p->expr_type == EXPR_ARRAY)
2368 : : return true;
2369 : :
2370 : 690 : e = gfc_get_expr ();
2371 : 690 : e->expr_type = EXPR_ARRAY;
2372 : 690 : e->ts = p->ts;
2373 : 690 : e->rank = p->rank;
2374 : 690 : e->corank = p->corank;
2375 : 690 : e->value.constructor = NULL;
2376 : 690 : e->shape = gfc_copy_shape (p->shape, p->rank);
2377 : 690 : e->where = p->where;
2378 : : /* If %kind and %len are not used then we're done, otherwise
2379 : : drop through for simplification. */
2380 : 690 : if (!inquiry)
2381 : : {
2382 : 620 : gfc_replace_expr (p, e);
2383 : 620 : return true;
2384 : : }
2385 : : }
2386 : : else
2387 : : {
2388 : 14145 : e = gfc_copy_expr (p->symtree->n.sym->value);
2389 : 14145 : if (e == NULL)
2390 : : return false;
2391 : :
2392 : 14079 : gfc_free_shape (&e->shape, e->rank);
2393 : 14079 : e->shape = gfc_copy_shape (p->shape, p->rank);
2394 : 14079 : e->rank = p->rank;
2395 : 14079 : e->corank = p->corank;
2396 : :
2397 : 14079 : if (e->ts.type == BT_CHARACTER && p->ts.u.cl)
2398 : 3483 : e->ts = p->ts;
2399 : : }
2400 : :
2401 : 14149 : if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL)
2402 : 0 : e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl);
2403 : :
2404 : : /* Do not copy subobject refs for constant. */
2405 : 14149 : if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
2406 : 14144 : e->ref = gfc_copy_ref (p->ref);
2407 : 14149 : t = gfc_simplify_expr (e, type);
2408 : 14149 : e->where = p->where;
2409 : :
2410 : : /* Only use the simplification if it eliminated all subobject references. */
2411 : 14149 : if (t && !e->ref)
2412 : 11762 : gfc_replace_expr (p, e);
2413 : : else
2414 : 2387 : gfc_free_expr (e);
2415 : :
2416 : : return t;
2417 : : }
2418 : :
2419 : :
2420 : : static bool
2421 : : scalarize_intrinsic_call (gfc_expr *, bool init_flag);
2422 : :
2423 : : /* Given an expression, simplify it by collapsing constant
2424 : : expressions. Most simplification takes place when the expression
2425 : : tree is being constructed. If an intrinsic function is simplified
2426 : : at some point, we get called again to collapse the result against
2427 : : other constants.
2428 : :
2429 : : We work by recursively simplifying expression nodes, simplifying
2430 : : intrinsic functions where possible, which can lead to further
2431 : : constant collapsing. If an operator has constant operand(s), we
2432 : : rip the expression apart, and rebuild it, hoping that it becomes
2433 : : something simpler.
2434 : :
2435 : : The expression type is defined for:
2436 : : 0 Basic expression parsing
2437 : : 1 Simplifying array constructors -- will substitute
2438 : : iterator values.
2439 : : Returns false on error, true otherwise.
2440 : : NOTE: Will return true even if the expression cannot be simplified. */
2441 : :
2442 : : bool
2443 : 56211665 : gfc_simplify_expr (gfc_expr *p, int type)
2444 : : {
2445 : 56211665 : gfc_actual_arglist *ap;
2446 : 56211665 : gfc_intrinsic_sym* isym = NULL;
2447 : :
2448 : :
2449 : 56211665 : if (p == NULL)
2450 : : return true;
2451 : :
2452 : 49894930 : switch (p->expr_type)
2453 : : {
2454 : 16943312 : case EXPR_CONSTANT:
2455 : 16943312 : if (p->ref && p->ref->type == REF_INQUIRY)
2456 : 40 : simplify_ref_chain (p->ref, type, &p);
2457 : : break;
2458 : : case EXPR_NULL:
2459 : : break;
2460 : :
2461 : 568651 : case EXPR_FUNCTION:
2462 : : // For array-bound functions, we don't need to optimize
2463 : : // the 'array' argument. In particular, if the argument
2464 : : // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2465 : : // into an EXPR_ARRAY; the latter has lbound = 1, the former
2466 : : // can have any lbound.
2467 : 568651 : ap = p->value.function.actual;
2468 : 568651 : if (p->value.function.isym &&
2469 : 533114 : (p->value.function.isym->id == GFC_ISYM_LBOUND
2470 : 520082 : || p->value.function.isym->id == GFC_ISYM_UBOUND
2471 : 512264 : || p->value.function.isym->id == GFC_ISYM_LCOBOUND
2472 : 512062 : || p->value.function.isym->id == GFC_ISYM_UCOBOUND
2473 : 511869 : || p->value.function.isym->id == GFC_ISYM_SHAPE))
2474 : 25925 : ap = ap->next;
2475 : :
2476 : 1649582 : for ( ; ap; ap = ap->next)
2477 : 1081082 : if (!gfc_simplify_expr (ap->expr, type))
2478 : : return false;
2479 : :
2480 : 568500 : if (p->value.function.isym != NULL
2481 : 568500 : && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
2482 : : return false;
2483 : :
2484 : 568441 : if (p->symtree && (p->value.function.isym || p->ts.type == BT_UNKNOWN))
2485 : : {
2486 : 215761 : isym = gfc_find_function (p->symtree->n.sym->name);
2487 : 215761 : if (isym && isym->elemental)
2488 : 108660 : scalarize_intrinsic_call (p, false);
2489 : : }
2490 : :
2491 : : break;
2492 : :
2493 : 1440 : case EXPR_SUBSTRING:
2494 : 1440 : if (!simplify_ref_chain (p->ref, type, &p))
2495 : : return false;
2496 : :
2497 : 1440 : if (gfc_is_constant_expr (p))
2498 : : {
2499 : 768 : gfc_char_t *s;
2500 : 768 : HOST_WIDE_INT start, end;
2501 : :
2502 : 768 : start = 0;
2503 : 768 : if (p->ref && p->ref->u.ss.start)
2504 : : {
2505 : 743 : gfc_extract_hwi (p->ref->u.ss.start, &start);
2506 : 743 : start--; /* Convert from one-based to zero-based. */
2507 : : }
2508 : :
2509 : 768 : end = p->value.character.length;
2510 : 768 : if (p->ref && p->ref->u.ss.end)
2511 : 743 : gfc_extract_hwi (p->ref->u.ss.end, &end);
2512 : :
2513 : 768 : if (end < start)
2514 : 7 : end = start;
2515 : :
2516 : 768 : s = gfc_get_wide_string (end - start + 2);
2517 : 768 : memcpy (s, p->value.character.string + start,
2518 : 768 : (end - start) * sizeof (gfc_char_t));
2519 : 768 : s[end - start + 1] = '\0'; /* TODO: C-style string. */
2520 : 768 : free (p->value.character.string);
2521 : 768 : p->value.character.string = s;
2522 : 768 : p->value.character.length = end - start;
2523 : 768 : p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2524 : 1536 : p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2525 : : NULL,
2526 : 768 : p->value.character.length);
2527 : 768 : gfc_free_ref_list (p->ref);
2528 : 768 : p->ref = NULL;
2529 : 768 : p->expr_type = EXPR_CONSTANT;
2530 : : }
2531 : : break;
2532 : :
2533 : 17276208 : case EXPR_OP:
2534 : 17276208 : if (!simplify_intrinsic_op (p, type))
2535 : : return false;
2536 : : break;
2537 : :
2538 : 27 : case EXPR_CONDITIONAL:
2539 : 27 : if (!simplify_conditional (p, type))
2540 : : return false;
2541 : : break;
2542 : :
2543 : 14974531 : case EXPR_VARIABLE:
2544 : : /* Only substitute array parameter variables if we are in an
2545 : : initialization expression, or we want a subsection. */
2546 : 14974531 : if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
2547 : 14463 : && (gfc_init_expr_flag || p->ref
2548 : 1 : || (p->symtree->n.sym->value
2549 : 0 : && p->symtree->n.sym->value->expr_type != EXPR_ARRAY)))
2550 : : {
2551 : 14462 : if (!simplify_parameter_variable (p, type))
2552 : : return false;
2553 : 13943 : if (!iter_stack)
2554 : : break;
2555 : : }
2556 : :
2557 : 14960953 : if (type == 1)
2558 : : {
2559 : 13969263 : gfc_simplify_iterator_var (p);
2560 : : }
2561 : :
2562 : : /* Simplify subcomponent references. */
2563 : 14960953 : if (!simplify_ref_chain (p->ref, type, &p))
2564 : : return false;
2565 : :
2566 : : break;
2567 : :
2568 : 127853 : case EXPR_STRUCTURE:
2569 : 127853 : case EXPR_ARRAY:
2570 : 127853 : if (!simplify_ref_chain (p->ref, type, &p))
2571 : : return false;
2572 : :
2573 : : /* If the following conditions hold, we found something like kind type
2574 : : inquiry of the form a(2)%kind while simplify the ref chain. */
2575 : 127852 : if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape)
2576 : : return true;
2577 : :
2578 : 127669 : if (!simplify_constructor (p->value.constructor, type))
2579 : : return false;
2580 : :
2581 : 127669 : if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
2582 : 14047 : && p->ref->u.ar.type == AR_FULL)
2583 : 8071 : gfc_expand_constructor (p, false);
2584 : :
2585 : 127669 : if (!simplify_const_ref (p))
2586 : : return false;
2587 : :
2588 : : break;
2589 : :
2590 : : case EXPR_COMPCALL:
2591 : : case EXPR_PPC:
2592 : : break;
2593 : :
2594 : 0 : case EXPR_UNKNOWN:
2595 : 0 : gcc_unreachable ();
2596 : : }
2597 : :
2598 : : return true;
2599 : : }
2600 : :
2601 : :
2602 : : /* Try simplification of an expression via gfc_simplify_expr.
2603 : : When an error occurs (arithmetic or otherwise), roll back. */
2604 : :
2605 : : bool
2606 : 0 : gfc_try_simplify_expr (gfc_expr *e, int type)
2607 : : {
2608 : 0 : gfc_expr *n;
2609 : 0 : bool t, saved_div0;
2610 : :
2611 : 0 : if (e == NULL || e->expr_type == EXPR_CONSTANT)
2612 : : return true;
2613 : :
2614 : 0 : saved_div0 = gfc_seen_div0;
2615 : 0 : gfc_seen_div0 = false;
2616 : 0 : n = gfc_copy_expr (e);
2617 : 0 : t = gfc_simplify_expr (n, type) && !gfc_seen_div0;
2618 : 0 : if (t)
2619 : 0 : gfc_replace_expr (e, n);
2620 : : else
2621 : 0 : gfc_free_expr (n);
2622 : 0 : gfc_seen_div0 = saved_div0;
2623 : 0 : return t;
2624 : : }
2625 : :
2626 : :
2627 : : /* Returns the type of an expression with the exception that iterator
2628 : : variables are automatically integers no matter what else they may
2629 : : be declared as. */
2630 : :
2631 : : static bt
2632 : 4744 : et0 (gfc_expr *e)
2633 : : {
2634 : 4744 : if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
2635 : : return BT_INTEGER;
2636 : :
2637 : 4744 : return e->ts.type;
2638 : : }
2639 : :
2640 : :
2641 : : /* Scalarize an expression for an elemental intrinsic call. */
2642 : :
2643 : : static bool
2644 : 108900 : scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
2645 : : {
2646 : 108900 : gfc_actual_arglist *a, *b;
2647 : 108900 : gfc_constructor_base ctor;
2648 : 108900 : gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */
2649 : 108900 : gfc_constructor *ci, *new_ctor;
2650 : 108900 : gfc_expr *expr, *old, *p;
2651 : 108900 : int n, i, rank[5], array_arg;
2652 : :
2653 : 108900 : if (e == NULL)
2654 : : return false;
2655 : :
2656 : 108900 : a = e->value.function.actual;
2657 : 116617 : for (; a; a = a->next)
2658 : 115891 : if (a->expr && !gfc_is_constant_expr (a->expr))
2659 : : return false;
2660 : :
2661 : : /* Find which, if any, arguments are arrays. Assume that the old
2662 : : expression carries the type information and that the first arg
2663 : : that is an array expression carries all the shape information.*/
2664 : 726 : n = array_arg = 0;
2665 : 726 : a = e->value.function.actual;
2666 : 1439 : for (; a; a = a->next)
2667 : : {
2668 : 1141 : n++;
2669 : 1141 : if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
2670 : 713 : continue;
2671 : 428 : array_arg = n;
2672 : 428 : expr = gfc_copy_expr (a->expr);
2673 : 428 : break;
2674 : : }
2675 : :
2676 : 726 : if (!array_arg)
2677 : : return false;
2678 : :
2679 : 428 : old = gfc_copy_expr (e);
2680 : :
2681 : 428 : gfc_constructor_free (expr->value.constructor);
2682 : 428 : expr->value.constructor = NULL;
2683 : 428 : expr->ts = old->ts;
2684 : 428 : expr->where = old->where;
2685 : 428 : expr->expr_type = EXPR_ARRAY;
2686 : :
2687 : : /* Copy the array argument constructors into an array, with nulls
2688 : : for the scalars. */
2689 : 428 : n = 0;
2690 : 428 : a = old->value.function.actual;
2691 : 1342 : for (; a; a = a->next)
2692 : : {
2693 : : /* Check that this is OK for an initialization expression. */
2694 : 914 : if (a->expr && init_flag && !gfc_check_init_expr (a->expr))
2695 : 0 : goto cleanup;
2696 : :
2697 : 914 : rank[n] = 0;
2698 : 914 : if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2699 : : {
2700 : 0 : rank[n] = a->expr->rank;
2701 : 0 : ctor = a->expr->symtree->n.sym->value->value.constructor;
2702 : 0 : args[n] = gfc_constructor_first (ctor);
2703 : : }
2704 : 914 : else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2705 : : {
2706 : 469 : if (a->expr->rank)
2707 : 469 : rank[n] = a->expr->rank;
2708 : : else
2709 : 0 : rank[n] = 1;
2710 : 469 : ctor = a->expr->value.constructor;
2711 : 469 : args[n] = gfc_constructor_first (ctor);
2712 : : }
2713 : : else
2714 : 445 : args[n] = NULL;
2715 : :
2716 : 914 : n++;
2717 : : }
2718 : :
2719 : : /* Using the array argument as the master, step through the array
2720 : : calling the function for each element and advancing the array
2721 : : constructors together. */
2722 : 3460 : for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2723 : : {
2724 : 3032 : new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2725 : : gfc_copy_expr (old), NULL);
2726 : :
2727 : 3032 : gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2728 : 3032 : a = NULL;
2729 : 3032 : b = old->value.function.actual;
2730 : 9169 : for (i = 0; i < n; i++)
2731 : : {
2732 : 6137 : if (a == NULL)
2733 : 6064 : new_ctor->expr->value.function.actual
2734 : 3032 : = a = gfc_get_actual_arglist ();
2735 : : else
2736 : : {
2737 : 3105 : a->next = gfc_get_actual_arglist ();
2738 : 3105 : a = a->next;
2739 : : }
2740 : :
2741 : 6137 : if (args[i])
2742 : 4033 : a->expr = gfc_copy_expr (args[i]->expr);
2743 : : else
2744 : 2104 : a->expr = gfc_copy_expr (b->expr);
2745 : :
2746 : 6137 : b = b->next;
2747 : : }
2748 : :
2749 : : /* Simplify the function calls. If the simplification fails, the
2750 : : error will be flagged up down-stream or the library will deal
2751 : : with it. */
2752 : 3032 : p = gfc_copy_expr (new_ctor->expr);
2753 : :
2754 : 3032 : if (!gfc_simplify_expr (p, init_flag))
2755 : 13 : gfc_free_expr (p);
2756 : : else
2757 : 3019 : gfc_replace_expr (new_ctor->expr, p);
2758 : :
2759 : 9169 : for (i = 0; i < n; i++)
2760 : 6137 : if (args[i])
2761 : 4033 : args[i] = gfc_constructor_next (args[i]);
2762 : :
2763 : 6137 : for (i = 1; i < n; i++)
2764 : 3105 : if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
2765 : 1133 : || (args[i] == NULL && args[array_arg - 1] != NULL)))
2766 : 0 : goto compliance;
2767 : : }
2768 : :
2769 : 428 : free_expr0 (e);
2770 : 428 : *e = *expr;
2771 : : /* Free "expr" but not the pointers it contains. */
2772 : 428 : free (expr);
2773 : 428 : gfc_free_expr (old);
2774 : 428 : return true;
2775 : :
2776 : 0 : compliance:
2777 : 0 : gfc_error_now ("elemental function arguments at %C are not compliant");
2778 : :
2779 : 0 : cleanup:
2780 : 0 : gfc_free_expr (expr);
2781 : 0 : gfc_free_expr (old);
2782 : 0 : return false;
2783 : : }
2784 : :
2785 : :
2786 : : static bool
2787 : 3724 : check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
2788 : : {
2789 : 3724 : gfc_expr *op1 = e->value.op.op1;
2790 : 3724 : gfc_expr *op2 = e->value.op.op2;
2791 : :
2792 : 3724 : if (!(*check_function)(op1))
2793 : : return false;
2794 : :
2795 : 2867 : switch (e->value.op.op)
2796 : : {
2797 : 513 : case INTRINSIC_UPLUS:
2798 : 513 : case INTRINSIC_UMINUS:
2799 : 513 : if (!numeric_type (et0 (op1)))
2800 : 0 : goto not_numeric;
2801 : : break;
2802 : :
2803 : 145 : case INTRINSIC_EQ:
2804 : 145 : case INTRINSIC_EQ_OS:
2805 : 145 : case INTRINSIC_NE:
2806 : 145 : case INTRINSIC_NE_OS:
2807 : 145 : case INTRINSIC_GT:
2808 : 145 : case INTRINSIC_GT_OS:
2809 : 145 : case INTRINSIC_GE:
2810 : 145 : case INTRINSIC_GE_OS:
2811 : 145 : case INTRINSIC_LT:
2812 : 145 : case INTRINSIC_LT_OS:
2813 : 145 : case INTRINSIC_LE:
2814 : 145 : case INTRINSIC_LE_OS:
2815 : 145 : if (!(*check_function)(op2))
2816 : : return false;
2817 : :
2818 : 217 : if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2819 : 145 : && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2820 : : {
2821 : 0 : gfc_error ("Numeric or CHARACTER operands are required in "
2822 : : "expression at %L", &e->where);
2823 : 0 : return false;
2824 : : }
2825 : : break;
2826 : :
2827 : 2160 : case INTRINSIC_PLUS:
2828 : 2160 : case INTRINSIC_MINUS:
2829 : 2160 : case INTRINSIC_TIMES:
2830 : 2160 : case INTRINSIC_DIVIDE:
2831 : 2160 : case INTRINSIC_POWER:
2832 : 2160 : if (!(*check_function)(op2))
2833 : : return false;
2834 : :
2835 : 1934 : if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2836 : 0 : goto not_numeric;
2837 : :
2838 : : break;
2839 : :
2840 : 1 : case INTRINSIC_CONCAT:
2841 : 1 : if (!(*check_function)(op2))
2842 : : return false;
2843 : :
2844 : 0 : if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2845 : : {
2846 : 0 : gfc_error ("Concatenation operator in expression at %L "
2847 : : "must have two CHARACTER operands", &op1->where);
2848 : 0 : return false;
2849 : : }
2850 : :
2851 : 0 : if (op1->ts.kind != op2->ts.kind)
2852 : : {
2853 : 0 : gfc_error ("Concat operator at %L must concatenate strings of the "
2854 : : "same kind", &e->where);
2855 : 0 : return false;
2856 : : }
2857 : :
2858 : : break;
2859 : :
2860 : 0 : case INTRINSIC_NOT:
2861 : 0 : if (et0 (op1) != BT_LOGICAL)
2862 : : {
2863 : 0 : gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2864 : : "operand", &op1->where);
2865 : 0 : return false;
2866 : : }
2867 : :
2868 : : break;
2869 : :
2870 : 0 : case INTRINSIC_AND:
2871 : 0 : case INTRINSIC_OR:
2872 : 0 : case INTRINSIC_EQV:
2873 : 0 : case INTRINSIC_NEQV:
2874 : 0 : if (!(*check_function)(op2))
2875 : : return false;
2876 : :
2877 : 0 : if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2878 : : {
2879 : 0 : gfc_error ("LOGICAL operands are required in expression at %L",
2880 : : &e->where);
2881 : 0 : return false;
2882 : : }
2883 : :
2884 : : break;
2885 : :
2886 : : case INTRINSIC_PARENTHESES:
2887 : : break;
2888 : :
2889 : 0 : default:
2890 : 0 : gfc_error ("Only intrinsic operators can be used in expression at %L",
2891 : : &e->where);
2892 : 0 : return false;
2893 : : }
2894 : :
2895 : : return true;
2896 : :
2897 : 0 : not_numeric:
2898 : 0 : gfc_error ("Numeric operands are required in expression at %L", &e->where);
2899 : :
2900 : 0 : return false;
2901 : : }
2902 : :
2903 : : /* F2003, 7.1.7 (3): In init expression, allocatable components
2904 : : must not be data-initialized. */
2905 : : static bool
2906 : 1953 : check_alloc_comp_init (gfc_expr *e)
2907 : : {
2908 : 1953 : gfc_component *comp;
2909 : 1953 : gfc_constructor *ctor;
2910 : :
2911 : 1953 : gcc_assert (e->expr_type == EXPR_STRUCTURE);
2912 : 1953 : gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);
2913 : :
2914 : 1953 : for (comp = e->ts.u.derived->components,
2915 : 1953 : ctor = gfc_constructor_first (e->value.constructor);
2916 : 4459 : comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2917 : : {
2918 : 2507 : if (comp->attr.allocatable && ctor->expr
2919 : 31 : && ctor->expr->expr_type != EXPR_NULL)
2920 : : {
2921 : 1 : gfc_error ("Invalid initialization expression for ALLOCATABLE "
2922 : : "component %qs in structure constructor at %L",
2923 : : comp->name, &ctor->expr->where);
2924 : 1 : return false;
2925 : : }
2926 : : }
2927 : :
2928 : : return true;
2929 : : }
2930 : :
2931 : : static match
2932 : 586 : check_init_expr_arguments (gfc_expr *e)
2933 : : {
2934 : 586 : gfc_actual_arglist *ap;
2935 : :
2936 : 1528 : for (ap = e->value.function.actual; ap; ap = ap->next)
2937 : 1255 : if (!gfc_check_init_expr (ap->expr))
2938 : : return MATCH_ERROR;
2939 : :
2940 : : return MATCH_YES;
2941 : : }
2942 : :
2943 : : static bool check_restricted (gfc_expr *);
2944 : :
2945 : : /* F95, 7.1.6.1, Initialization expressions, (7)
2946 : : F2003, 7.1.7 Initialization expression, (8)
2947 : : F2008, 7.1.12 Constant expression, (4) */
2948 : :
2949 : : static match
2950 : 4138 : check_inquiry (gfc_expr *e, int not_restricted)
2951 : : {
2952 : 4138 : const char *name;
2953 : 4138 : const char *const *functions;
2954 : :
2955 : 4138 : static const char *const inquiry_func_f95[] = {
2956 : : "lbound", "shape", "size", "ubound",
2957 : : "bit_size", "len", "kind",
2958 : : "digits", "epsilon", "huge", "maxexponent", "minexponent",
2959 : : "precision", "radix", "range", "tiny",
2960 : : NULL
2961 : : };
2962 : :
2963 : 4138 : static const char *const inquiry_func_f2003[] = {
2964 : : "lbound", "shape", "size", "ubound",
2965 : : "bit_size", "len", "kind",
2966 : : "digits", "epsilon", "huge", "maxexponent", "minexponent",
2967 : : "precision", "radix", "range", "tiny",
2968 : : "new_line", NULL
2969 : : };
2970 : :
2971 : : /* std=f2008+ or -std=gnu */
2972 : 4138 : static const char *const inquiry_func_gnu[] = {
2973 : : "lbound", "shape", "size", "ubound",
2974 : : "bit_size", "len", "kind",
2975 : : "digits", "epsilon", "huge", "maxexponent", "minexponent",
2976 : : "precision", "radix", "range", "tiny",
2977 : : "new_line", "storage_size", NULL
2978 : : };
2979 : :
2980 : 4138 : int i = 0;
2981 : 4138 : gfc_actual_arglist *ap;
2982 : 4138 : gfc_symbol *sym;
2983 : 4138 : gfc_symbol *asym;
2984 : :
2985 : 4138 : if (!e->value.function.isym
2986 : 4032 : || !e->value.function.isym->inquiry)
2987 : : return MATCH_NO;
2988 : :
2989 : : /* An undeclared parameter will get us here (PR25018). */
2990 : 2804 : if (e->symtree == NULL)
2991 : : return MATCH_NO;
2992 : :
2993 : 2802 : sym = e->symtree->n.sym;
2994 : :
2995 : 2802 : if (sym->from_intmod)
2996 : : {
2997 : 2 : if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
2998 : 0 : && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
2999 : 0 : && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
3000 : : return MATCH_NO;
3001 : :
3002 : 2 : if (sym->from_intmod == INTMOD_ISO_C_BINDING
3003 : 2 : && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
3004 : : return MATCH_NO;
3005 : : }
3006 : : else
3007 : : {
3008 : 2800 : name = sym->name;
3009 : :
3010 : 2800 : functions = inquiry_func_gnu;
3011 : 2800 : if (gfc_option.warn_std & GFC_STD_F2003)
3012 : 0 : functions = inquiry_func_f2003;
3013 : 2800 : if (gfc_option.warn_std & GFC_STD_F95)
3014 : 0 : functions = inquiry_func_f95;
3015 : :
3016 : 11757 : for (i = 0; functions[i]; i++)
3017 : 11751 : if (strcmp (functions[i], name) == 0)
3018 : : break;
3019 : :
3020 : 2800 : if (functions[i] == NULL)
3021 : : return MATCH_ERROR;
3022 : : }
3023 : :
3024 : : /* At this point we have an inquiry function with a variable argument. The
3025 : : type of the variable might be undefined, but we need it now, because the
3026 : : arguments of these functions are not allowed to be undefined. */
3027 : :
3028 : 8985 : for (ap = e->value.function.actual; ap; ap = ap->next)
3029 : : {
3030 : 6690 : if (!ap->expr)
3031 : 3273 : continue;
3032 : :
3033 : 3417 : asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL;
3034 : :
3035 : 3417 : if (ap->expr->ts.type == BT_UNKNOWN)
3036 : : {
3037 : 0 : if (asym && asym->ts.type == BT_UNKNOWN
3038 : 0 : && !gfc_set_default_type (asym, 0, gfc_current_ns))
3039 : : return MATCH_NO;
3040 : :
3041 : 0 : ap->expr->ts = asym->ts;
3042 : : }
3043 : :
3044 : 3417 : if (asym && asym->assoc && asym->assoc->target
3045 : 12 : && asym->assoc->target->expr_type == EXPR_CONSTANT)
3046 : : {
3047 : 12 : gfc_free_expr (ap->expr);
3048 : 12 : ap->expr = gfc_copy_expr (asym->assoc->target);
3049 : : }
3050 : :
3051 : : /* Assumed character length will not reduce to a constant expression
3052 : : with LEN, as required by the standard. */
3053 : 3417 : if (i == 5 && not_restricted && asym
3054 : 403 : && asym->ts.type == BT_CHARACTER
3055 : 403 : && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL)
3056 : 49 : || asym->ts.deferred))
3057 : : {
3058 : 354 : gfc_error ("Assumed or deferred character length variable %qs "
3059 : : "in constant expression at %L",
3060 : 354 : asym->name, &ap->expr->where);
3061 : 354 : return MATCH_ERROR;
3062 : : }
3063 : 3063 : else if (not_restricted && !gfc_check_init_expr (ap->expr))
3064 : : return MATCH_ERROR;
3065 : :
3066 : 2921 : if (not_restricted == 0
3067 : 2901 : && ap->expr->expr_type != EXPR_VARIABLE
3068 : 3600 : && !check_restricted (ap->expr))
3069 : : return MATCH_ERROR;
3070 : :
3071 : 2919 : if (not_restricted == 0
3072 : 2899 : && ap->expr->expr_type == EXPR_VARIABLE
3073 : 2222 : && asym->attr.dummy && asym->attr.optional)
3074 : : return MATCH_NO;
3075 : : }
3076 : :
3077 : : return MATCH_YES;
3078 : : }
3079 : :
3080 : :
3081 : : /* F95, 7.1.6.1, Initialization expressions, (5)
3082 : : F2003, 7.1.7 Initialization expression, (5) */
3083 : :
3084 : : static match
3085 : 587 : check_transformational (gfc_expr *e)
3086 : : {
3087 : 587 : static const char * const trans_func_f95[] = {
3088 : : "repeat", "reshape", "selected_int_kind",
3089 : : "selected_real_kind", "transfer", "trim", NULL
3090 : : };
3091 : :
3092 : 587 : static const char * const trans_func_f2003[] = {
3093 : : "all", "any", "count", "dot_product", "matmul", "null", "pack",
3094 : : "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
3095 : : "selected_real_kind", "spread", "sum", "transfer", "transpose",
3096 : : "trim", "unpack", NULL
3097 : : };
3098 : :
3099 : 587 : static const char * const trans_func_f2008[] = {
3100 : : "all", "any", "count", "dot_product", "matmul", "null", "pack",
3101 : : "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
3102 : : "selected_real_kind", "spread", "sum", "transfer", "transpose",
3103 : : "trim", "unpack", "findloc", NULL
3104 : : };
3105 : :
3106 : 587 : static const char * const trans_func_f2023[] = {
3107 : : "all", "any", "count", "dot_product", "matmul", "null", "pack",
3108 : : "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
3109 : : "selected_logical_kind", "selected_real_kind", "spread", "sum", "transfer",
3110 : : "transpose", "trim", "unpack", "findloc", NULL
3111 : : };
3112 : :
3113 : 587 : int i;
3114 : 587 : const char *name;
3115 : 587 : const char *const *functions;
3116 : :
3117 : 587 : if (!e->value.function.isym
3118 : 587 : || !e->value.function.isym->transformational)
3119 : : return MATCH_NO;
3120 : :
3121 : 102 : name = e->symtree->n.sym->name;
3122 : :
3123 : 102 : if (gfc_option.allow_std & GFC_STD_F2023)
3124 : : functions = trans_func_f2023;
3125 : 0 : else if (gfc_option.allow_std & GFC_STD_F2008)
3126 : : functions = trans_func_f2008;
3127 : 0 : else if (gfc_option.allow_std & GFC_STD_F2003)
3128 : : functions = trans_func_f2003;
3129 : : else
3130 : 0 : functions = trans_func_f95;
3131 : :
3132 : : /* NULL() is dealt with below. */
3133 : 102 : if (strcmp ("null", name) == 0)
3134 : : return MATCH_NO;
3135 : :
3136 : 1621 : for (i = 0; functions[i]; i++)
3137 : 1620 : if (strcmp (functions[i], name) == 0)
3138 : : break;
3139 : :
3140 : 102 : if (functions[i] == NULL)
3141 : : {
3142 : 1 : gfc_error ("transformational intrinsic %qs at %L is not permitted "
3143 : : "in an initialization expression", name, &e->where);
3144 : 1 : return MATCH_ERROR;
3145 : : }
3146 : :
3147 : 101 : return check_init_expr_arguments (e);
3148 : : }
3149 : :
3150 : :
3151 : : /* F95, 7.1.6.1, Initialization expressions, (6)
3152 : : F2003, 7.1.7 Initialization expression, (6) */
3153 : :
3154 : : static match
3155 : 587 : check_null (gfc_expr *e)
3156 : : {
3157 : 587 : if (strcmp ("null", e->symtree->n.sym->name) != 0)
3158 : : return MATCH_NO;
3159 : :
3160 : 0 : return check_init_expr_arguments (e);
3161 : : }
3162 : :
3163 : :
3164 : : static match
3165 : 485 : check_elemental (gfc_expr *e)
3166 : : {
3167 : 485 : if (!e->value.function.isym
3168 : 485 : || !e->value.function.isym->elemental)
3169 : : return MATCH_NO;
3170 : :
3171 : 482 : if (e->ts.type != BT_INTEGER
3172 : 2 : && e->ts.type != BT_CHARACTER
3173 : 484 : && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard "
3174 : : "initialization expression at %L", &e->where))
3175 : : return MATCH_ERROR;
3176 : :
3177 : 482 : return check_init_expr_arguments (e);
3178 : : }
3179 : :
3180 : :
3181 : : static match
3182 : 1104 : check_conversion (gfc_expr *e)
3183 : : {
3184 : 1104 : if (!e->value.function.isym
3185 : 1104 : || !e->value.function.isym->conversion)
3186 : : return MATCH_NO;
3187 : :
3188 : 3 : return check_init_expr_arguments (e);
3189 : : }
3190 : :
3191 : :
3192 : : /* Verify that an expression is an initialization expression. A side
3193 : : effect is that the expression tree is reduced to a single constant
3194 : : node if all goes well. This would normally happen when the
3195 : : expression is constructed but function references are assumed to be
3196 : : intrinsics in the context of initialization expressions. If
3197 : : false is returned an error message has been generated. */
3198 : :
3199 : : bool
3200 : 656920 : gfc_check_init_expr (gfc_expr *e)
3201 : : {
3202 : 656920 : match m;
3203 : 656920 : bool t;
3204 : :
3205 : 656920 : if (e == NULL)
3206 : : return true;
3207 : :
3208 : 656879 : switch (e->expr_type)
3209 : : {
3210 : 1096 : case EXPR_OP:
3211 : 1096 : t = check_intrinsic_op (e, gfc_check_init_expr);
3212 : 1096 : if (t)
3213 : 14 : t = gfc_simplify_expr (e, 0);
3214 : :
3215 : : break;
3216 : :
3217 : 1 : case EXPR_CONDITIONAL:
3218 : 1 : t = gfc_check_init_expr (e->value.conditional.condition);
3219 : 1 : if (!t)
3220 : : break;
3221 : 0 : t = gfc_check_init_expr (e->value.conditional.true_expr);
3222 : 0 : if (!t)
3223 : : break;
3224 : 0 : t = gfc_check_init_expr (e->value.conditional.false_expr);
3225 : 0 : if (t)
3226 : 0 : t = gfc_simplify_expr (e, 0);
3227 : : else
3228 : : t = false;
3229 : : break;
3230 : :
3231 : 1662 : case EXPR_FUNCTION:
3232 : 1662 : t = false;
3233 : :
3234 : 1662 : {
3235 : 1662 : bool conversion;
3236 : 1662 : gfc_intrinsic_sym* isym = NULL;
3237 : 1662 : gfc_symbol* sym = e->symtree->n.sym;
3238 : :
3239 : : /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
3240 : : IEEE_EXCEPTIONS modules. */
3241 : 1662 : int mod = sym->from_intmod;
3242 : 1662 : if (mod == INTMOD_NONE && sym->generic)
3243 : 192 : mod = sym->generic->sym->from_intmod;
3244 : 1662 : if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
3245 : : {
3246 : 453 : gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
3247 : 453 : if (new_expr)
3248 : : {
3249 : 327 : gfc_replace_expr (e, new_expr);
3250 : 327 : t = true;
3251 : 327 : break;
3252 : : }
3253 : : }
3254 : :
3255 : : /* If a conversion function, e.g., __convert_i8_i4, was inserted
3256 : : into an array constructor, we need to skip the error check here.
3257 : : Conversion errors are caught below in scalarize_intrinsic_call. */
3258 : 3771 : conversion = e->value.function.isym
3259 : 1335 : && (e->value.function.isym->conversion == 1);
3260 : :
3261 : 1332 : if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
3262 : 1117 : || (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO))
3263 : : {
3264 : 231 : gfc_error ("Function %qs in initialization expression at %L "
3265 : : "must be an intrinsic function",
3266 : 231 : e->symtree->n.sym->name, &e->where);
3267 : 231 : break;
3268 : : }
3269 : :
3270 : 1104 : if ((m = check_conversion (e)) == MATCH_NO
3271 : 1101 : && (m = check_inquiry (e, 1)) == MATCH_NO
3272 : 587 : && (m = check_null (e)) == MATCH_NO
3273 : 587 : && (m = check_transformational (e)) == MATCH_NO
3274 : 1589 : && (m = check_elemental (e)) == MATCH_NO)
3275 : : {
3276 : 3 : gfc_error ("Intrinsic function %qs at %L is not permitted "
3277 : : "in an initialization expression",
3278 : 3 : e->symtree->n.sym->name, &e->where);
3279 : 3 : m = MATCH_ERROR;
3280 : : }
3281 : :
3282 : 1104 : if (m == MATCH_ERROR)
3283 : 815 : return false;
3284 : :
3285 : : /* Try to scalarize an elemental intrinsic function that has an
3286 : : array argument. */
3287 : 289 : isym = gfc_find_function (e->symtree->n.sym->name);
3288 : 289 : if (isym && isym->elemental
3289 : 529 : && (t = scalarize_intrinsic_call (e, true)))
3290 : : break;
3291 : : }
3292 : :
3293 : 289 : if (m == MATCH_YES)
3294 : 289 : t = gfc_simplify_expr (e, 0);
3295 : :
3296 : : break;
3297 : :
3298 : 4385 : case EXPR_VARIABLE:
3299 : 4385 : t = true;
3300 : :
3301 : : /* This occurs when parsing pdt templates. */
3302 : 4385 : if (gfc_expr_attr (e).pdt_kind)
3303 : : break;
3304 : :
3305 : 4377 : if (gfc_check_iter_variable (e))
3306 : : break;
3307 : :
3308 : 4361 : if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
3309 : : {
3310 : : /* A PARAMETER shall not be used to define itself, i.e.
3311 : : REAL, PARAMETER :: x = transfer(0, x)
3312 : : is invalid. */
3313 : 383 : if (!e->symtree->n.sym->value)
3314 : : {
3315 : 9 : gfc_error ("PARAMETER %qs is used at %L before its definition "
3316 : : "is complete", e->symtree->n.sym->name, &e->where);
3317 : 9 : t = false;
3318 : : }
3319 : : else
3320 : 374 : t = simplify_parameter_variable (e, 0);
3321 : :
3322 : : break;
3323 : : }
3324 : :
3325 : 3978 : if (gfc_in_match_data ())
3326 : : break;
3327 : :
3328 : 3961 : t = false;
3329 : :
3330 : 3961 : if (e->symtree->n.sym->as)
3331 : : {
3332 : 155 : switch (e->symtree->n.sym->as->type)
3333 : : {
3334 : 1 : case AS_ASSUMED_SIZE:
3335 : 1 : gfc_error ("Assumed size array %qs at %L is not permitted "
3336 : : "in an initialization expression",
3337 : : e->symtree->n.sym->name, &e->where);
3338 : 1 : break;
3339 : :
3340 : 18 : case AS_ASSUMED_SHAPE:
3341 : 18 : gfc_error ("Assumed shape array %qs at %L is not permitted "
3342 : : "in an initialization expression",
3343 : : e->symtree->n.sym->name, &e->where);
3344 : 18 : break;
3345 : :
3346 : 110 : case AS_DEFERRED:
3347 : 110 : if (!e->symtree->n.sym->attr.allocatable
3348 : 89 : && !e->symtree->n.sym->attr.pointer
3349 : 65 : && e->symtree->n.sym->attr.dummy)
3350 : 65 : gfc_error ("Assumed-shape array %qs at %L is not permitted "
3351 : : "in an initialization expression",
3352 : : e->symtree->n.sym->name, &e->where);
3353 : : else
3354 : 45 : gfc_error ("Deferred array %qs at %L is not permitted "
3355 : : "in an initialization expression",
3356 : : e->symtree->n.sym->name, &e->where);
3357 : : break;
3358 : :
3359 : 20 : case AS_EXPLICIT:
3360 : 20 : gfc_error ("Array %qs at %L is a variable, which does "
3361 : : "not reduce to a constant expression",
3362 : : e->symtree->n.sym->name, &e->where);
3363 : 20 : break;
3364 : :
3365 : 6 : case AS_ASSUMED_RANK:
3366 : 6 : gfc_error ("Assumed-rank array %qs at %L is not permitted "
3367 : : "in an initialization expression",
3368 : : e->symtree->n.sym->name, &e->where);
3369 : 6 : break;
3370 : :
3371 : 0 : default:
3372 : 0 : gcc_unreachable();
3373 : : }
3374 : : }
3375 : : else
3376 : 3806 : gfc_error ("Parameter %qs at %L has not been declared or is "
3377 : : "a variable, which does not reduce to a constant "
3378 : : "expression", e->symtree->name, &e->where);
3379 : :
3380 : : break;
3381 : :
3382 : : case EXPR_CONSTANT:
3383 : : case EXPR_NULL:
3384 : : t = true;
3385 : : break;
3386 : :
3387 : 11 : case EXPR_SUBSTRING:
3388 : 11 : if (e->ref)
3389 : : {
3390 : 7 : t = gfc_check_init_expr (e->ref->u.ss.start);
3391 : 7 : if (!t)
3392 : : break;
3393 : :
3394 : 7 : t = gfc_check_init_expr (e->ref->u.ss.end);
3395 : 7 : if (t)
3396 : 7 : t = gfc_simplify_expr (e, 0);
3397 : : }
3398 : : else
3399 : : t = false;
3400 : : break;
3401 : :
3402 : 2067 : case EXPR_STRUCTURE:
3403 : 2067 : t = e->ts.is_iso_c ? true : false;
3404 : 2067 : if (t)
3405 : : break;
3406 : :
3407 : 1953 : t = check_alloc_comp_init (e);
3408 : 1953 : if (!t)
3409 : : break;
3410 : :
3411 : 1952 : t = gfc_check_constructor (e, gfc_check_init_expr);
3412 : 1952 : if (!t)
3413 : : break;
3414 : :
3415 : 1952 : break;
3416 : :
3417 : 4875 : case EXPR_ARRAY:
3418 : 4875 : t = gfc_check_constructor (e, gfc_check_init_expr);
3419 : 4875 : if (!t)
3420 : : break;
3421 : :
3422 : 4856 : t = gfc_expand_constructor (e, true);
3423 : 4856 : if (!t)
3424 : : break;
3425 : :
3426 : 4835 : t = gfc_check_constructor_type (e);
3427 : 4835 : break;
3428 : :
3429 : 0 : default:
3430 : 0 : gfc_internal_error ("check_init_expr(): Unknown expression type");
3431 : : }
3432 : :
3433 : : return t;
3434 : : }
3435 : :
3436 : : /* Reduces a general expression to an initialization expression (a constant).
3437 : : This used to be part of gfc_match_init_expr.
3438 : : Note that this function doesn't free the given expression on false. */
3439 : :
3440 : : bool
3441 : 297966 : gfc_reduce_init_expr (gfc_expr *expr)
3442 : : {
3443 : 297966 : bool t;
3444 : :
3445 : : /* It is far too early to resolve a class compcall. Punt to resolution. */
3446 : 297966 : if (expr && expr->expr_type == EXPR_COMPCALL
3447 : 25 : && expr->symtree->n.sym->ts.type == BT_CLASS)
3448 : : return false;
3449 : :
3450 : 297941 : gfc_init_expr_flag = true;
3451 : 297941 : t = gfc_resolve_expr (expr);
3452 : 297941 : if (t)
3453 : 297804 : t = gfc_check_init_expr (expr);
3454 : 297941 : gfc_init_expr_flag = false;
3455 : :
3456 : 297941 : if (!t || !expr)
3457 : : return false;
3458 : :
3459 : 293199 : if (expr->expr_type == EXPR_ARRAY)
3460 : : {
3461 : 5081 : if (!gfc_check_constructor_type (expr))
3462 : : return false;
3463 : 5081 : if (!gfc_expand_constructor (expr, true))
3464 : : return false;
3465 : : }
3466 : :
3467 : : return true;
3468 : : }
3469 : :
3470 : :
3471 : : /* Match an initialization expression. We work by first matching an
3472 : : expression, then reducing it to a constant. */
3473 : :
3474 : : match
3475 : 90603 : gfc_match_init_expr (gfc_expr **result)
3476 : : {
3477 : 90603 : gfc_expr *expr;
3478 : 90603 : match m;
3479 : 90603 : bool t;
3480 : :
3481 : 90603 : expr = NULL;
3482 : :
3483 : 90603 : gfc_init_expr_flag = true;
3484 : :
3485 : 90603 : m = gfc_match_expr (&expr);
3486 : 90603 : if (m != MATCH_YES)
3487 : : {
3488 : 113 : gfc_init_expr_flag = false;
3489 : 113 : return m;
3490 : : }
3491 : :
3492 : 90490 : if (expr->expr_type != EXPR_FUNCTION && gfc_derived_parameter_expr (expr))
3493 : : {
3494 : 156 : *result = expr;
3495 : 156 : gfc_init_expr_flag = false;
3496 : 156 : return m;
3497 : : }
3498 : :
3499 : 90334 : t = gfc_reduce_init_expr (expr);
3500 : 90334 : if (!t)
3501 : : {
3502 : 491 : gfc_free_expr (expr);
3503 : 491 : gfc_init_expr_flag = false;
3504 : 491 : return MATCH_ERROR;
3505 : : }
3506 : :
3507 : 89843 : *result = expr;
3508 : 89843 : gfc_init_expr_flag = false;
3509 : :
3510 : 89843 : return MATCH_YES;
3511 : : }
3512 : :
3513 : :
3514 : : /* Given an actual argument list, test to see that each argument is a
3515 : : restricted expression and optionally if the expression type is
3516 : : integer or character. */
3517 : :
3518 : : static bool
3519 : 1335 : restricted_args (gfc_actual_arglist *a)
3520 : : {
3521 : 3393 : for (; a; a = a->next)
3522 : : {
3523 : 2059 : if (!check_restricted (a->expr))
3524 : : return false;
3525 : : }
3526 : :
3527 : : return true;
3528 : : }
3529 : :
3530 : :
3531 : : /************* Restricted/specification expressions *************/
3532 : :
3533 : :
3534 : : /* Make sure a non-intrinsic function is a specification function,
3535 : : * see F08:7.1.11.5. */
3536 : :
3537 : : static bool
3538 : 579 : external_spec_function (gfc_expr *e)
3539 : : {
3540 : 579 : gfc_symbol *f;
3541 : :
3542 : 579 : f = e->value.function.esym;
3543 : :
3544 : : /* IEEE functions allowed are "a reference to a transformational function
3545 : : from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3546 : : "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3547 : : IEEE_EXCEPTIONS". */
3548 : 579 : if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
3549 : 579 : || f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
3550 : : {
3551 : 234 : if (!strcmp (f->name, "ieee_selected_real_kind")
3552 : 216 : || !strcmp (f->name, "ieee_support_rounding")
3553 : 216 : || !strcmp (f->name, "ieee_support_flag")
3554 : 216 : || !strcmp (f->name, "ieee_support_halting")
3555 : 216 : || !strcmp (f->name, "ieee_support_datatype")
3556 : 216 : || !strcmp (f->name, "ieee_support_denormal")
3557 : 216 : || !strcmp (f->name, "ieee_support_subnormal")
3558 : 216 : || !strcmp (f->name, "ieee_support_divide")
3559 : 216 : || !strcmp (f->name, "ieee_support_inf")
3560 : 216 : || !strcmp (f->name, "ieee_support_io")
3561 : 216 : || !strcmp (f->name, "ieee_support_nan")
3562 : 216 : || !strcmp (f->name, "ieee_support_sqrt")
3563 : 216 : || !strcmp (f->name, "ieee_support_standard")
3564 : 216 : || !strcmp (f->name, "ieee_support_underflow_control"))
3565 : 18 : goto function_allowed;
3566 : : }
3567 : :
3568 : 561 : if (f->attr.proc == PROC_ST_FUNCTION)
3569 : : {
3570 : 0 : gfc_error ("Specification function %qs at %L cannot be a statement "
3571 : : "function", f->name, &e->where);
3572 : 0 : return false;
3573 : : }
3574 : :
3575 : 561 : if (f->attr.proc == PROC_INTERNAL)
3576 : : {
3577 : 0 : gfc_error ("Specification function %qs at %L cannot be an internal "
3578 : : "function", f->name, &e->where);
3579 : 0 : return false;
3580 : : }
3581 : :
3582 : 561 : if (!f->attr.pure && !f->attr.elemental)
3583 : : {
3584 : 2 : gfc_error ("Specification function %qs at %L must be PURE", f->name,
3585 : : &e->where);
3586 : 2 : return false;
3587 : : }
3588 : :
3589 : : /* F08:7.1.11.6. */
3590 : 559 : if (f->attr.recursive
3591 : 559 : && !gfc_notify_std (GFC_STD_F2003,
3592 : : "Specification function %qs "
3593 : : "at %L cannot be RECURSIVE", f->name, &e->where))
3594 : : return false;
3595 : :
3596 : 577 : function_allowed:
3597 : 577 : return restricted_args (e->value.function.actual);
3598 : : }
3599 : :
3600 : :
3601 : : /* Check to see that a function reference to an intrinsic is a
3602 : : restricted expression. */
3603 : :
3604 : : static bool
3605 : 3037 : restricted_intrinsic (gfc_expr *e)
3606 : : {
3607 : : /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3608 : 3037 : if (check_inquiry (e, 0) == MATCH_YES)
3609 : : return true;
3610 : :
3611 : 758 : return restricted_args (e->value.function.actual);
3612 : : }
3613 : :
3614 : :
3615 : : /* Check the expressions of an actual arglist. Used by check_restricted. */
3616 : :
3617 : : static bool
3618 : 1336 : check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*))
3619 : : {
3620 : 3377 : for (; arg; arg = arg->next)
3621 : 2049 : if (!checker (arg->expr))
3622 : : return false;
3623 : :
3624 : : return true;
3625 : : }
3626 : :
3627 : :
3628 : : /* Check the subscription expressions of a reference chain with a checking
3629 : : function; used by check_restricted. */
3630 : :
3631 : : static bool
3632 : 15128 : check_references (gfc_ref* ref, bool (*checker) (gfc_expr*))
3633 : : {
3634 : 15990 : int dim;
3635 : :
3636 : 15990 : if (!ref)
3637 : : return true;
3638 : :
3639 : 865 : switch (ref->type)
3640 : : {
3641 : : case REF_ARRAY:
3642 : 1384 : for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3643 : : {
3644 : 699 : if (!checker (ref->u.ar.start[dim]))
3645 : : return false;
3646 : 697 : if (!checker (ref->u.ar.end[dim]))
3647 : : return false;
3648 : 697 : if (!checker (ref->u.ar.stride[dim]))
3649 : : return false;
3650 : : }
3651 : : break;
3652 : :
3653 : : case REF_COMPONENT:
3654 : : /* Nothing needed, just proceed to next reference. */
3655 : : break;
3656 : :
3657 : 13 : case REF_SUBSTRING:
3658 : 13 : if (!checker (ref->u.ss.start))
3659 : : return false;
3660 : 12 : if (!checker (ref->u.ss.end))
3661 : : return false;
3662 : : break;
3663 : :
3664 : 0 : default:
3665 : 0 : gcc_unreachable ();
3666 : 862 : break;
3667 : : }
3668 : :
3669 : 862 : return check_references (ref->next, checker);
3670 : : }
3671 : :
3672 : : /* Return true if ns is a parent of the current ns. */
3673 : :
3674 : : static bool
3675 : 520 : is_parent_of_current_ns (gfc_namespace *ns)
3676 : : {
3677 : 520 : gfc_namespace *p;
3678 : 548 : for (p = gfc_current_ns->parent; p; p = p->parent)
3679 : 533 : if (ns == p)
3680 : : return true;
3681 : :
3682 : : return false;
3683 : : }
3684 : :
3685 : : /* Verify that an expression is a restricted expression. Like its
3686 : : cousin check_init_expr(), an error message is generated if we
3687 : : return false. */
3688 : :
3689 : : static bool
3690 : 437496 : check_restricted (gfc_expr *e)
3691 : : {
3692 : 437496 : gfc_symbol* sym;
3693 : 437496 : bool t;
3694 : :
3695 : 437496 : if (e == NULL)
3696 : : return true;
3697 : :
3698 : 434983 : switch (e->expr_type)
3699 : : {
3700 : 2628 : case EXPR_OP:
3701 : 2628 : t = check_intrinsic_op (e, check_restricted);
3702 : 2628 : if (t)
3703 : 2626 : t = gfc_simplify_expr (e, 0);
3704 : :
3705 : : break;
3706 : :
3707 : 1 : case EXPR_CONDITIONAL:
3708 : 1 : t = check_restricted (e->value.conditional.condition);
3709 : 1 : if (!t)
3710 : : break;
3711 : 1 : t = check_restricted (e->value.conditional.true_expr);
3712 : 1 : if (!t)
3713 : : break;
3714 : 1 : t = check_restricted (e->value.conditional.false_expr);
3715 : 1 : if (t)
3716 : 1 : t = gfc_simplify_expr (e, 0);
3717 : : else
3718 : : t = false;
3719 : : break;
3720 : :
3721 : 3624 : case EXPR_FUNCTION:
3722 : 3624 : if (e->value.function.esym)
3723 : : {
3724 : 579 : t = check_arglist (e->value.function.actual, &check_restricted);
3725 : 579 : if (t)
3726 : 579 : t = external_spec_function (e);
3727 : : }
3728 : : else
3729 : : {
3730 : 3045 : if (e->value.function.isym && e->value.function.isym->inquiry)
3731 : : t = true;
3732 : : else
3733 : 757 : t = check_arglist (e->value.function.actual, &check_restricted);
3734 : :
3735 : 757 : if (t)
3736 : 3037 : t = restricted_intrinsic (e);
3737 : : }
3738 : : break;
3739 : :
3740 : 15134 : case EXPR_VARIABLE:
3741 : 15134 : sym = e->symtree->n.sym;
3742 : 15134 : t = false;
3743 : :
3744 : : /* If a dummy argument appears in a context that is valid for a
3745 : : restricted expression in an elemental procedure, it will have
3746 : : already been simplified away once we get here. Therefore we
3747 : : don't need to jump through hoops to distinguish valid from
3748 : : invalid cases. Allowed in F2008 and F2018. */
3749 : 15134 : if (gfc_notification_std (GFC_STD_F2008)
3750 : 40 : && sym->attr.dummy && sym->ns == gfc_current_ns
3751 : 15174 : && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
3752 : : {
3753 : 4 : gfc_error_now ("Dummy argument %qs not "
3754 : : "allowed in expression at %L",
3755 : : sym->name, &e->where);
3756 : 4 : break;
3757 : : }
3758 : :
3759 : 15130 : if (sym->attr.optional)
3760 : : {
3761 : 2 : gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3762 : : sym->name, &e->where);
3763 : 2 : break;
3764 : : }
3765 : :
3766 : 15128 : if (sym->attr.intent == INTENT_OUT)
3767 : : {
3768 : 0 : gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3769 : : sym->name, &e->where);
3770 : 0 : break;
3771 : : }
3772 : :
3773 : : /* Check reference chain if any. */
3774 : 15128 : if (!check_references (e->ref, &check_restricted))
3775 : : break;
3776 : :
3777 : 15125 : if (e->error
3778 : 15105 : || sym->attr.in_common
3779 : 14910 : || sym->attr.use_assoc
3780 : 11652 : || sym->attr.used_in_submodule
3781 : 11651 : || sym->attr.dummy
3782 : 578 : || sym->attr.implied_index
3783 : 578 : || sym->attr.flavor == FL_PARAMETER
3784 : 16165 : || is_parent_of_current_ns (gfc_get_spec_ns (sym)))
3785 : : {
3786 : : t = true;
3787 : : break;
3788 : : }
3789 : :
3790 : 15 : gfc_error ("Variable %qs cannot appear in the expression at %L",
3791 : : sym->name, &e->where);
3792 : : /* Prevent a repetition of the error. */
3793 : 15 : e->error = 1;
3794 : 15 : break;
3795 : :
3796 : : case EXPR_NULL:
3797 : : case EXPR_CONSTANT:
3798 : : t = true;
3799 : : break;
3800 : :
3801 : 7 : case EXPR_SUBSTRING:
3802 : 7 : t = gfc_specification_expr (e->ref->u.ss.start);
3803 : 7 : if (!t)
3804 : : break;
3805 : :
3806 : 6 : t = gfc_specification_expr (e->ref->u.ss.end);
3807 : 6 : if (t)
3808 : 6 : t = gfc_simplify_expr (e, 0);
3809 : :
3810 : : break;
3811 : :
3812 : 6 : case EXPR_STRUCTURE:
3813 : 6 : t = gfc_check_constructor (e, check_restricted);
3814 : 6 : break;
3815 : :
3816 : 58 : case EXPR_ARRAY:
3817 : 58 : t = gfc_check_constructor (e, check_restricted);
3818 : 58 : break;
3819 : :
3820 : 0 : default:
3821 : 0 : gfc_internal_error ("check_restricted(): Unknown expression type");
3822 : : }
3823 : :
3824 : : return t;
3825 : : }
3826 : :
3827 : :
3828 : : /* Check to see that an expression is a specification expression. If
3829 : : we return false, an error has been generated. */
3830 : :
3831 : : bool
3832 : 459559 : gfc_specification_expr (gfc_expr *e)
3833 : : {
3834 : 459559 : gfc_component *comp;
3835 : :
3836 : 459559 : if (e == NULL)
3837 : : return true;
3838 : :
3839 : 425580 : if (e->ts.type != BT_INTEGER)
3840 : : {
3841 : 26 : gfc_error ("Expression at %L must be of INTEGER type, found %s",
3842 : : &e->where, gfc_basic_typename (e->ts.type));
3843 : 26 : return false;
3844 : : }
3845 : :
3846 : 425554 : comp = gfc_get_proc_ptr_comp (e);
3847 : 425554 : if (e->expr_type == EXPR_FUNCTION
3848 : 2381 : && !e->value.function.isym
3849 : 392 : && !e->value.function.esym
3850 : 109 : && !gfc_pure (e->symtree->n.sym)
3851 : 425656 : && (!comp || !comp->attr.pure))
3852 : : {
3853 : 3 : gfc_error ("Function %qs at %L must be PURE",
3854 : 3 : e->symtree->n.sym->name, &e->where);
3855 : : /* Prevent repeat error messages. */
3856 : 3 : e->symtree->n.sym->attr.pure = 1;
3857 : 3 : return false;
3858 : : }
3859 : :
3860 : 425551 : if (e->rank != 0)
3861 : : {
3862 : 3 : gfc_error ("Expression at %L must be scalar", &e->where);
3863 : 3 : return false;
3864 : : }
3865 : :
3866 : 425548 : if (!gfc_simplify_expr (e, 0))
3867 : : return false;
3868 : :
3869 : 425543 : return check_restricted (e);
3870 : : }
3871 : :
3872 : :
3873 : : /************** Expression conformance checks. *************/
3874 : :
3875 : : /* Given two expressions, make sure that the arrays are conformable. */
3876 : :
3877 : : bool
3878 : 192547 : gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
3879 : : {
3880 : 192547 : int op1_flag, op2_flag, d;
3881 : 192547 : mpz_t op1_size, op2_size;
3882 : 192547 : bool t;
3883 : :
3884 : 192547 : va_list argp;
3885 : 192547 : char buffer[240];
3886 : :
3887 : 192547 : if (op1->rank == 0 || op2->rank == 0)
3888 : : return true;
3889 : :
3890 : 69056 : va_start (argp, optype_msgid);
3891 : 69056 : d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp);
3892 : 69056 : va_end (argp);
3893 : 69056 : if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */
3894 : 0 : gfc_internal_error ("optype_msgid overflow: %d", d);
3895 : :
3896 : 69056 : if (op1->rank != op2->rank)
3897 : : {
3898 : 34 : gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
3899 : : op1->rank, op2->rank, &op1->where);
3900 : 34 : return false;
3901 : : }
3902 : :
3903 : : t = true;
3904 : :
3905 : 166929 : for (d = 0; d < op1->rank; d++)
3906 : : {
3907 : 97975 : op1_flag = gfc_array_dimen_size(op1, d, &op1_size);
3908 : 97975 : op2_flag = gfc_array_dimen_size(op2, d, &op2_size);
3909 : :
3910 : 97975 : if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3911 : : {
3912 : 68 : gfc_error ("Different shape for %s at %L on dimension %d "
3913 : : "(%d and %d)", _(buffer), &op1->where, d + 1,
3914 : 68 : (int) mpz_get_si (op1_size),
3915 : 68 : (int) mpz_get_si (op2_size));
3916 : :
3917 : 68 : t = false;
3918 : : }
3919 : :
3920 : 97975 : if (op1_flag)
3921 : 65089 : mpz_clear (op1_size);
3922 : 97975 : if (op2_flag)
3923 : 74297 : mpz_clear (op2_size);
3924 : :
3925 : 97975 : if (!t)
3926 : : return false;
3927 : : }
3928 : :
3929 : : return true;
3930 : : }
3931 : :
3932 : :
3933 : : /* Given an assignable expression and an arbitrary expression, make
3934 : : sure that the assignment can take place. Only add a call to the intrinsic
3935 : : conversion routines, when allow_convert is set. When this assign is a
3936 : : coarray call, then the convert is done by the coarray routine implicitly and
3937 : : adding the intrinsic conversion would do harm in most cases. */
3938 : :
3939 : : bool
3940 : 761207 : gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
3941 : : bool allow_convert)
3942 : : {
3943 : 761207 : gfc_symbol *sym;
3944 : 761207 : gfc_ref *ref;
3945 : 761207 : int has_pointer;
3946 : :
3947 : 761207 : sym = lvalue->symtree->n.sym;
3948 : :
3949 : : /* See if this is the component or subcomponent of a pointer and guard
3950 : : against assignment to LEN or KIND part-refs. */
3951 : 761207 : has_pointer = sym->attr.pointer;
3952 : 890218 : for (ref = lvalue->ref; ref; ref = ref->next)
3953 : : {
3954 : 129011 : if (!has_pointer && ref->type == REF_COMPONENT
3955 : 38944 : && ref->u.c.component->attr.pointer)
3956 : : has_pointer = 1;
3957 : 128080 : else if (ref->type == REF_INQUIRY
3958 : 92 : && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND))
3959 : : {
3960 : 0 : gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3961 : : "allowed", &lvalue->where);
3962 : 0 : return false;
3963 : : }
3964 : : }
3965 : :
3966 : : /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3967 : : variable local to a function subprogram. Its existence begins when
3968 : : execution of the function is initiated and ends when execution of the
3969 : : function is terminated...
3970 : : Therefore, the left hand side is no longer a variable, when it is: */
3971 : 761207 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3972 : 8294 : && !sym->attr.external)
3973 : : {
3974 : 8284 : bool bad_proc;
3975 : 8284 : bad_proc = false;
3976 : :
3977 : : /* (i) Use associated; */
3978 : 8284 : if (sym->attr.use_assoc)
3979 : 0 : bad_proc = true;
3980 : :
3981 : : /* (ii) The assignment is in the main program; or */
3982 : 8284 : if (gfc_current_ns->proc_name
3983 : 8283 : && gfc_current_ns->proc_name->attr.is_main_program)
3984 : 8284 : bad_proc = true;
3985 : :
3986 : : /* (iii) A module or internal procedure... */
3987 : 8284 : if (gfc_current_ns->proc_name
3988 : 8283 : && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3989 : 4681 : || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3990 : 5883 : && gfc_current_ns->parent
3991 : 5402 : && (!(gfc_current_ns->parent->proc_name->attr.function
3992 : 5249 : || gfc_current_ns->parent->proc_name->attr.subroutine)
3993 : 2880 : || gfc_current_ns->parent->proc_name->attr.is_main_program))
3994 : : {
3995 : : /* ... that is not a function... */
3996 : 4932 : if (gfc_current_ns->proc_name
3997 : 4932 : && !gfc_current_ns->proc_name->attr.function)
3998 : 0 : bad_proc = true;
3999 : :
4000 : : /* ... or is not an entry and has a different name. */
4001 : 4932 : if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
4002 : 8284 : bad_proc = true;
4003 : : }
4004 : :
4005 : : /* (iv) Host associated and not the function symbol or the
4006 : : parent result. This picks up sibling references, which
4007 : : cannot be entries. */
4008 : 8284 : if (!sym->attr.entry
4009 : 7546 : && sym->ns == gfc_current_ns->parent
4010 : 5159 : && sym != gfc_current_ns->proc_name
4011 : 72 : && sym != gfc_current_ns->parent->proc_name->result)
4012 : : bad_proc = true;
4013 : :
4014 : 8283 : if (bad_proc)
4015 : : {
4016 : 1 : gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
4017 : 1 : return false;
4018 : : }
4019 : : }
4020 : : else
4021 : : {
4022 : : /* Reject assigning to an external symbol. For initializers, this
4023 : : was already done before, in resolve_fl_procedure. */
4024 : 752923 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
4025 : 10 : && sym->attr.proc != PROC_MODULE && !rvalue->error)
4026 : : {
4027 : 2 : gfc_error ("Illegal assignment to external procedure at %L",
4028 : : &lvalue->where);
4029 : 2 : return false;
4030 : : }
4031 : : }
4032 : :
4033 : 761204 : if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
4034 : : {
4035 : 25 : gfc_error ("Incompatible ranks %d and %d in assignment at %L",
4036 : : lvalue->rank, rvalue->rank, &lvalue->where);
4037 : 25 : return false;
4038 : : }
4039 : :
4040 : 761179 : if (lvalue->ts.type == BT_UNKNOWN)
4041 : : {
4042 : 0 : gfc_error ("Variable type is UNKNOWN in assignment at %L",
4043 : : &lvalue->where);
4044 : 0 : return false;
4045 : : }
4046 : :
4047 : 761179 : if (rvalue->expr_type == EXPR_NULL)
4048 : : {
4049 : 19 : if (has_pointer && (ref == NULL || ref->next == NULL)
4050 : 8 : && lvalue->symtree->n.sym->attr.data)
4051 : : return true;
4052 : : /* Prevent the following error message for caf-single mode, because there
4053 : : are no teams in single mode and the simplify returns a null then. */
4054 : 12 : else if (!(flag_coarray == GFC_FCOARRAY_SINGLE
4055 : 9 : && rvalue->ts.type == BT_DERIVED
4056 : 9 : && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
4057 : 9 : && rvalue->ts.u.derived->intmod_sym_id
4058 : : == ISOFORTRAN_TEAM_TYPE))
4059 : : {
4060 : 3 : gfc_error ("NULL appears on right-hand side in assignment at %L",
4061 : : &rvalue->where);
4062 : 3 : return false;
4063 : : }
4064 : : }
4065 : :
4066 : : /* This is possibly a typo: x = f() instead of x => f(). */
4067 : 761169 : if (warn_surprising
4068 : 761169 : && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
4069 : 6 : gfc_warning (OPT_Wsurprising,
4070 : : "POINTER-valued function appears on right-hand side of "
4071 : : "assignment at %L", &rvalue->where);
4072 : :
4073 : : /* Check size of array assignments. */
4074 : 75789 : if (lvalue->rank != 0 && rvalue->rank != 0
4075 : 811230 : && !gfc_check_conformance (lvalue, rvalue, _("array assignment")))
4076 : : return false;
4077 : :
4078 : : /* Handle the case of a BOZ literal on the RHS. */
4079 : 761137 : if (rvalue->ts.type == BT_BOZ)
4080 : : {
4081 : 241 : if (lvalue->symtree->n.sym->attr.data)
4082 : : {
4083 : 93 : if (lvalue->ts.type == BT_INTEGER
4084 : 93 : && gfc_boz2int (rvalue, lvalue->ts.kind))
4085 : : return true;
4086 : :
4087 : 2 : if (lvalue->ts.type == BT_REAL
4088 : 2 : && gfc_boz2real (rvalue, lvalue->ts.kind))
4089 : : {
4090 : 2 : if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
4091 : : "be assigned to a REAL variable",
4092 : : &rvalue->where))
4093 : : return false;
4094 : : return true;
4095 : : }
4096 : : }
4097 : :
4098 : 148 : if (!lvalue->symtree->n.sym->attr.data
4099 : 148 : && gfc_invalid_boz ("BOZ literal constant at %L is neither a "
4100 : : "data-stmt-constant nor an actual argument to "
4101 : : "INT, REAL, DBLE, or CMPLX intrinsic function",
4102 : : &rvalue->where))
4103 : : return false;
4104 : :
4105 : 148 : if (lvalue->ts.type == BT_INTEGER
4106 : 148 : && gfc_boz2int (rvalue, lvalue->ts.kind))
4107 : : return true;
4108 : :
4109 : 1 : if (lvalue->ts.type == BT_REAL
4110 : 1 : && gfc_boz2real (rvalue, lvalue->ts.kind))
4111 : : return true;
4112 : :
4113 : 0 : gfc_error ("BOZ literal constant near %L cannot be assigned to a "
4114 : : "%qs variable", &rvalue->where, gfc_typename (lvalue));
4115 : 0 : return false;
4116 : : }
4117 : :
4118 : 760896 : if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
4119 : : {
4120 : 3 : gfc_error ("The assignment to a KIND or LEN component of a "
4121 : : "parameterized type at %L is not allowed",
4122 : : &lvalue->where);
4123 : 3 : return false;
4124 : : }
4125 : :
4126 : 760893 : if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
4127 : : return true;
4128 : :
4129 : : /* Only DATA Statements come here. */
4130 : 19062 : if (!conform)
4131 : : {
4132 : 1524 : locus *where;
4133 : :
4134 : : /* Numeric can be converted to any other numeric. And Hollerith can be
4135 : : converted to any other type. */
4136 : 2817 : if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
4137 : 2127 : || rvalue->ts.type == BT_HOLLERITH)
4138 : 1145 : return true;
4139 : :
4140 : 364 : if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts)
4141 : 91 : || lvalue->ts.type == BT_LOGICAL)
4142 : 364 : && rvalue->ts.type == BT_CHARACTER
4143 : 743 : && rvalue->ts.kind == gfc_default_character_kind)
4144 : : return true;
4145 : :
4146 : 19 : if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
4147 : : return true;
4148 : :
4149 : 18 : where = (GFC_LOCUS_IS_SET (lvalue->where)
4150 : 18 : ? &lvalue->where : &rvalue->where);
4151 : 18 : gfc_error ("Incompatible types in DATA statement at %L; attempted "
4152 : : "conversion of %s to %s", where,
4153 : : gfc_typename (rvalue), gfc_typename (lvalue));
4154 : :
4155 : 18 : return false;
4156 : : }
4157 : :
4158 : : /* Assignment is the only case where character variables of different
4159 : : kind values can be converted into one another. */
4160 : 17538 : if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
4161 : : {
4162 : 366 : if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
4163 : 366 : return gfc_convert_chartype (rvalue, &lvalue->ts);
4164 : : else
4165 : : return true;
4166 : : }
4167 : :
4168 : 17172 : if (!allow_convert)
4169 : : return true;
4170 : :
4171 : 17172 : return gfc_convert_type (rvalue, &lvalue->ts, 1);
4172 : : }
4173 : :
4174 : :
4175 : : /* Check that a pointer assignment is OK. We first check lvalue, and
4176 : : we only check rvalue if it's not an assignment to NULL() or a
4177 : : NULLIFY statement. */
4178 : :
4179 : : bool
4180 : 15887 : gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
4181 : : bool suppress_type_test, bool is_init_expr)
4182 : : {
4183 : 15887 : symbol_attribute attr, lhs_attr;
4184 : 15887 : gfc_ref *ref;
4185 : 15887 : bool is_pure, is_implicit_pure, rank_remap;
4186 : 15887 : int proc_pointer;
4187 : 15887 : bool same_rank;
4188 : :
4189 : 15887 : if (!lvalue->symtree)
4190 : : return false;
4191 : :
4192 : 15886 : lhs_attr = gfc_expr_attr (lvalue);
4193 : 15886 : if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
4194 : : {
4195 : 0 : gfc_error ("Pointer assignment target is not a POINTER at %L",
4196 : : &lvalue->where);
4197 : 0 : return false;
4198 : : }
4199 : :
4200 : 15886 : if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
4201 : 36 : && !lhs_attr.proc_pointer)
4202 : : {
4203 : 0 : gfc_error ("%qs in the pointer assignment at %L cannot be an "
4204 : : "l-value since it is a procedure",
4205 : 0 : lvalue->symtree->n.sym->name, &lvalue->where);
4206 : 0 : return false;
4207 : : }
4208 : :
4209 : 15886 : proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
4210 : :
4211 : 15886 : rank_remap = false;
4212 : 15886 : same_rank = lvalue->rank == rvalue->rank;
4213 : 22798 : for (ref = lvalue->ref; ref; ref = ref->next)
4214 : : {
4215 : 10950 : if (ref->type == REF_COMPONENT)
4216 : 6098 : proc_pointer = ref->u.c.component->attr.proc_pointer;
4217 : :
4218 : 10950 : if (ref->type == REF_ARRAY && ref->next == NULL)
4219 : : {
4220 : 4404 : int dim;
4221 : :
4222 : 4404 : if (ref->u.ar.type == AR_FULL)
4223 : : break;
4224 : :
4225 : 377 : if (ref->u.ar.type != AR_SECTION)
4226 : : {
4227 : 2 : gfc_error ("Expected bounds specification for %qs at %L",
4228 : 2 : lvalue->symtree->n.sym->name, &lvalue->where);
4229 : 2 : return false;
4230 : : }
4231 : :
4232 : 375 : if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
4233 : : "for %qs in pointer assignment at %L",
4234 : 375 : lvalue->symtree->n.sym->name, &lvalue->where))
4235 : : return false;
4236 : :
4237 : : /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
4238 : : *
4239 : : * (C1017) If bounds-spec-list is specified, the number of
4240 : : * bounds-specs shall equal the rank of data-pointer-object.
4241 : : *
4242 : : * If bounds-spec-list appears, it specifies the lower bounds.
4243 : : *
4244 : : * (C1018) If bounds-remapping-list is specified, the number of
4245 : : * bounds-remappings shall equal the rank of data-pointer-object.
4246 : : *
4247 : : * If bounds-remapping-list appears, it specifies the upper and
4248 : : * lower bounds of each dimension of the pointer; the pointer target
4249 : : * shall be simply contiguous or of rank one.
4250 : : *
4251 : : * (C1019) If bounds-remapping-list is not specified, the ranks of
4252 : : * data-pointer-object and data-target shall be the same.
4253 : : *
4254 : : * Thus when bounds are given, all lbounds are necessary and either
4255 : : * all or none of the upper bounds; no strides are allowed. If the
4256 : : * upper bounds are present, we may do rank remapping. */
4257 : 966 : for (dim = 0; dim < ref->u.ar.dimen; ++dim)
4258 : : {
4259 : 600 : if (ref->u.ar.stride[dim])
4260 : : {
4261 : 1 : gfc_error ("Stride must not be present at %L",
4262 : : &lvalue->where);
4263 : 1 : return false;
4264 : : }
4265 : 599 : if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim]))
4266 : : {
4267 : 3 : gfc_error ("Rank remapping requires a "
4268 : : "list of %<lower-bound : upper-bound%> "
4269 : : "specifications at %L", &lvalue->where);
4270 : 3 : return false;
4271 : : }
4272 : 596 : if (!ref->u.ar.start[dim]
4273 : 595 : || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
4274 : : {
4275 : 2 : gfc_error ("Expected list of %<lower-bound :%> or "
4276 : : "list of %<lower-bound : upper-bound%> "
4277 : : "specifications at %L", &lvalue->where);
4278 : 2 : return false;
4279 : : }
4280 : :
4281 : 594 : if (dim == 0)
4282 : 367 : rank_remap = (ref->u.ar.end[dim] != NULL);
4283 : : else
4284 : : {
4285 : 227 : if ((rank_remap && !ref->u.ar.end[dim]))
4286 : : {
4287 : 0 : gfc_error ("Rank remapping requires a "
4288 : : "list of %<lower-bound : upper-bound%> "
4289 : : "specifications at %L", &lvalue->where);
4290 : 0 : return false;
4291 : : }
4292 : 102 : if (!rank_remap && ref->u.ar.end[dim])
4293 : : {
4294 : 0 : gfc_error ("Expected list of %<lower-bound :%> or "
4295 : : "list of %<lower-bound : upper-bound%> "
4296 : : "specifications at %L", &lvalue->where);
4297 : 0 : return false;
4298 : : }
4299 : : }
4300 : : }
4301 : : }
4302 : : }
4303 : :
4304 : 15875 : is_pure = gfc_pure (NULL);
4305 : 15875 : is_implicit_pure = gfc_implicit_pure (NULL);
4306 : :
4307 : : /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
4308 : : kind, etc for lvalue and rvalue must match, and rvalue must be a
4309 : : pure variable if we're in a pure function. */
4310 : 15875 : if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
4311 : : return true;
4312 : :
4313 : : /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
4314 : 8844 : if (lvalue->expr_type == EXPR_VARIABLE
4315 : 8844 : && gfc_is_coindexed (lvalue))
4316 : : {
4317 : 5 : gfc_ref *ref;
4318 : 6 : for (ref = lvalue->ref; ref; ref = ref->next)
4319 : 6 : if (ref->type == REF_ARRAY && ref->u.ar.codimen)
4320 : : {
4321 : 5 : gfc_error ("Pointer object at %L shall not have a coindex",
4322 : : &lvalue->where);
4323 : 5 : return false;
4324 : : }
4325 : : }
4326 : :
4327 : : /* Checks on rvalue for procedure pointer assignments. */
4328 : 8839 : if (proc_pointer)
4329 : : {
4330 : 1246 : char err[200];
4331 : 1246 : gfc_symbol *s1,*s2;
4332 : 1246 : gfc_component *comp1, *comp2;
4333 : 1246 : const char *name;
4334 : :
4335 : 1246 : attr = gfc_expr_attr (rvalue);
4336 : 2251 : if (!((rvalue->expr_type == EXPR_NULL)
4337 : 1240 : || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
4338 : 1119 : || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
4339 : : || (rvalue->expr_type == EXPR_VARIABLE
4340 : 1003 : && attr.flavor == FL_PROCEDURE)))
4341 : : {
4342 : 6 : gfc_error ("Invalid procedure pointer assignment at %L",
4343 : : &rvalue->where);
4344 : 6 : return false;
4345 : : }
4346 : :
4347 : 1240 : if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
4348 : : {
4349 : : /* Check for intrinsics. */
4350 : 999 : gfc_symbol *sym = rvalue->symtree->n.sym;
4351 : 999 : if (!sym->attr.intrinsic
4352 : 999 : && (gfc_is_intrinsic (sym, 0, sym->declared_at)
4353 : 872 : || gfc_is_intrinsic (sym, 1, sym->declared_at)))
4354 : : {
4355 : 37 : sym->attr.intrinsic = 1;
4356 : 37 : gfc_resolve_intrinsic (sym, &rvalue->where);
4357 : 37 : attr = gfc_expr_attr (rvalue);
4358 : : }
4359 : : /* Check for result of embracing function. */
4360 : 999 : if (sym->attr.function && sym->result == sym)
4361 : : {
4362 : 373 : gfc_namespace *ns;
4363 : :
4364 : 819 : for (ns = gfc_current_ns; ns; ns = ns->parent)
4365 : 450 : if (sym == ns->proc_name)
4366 : : {
4367 : 4 : gfc_error ("Function result %qs is invalid as proc-target "
4368 : : "in procedure pointer assignment at %L",
4369 : : sym->name, &rvalue->where);
4370 : 4 : return false;
4371 : : }
4372 : : }
4373 : : }
4374 : 1236 : if (attr.abstract)
4375 : : {
4376 : 1 : gfc_error ("Abstract interface %qs is invalid "
4377 : : "in procedure pointer assignment at %L",
4378 : 1 : rvalue->symtree->name, &rvalue->where);
4379 : 1 : return false;
4380 : : }
4381 : : /* Check for F08:C729. */
4382 : 1235 : if (attr.flavor == FL_PROCEDURE)
4383 : : {
4384 : 1229 : if (attr.proc == PROC_ST_FUNCTION)
4385 : : {
4386 : 1 : gfc_error ("Statement function %qs is invalid "
4387 : : "in procedure pointer assignment at %L",
4388 : 1 : rvalue->symtree->name, &rvalue->where);
4389 : 1 : return false;
4390 : : }
4391 : 1559 : if (attr.proc == PROC_INTERNAL &&
4392 : 331 : !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs "
4393 : : "is invalid in procedure pointer assignment "
4394 : 331 : "at %L", rvalue->symtree->name, &rvalue->where))
4395 : : return false;
4396 : 1354 : if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
4397 : 127 : attr.subroutine) == 0)
4398 : : {
4399 : 1 : gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
4400 : 1 : "assignment", rvalue->symtree->name, &rvalue->where);
4401 : 1 : return false;
4402 : : }
4403 : : }
4404 : : /* Check for F08:C730. */
4405 : 1232 : if (attr.elemental && !attr.intrinsic)
4406 : : {
4407 : 1 : gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
4408 : : "in procedure pointer assignment at %L",
4409 : 1 : rvalue->symtree->name, &rvalue->where);
4410 : 1 : return false;
4411 : : }
4412 : :
4413 : : /* Ensure that the calling convention is the same. As other attributes
4414 : : such as DLLEXPORT may differ, one explicitly only tests for the
4415 : : calling conventions. */
4416 : 1231 : if (rvalue->expr_type == EXPR_VARIABLE
4417 : 1104 : && lvalue->symtree->n.sym->attr.ext_attr
4418 : 1104 : != rvalue->symtree->n.sym->attr.ext_attr)
4419 : : {
4420 : 10 : symbol_attribute calls;
4421 : :
4422 : 10 : calls.ext_attr = 0;
4423 : 10 : gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
4424 : 10 : gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
4425 : 10 : gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
4426 : :
4427 : 10 : if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
4428 : 10 : != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
4429 : : {
4430 : 10 : gfc_error ("Mismatch in the procedure pointer assignment "
4431 : : "at %L: mismatch in the calling convention",
4432 : : &rvalue->where);
4433 : 10 : return false;
4434 : : }
4435 : : }
4436 : :
4437 : 1221 : comp1 = gfc_get_proc_ptr_comp (lvalue);
4438 : 1221 : if (comp1)
4439 : 381 : s1 = comp1->ts.interface;
4440 : : else
4441 : : {
4442 : 840 : s1 = lvalue->symtree->n.sym;
4443 : 840 : if (s1->ts.interface)
4444 : 635 : s1 = s1->ts.interface;
4445 : : }
4446 : :
4447 : 1221 : comp2 = gfc_get_proc_ptr_comp (rvalue);
4448 : 1221 : if (comp2)
4449 : : {
4450 : 67 : if (rvalue->expr_type == EXPR_FUNCTION)
4451 : : {
4452 : 6 : s2 = comp2->ts.interface->result;
4453 : 6 : name = s2->name;
4454 : : }
4455 : : else
4456 : : {
4457 : 61 : s2 = comp2->ts.interface;
4458 : 61 : name = comp2->name;
4459 : : }
4460 : : }
4461 : 1154 : else if (rvalue->expr_type == EXPR_FUNCTION)
4462 : : {
4463 : 115 : if (rvalue->value.function.esym)
4464 : 115 : s2 = rvalue->value.function.esym->result;
4465 : : else
4466 : 0 : s2 = rvalue->symtree->n.sym->result;
4467 : :
4468 : 115 : name = s2->name;
4469 : : }
4470 : : else
4471 : : {
4472 : 1039 : s2 = rvalue->symtree->n.sym;
4473 : 1039 : name = s2->name;
4474 : : }
4475 : :
4476 : 1221 : if (s2 && s2->attr.proc_pointer && s2->ts.interface)
4477 : 1221 : s2 = s2->ts.interface;
4478 : :
4479 : : /* Special check for the case of absent interface on the lvalue.
4480 : : * All other interface checks are done below. */
4481 : 1221 : if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
4482 : : {
4483 : 1 : gfc_error ("Interface mismatch in procedure pointer assignment "
4484 : : "at %L: %qs is not a subroutine", &rvalue->where, name);
4485 : 1 : return false;
4486 : : }
4487 : :
4488 : : /* F08:7.2.2.4 (4) */
4489 : 1218 : if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err)))
4490 : : {
4491 : 250 : if (comp1 && !s1)
4492 : : {
4493 : 2 : gfc_error ("Explicit interface required for component %qs at %L: %s",
4494 : : comp1->name, &lvalue->where, err);
4495 : 2 : return false;
4496 : : }
4497 : 248 : else if (s1->attr.if_source == IFSRC_UNKNOWN)
4498 : : {
4499 : 2 : gfc_error ("Explicit interface required for %qs at %L: %s",
4500 : : s1->name, &lvalue->where, err);
4501 : 2 : return false;
4502 : : }
4503 : : }
4504 : 1216 : if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err)))
4505 : : {
4506 : 262 : if (comp2 && !s2)
4507 : : {
4508 : 2 : gfc_error ("Explicit interface required for component %qs at %L: %s",
4509 : : comp2->name, &rvalue->where, err);
4510 : 2 : return false;
4511 : : }
4512 : 260 : else if (s2->attr.if_source == IFSRC_UNKNOWN)
4513 : : {
4514 : 2 : gfc_error ("Explicit interface required for %qs at %L: %s",
4515 : : s2->name, &rvalue->where, err);
4516 : 2 : return false;
4517 : : }
4518 : : }
4519 : :
4520 : 1212 : if (s1 == s2 || !s1 || !s2)
4521 : : return true;
4522 : :
4523 : 716 : if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
4524 : : err, sizeof(err), NULL, NULL))
4525 : : {
4526 : 23 : gfc_error ("Interface mismatch in procedure pointer assignment "
4527 : : "at %L: %s", &rvalue->where, err);
4528 : 23 : return false;
4529 : : }
4530 : :
4531 : : /* Check F2008Cor2, C729. */
4532 : 693 : if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
4533 : 102 : && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
4534 : : {
4535 : 1 : gfc_error ("Procedure pointer target %qs at %L must be either an "
4536 : : "intrinsic, host or use associated, referenced or have "
4537 : : "the EXTERNAL attribute", s2->name, &rvalue->where);
4538 : 1 : return false;
4539 : : }
4540 : :
4541 : : return true;
4542 : : }
4543 : : else
4544 : : {
4545 : : /* A non-proc pointer cannot point to a constant. */
4546 : 7593 : if (rvalue->expr_type == EXPR_CONSTANT)
4547 : : {
4548 : 2 : gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4549 : : &rvalue->where);
4550 : 2 : return false;
4551 : : }
4552 : : }
4553 : :
4554 : 7591 : if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
4555 : : {
4556 : : /* Check for F03:C717. */
4557 : 11 : if (UNLIMITED_POLY (rvalue)
4558 : 1 : && !(UNLIMITED_POLY (lvalue)
4559 : 1 : || (lvalue->ts.type == BT_DERIVED
4560 : 0 : && (lvalue->ts.u.derived->attr.is_bind_c
4561 : 0 : || lvalue->ts.u.derived->attr.sequence))))
4562 : 1 : gfc_error ("Data-pointer-object at %L must be unlimited "
4563 : : "polymorphic, or of a type with the BIND or SEQUENCE "
4564 : : "attribute, to be compatible with an unlimited "
4565 : : "polymorphic target", &lvalue->where);
4566 : 10 : else if (!suppress_type_test)
4567 : 8 : gfc_error ("Different types in pointer assignment at %L; "
4568 : : "attempted assignment of %s to %s", &lvalue->where,
4569 : : gfc_typename (rvalue), gfc_typename (lvalue));
4570 : 11 : return false;
4571 : : }
4572 : :
4573 : 7580 : if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
4574 : : {
4575 : 0 : gfc_error ("Different kind type parameters in pointer "
4576 : : "assignment at %L", &lvalue->where);
4577 : 0 : return false;
4578 : : }
4579 : :
4580 : 7580 : if (lvalue->rank != rvalue->rank && !rank_remap
4581 : 64 : && !(rvalue->expr_type == EXPR_NULL && is_init_expr))
4582 : : {
4583 : 4 : gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
4584 : 4 : return false;
4585 : : }
4586 : :
4587 : : /* Make sure the vtab is present. */
4588 : 7576 : if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
4589 : 1316 : gfc_find_vtab (&rvalue->ts);
4590 : :
4591 : : /* Check rank remapping. */
4592 : 7576 : if (rank_remap)
4593 : : {
4594 : 240 : mpz_t lsize, rsize;
4595 : :
4596 : : /* If this can be determined, check that the target must be at least as
4597 : : large as the pointer assigned to it is. */
4598 : 240 : bool got_lsize = gfc_array_size (lvalue, &lsize);
4599 : 240 : bool got_rsize = got_lsize && gfc_array_size (rvalue, &rsize);
4600 : 87 : bool too_small = got_rsize && mpz_cmp (rsize, lsize) < 0;
4601 : :
4602 : 240 : if (too_small)
4603 : : {
4604 : 4 : gfc_error ("Rank remapping target is smaller than size of the"
4605 : : " pointer (%ld < %ld) at %L",
4606 : : mpz_get_si (rsize), mpz_get_si (lsize),
4607 : : &lvalue->where);
4608 : 4 : mpz_clear (lsize);
4609 : 4 : mpz_clear (rsize);
4610 : 8 : return false;
4611 : : }
4612 : 236 : if (got_lsize)
4613 : 151 : mpz_clear (lsize);
4614 : 236 : if (got_rsize)
4615 : 83 : mpz_clear (rsize);
4616 : :
4617 : : /* An assumed rank target is an experimental F202y feature. */
4618 : 236 : if (rvalue->rank == -1 && !(gfc_option.allow_std & GFC_STD_F202Y))
4619 : : {
4620 : 1 : gfc_error ("The assumed rank target at %L is an experimental F202y "
4621 : : "feature. Use option -std=f202y to enable",
4622 : : &rvalue->where);
4623 : 1 : return false;
4624 : : }
4625 : :
4626 : : /* The target must be either rank one or it must be simply contiguous
4627 : : and F2008 must be allowed. */
4628 : 235 : if (rvalue->rank != 1 && rvalue->rank != -1)
4629 : : {
4630 : 21 : if (!gfc_is_simply_contiguous (rvalue, true, false))
4631 : : {
4632 : 2 : gfc_error ("Rank remapping target must be rank 1 or"
4633 : : " simply contiguous at %L", &rvalue->where);
4634 : 2 : return false;
4635 : : }
4636 : 19 : if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not "
4637 : : "rank 1 at %L", &rvalue->where))
4638 : : return false;
4639 : : }
4640 : : }
4641 : 7336 : else if (rvalue->rank == -1)
4642 : : {
4643 : 0 : gfc_error ("The data-target at %L is an assumed rank object and so the "
4644 : : "data-pointer-object %s must have a bounds remapping list "
4645 : : "(list of lbound:ubound for each dimension)",
4646 : 0 : &rvalue->where, lvalue->symtree->name);
4647 : 0 : return false;
4648 : : }
4649 : :
4650 : 7568 : if (rvalue->rank == -1 && !gfc_is_simply_contiguous (rvalue, true, false))
4651 : : {
4652 : 0 : gfc_error ("The assumed rank data-target at %L must be contiguous",
4653 : : &rvalue->where);
4654 : 0 : return false;
4655 : : }
4656 : :
4657 : : /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4658 : 7568 : if (rvalue->expr_type == EXPR_NULL)
4659 : : return true;
4660 : :
4661 : 7481 : if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
4662 : 549 : lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
4663 : :
4664 : 7481 : attr = gfc_expr_attr (rvalue);
4665 : :
4666 : 7481 : if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
4667 : : {
4668 : : /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4669 : : to caf_get. Map this to the same error message as below when it is
4670 : : still a variable expression. */
4671 : 1 : if (rvalue->value.function.isym
4672 : 0 : && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET)
4673 : : /* The test above might need to be extend when F08, Note 5.4 has to be
4674 : : interpreted in the way that target and pointer with the same coindex
4675 : : are allowed. */
4676 : 0 : gfc_error ("Data target at %L shall not have a coindex",
4677 : : &rvalue->where);
4678 : : else
4679 : 1 : gfc_error ("Target expression in pointer assignment "
4680 : : "at %L must deliver a pointer result",
4681 : : &rvalue->where);
4682 : 1 : return false;
4683 : : }
4684 : :
4685 : 7480 : if (is_init_expr)
4686 : : {
4687 : 245 : gfc_symbol *sym;
4688 : 245 : bool target;
4689 : 245 : gfc_ref *ref;
4690 : :
4691 : 245 : if (gfc_is_size_zero_array (rvalue))
4692 : : {
4693 : 1 : gfc_error ("Zero-sized array detected at %L where an entity with "
4694 : : "the TARGET attribute is expected", &rvalue->where);
4695 : 1 : return false;
4696 : : }
4697 : 244 : else if (!rvalue->symtree)
4698 : : {
4699 : 1 : gfc_error ("Pointer assignment target in initialization expression "
4700 : : "does not have the TARGET attribute at %L",
4701 : : &rvalue->where);
4702 : 1 : return false;
4703 : : }
4704 : :
4705 : 243 : sym = rvalue->symtree->n.sym;
4706 : :
4707 : 243 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
4708 : 0 : target = CLASS_DATA (sym)->attr.target;
4709 : : else
4710 : 243 : target = sym->attr.target;
4711 : :
4712 : 243 : if (!target && !proc_pointer)
4713 : : {
4714 : 4 : gfc_error ("Pointer assignment target in initialization expression "
4715 : : "does not have the TARGET attribute at %L",
4716 : : &rvalue->where);
4717 : 4 : return false;
4718 : : }
4719 : :
4720 : 312 : for (ref = rvalue->ref; ref; ref = ref->next)
4721 : : {
4722 : 78 : switch (ref->type)
4723 : : {
4724 : : case REF_ARRAY:
4725 : 47 : for (int n = 0; n < ref->u.ar.dimen; n++)
4726 : 25 : if (!gfc_is_constant_expr (ref->u.ar.start[n])
4727 : 23 : || !gfc_is_constant_expr (ref->u.ar.end[n])
4728 : 47 : || !gfc_is_constant_expr (ref->u.ar.stride[n]))
4729 : : {
4730 : 3 : gfc_error ("Every subscript of target specification "
4731 : : "at %L must be a constant expression",
4732 : : &ref->u.ar.where);
4733 : 3 : return false;
4734 : : }
4735 : : break;
4736 : :
4737 : 5 : case REF_SUBSTRING:
4738 : 5 : if (!gfc_is_constant_expr (ref->u.ss.start)
4739 : 5 : || !gfc_is_constant_expr (ref->u.ss.end))
4740 : : {
4741 : 2 : gfc_error ("Substring starting and ending points of target "
4742 : : "specification at %L must be constant expressions",
4743 : 2 : &ref->u.ss.start->where);
4744 : 2 : return false;
4745 : : }
4746 : : break;
4747 : :
4748 : : default:
4749 : : break;
4750 : : }
4751 : : }
4752 : : }
4753 : : else
4754 : : {
4755 : 7235 : if (!attr.target && !attr.pointer)
4756 : : {
4757 : 9 : gfc_error ("Pointer assignment target is neither TARGET "
4758 : : "nor POINTER at %L", &rvalue->where);
4759 : 9 : return false;
4760 : : }
4761 : : }
4762 : :
4763 : 7460 : if (lvalue->ts.type == BT_CHARACTER)
4764 : : {
4765 : 1253 : bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
4766 : 1253 : if (!t)
4767 : : return false;
4768 : : }
4769 : :
4770 : 7458 : if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
4771 : : {
4772 : 3 : gfc_error ("Bad target in pointer assignment in PURE "
4773 : : "procedure at %L", &rvalue->where);
4774 : : }
4775 : :
4776 : 7458 : if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
4777 : 290 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
4778 : :
4779 : 7458 : if (gfc_has_vector_index (rvalue))
4780 : : {
4781 : 2 : gfc_error ("Pointer assignment with vector subscript "
4782 : : "on rhs at %L", &rvalue->where);
4783 : 2 : return false;
4784 : : }
4785 : :
4786 : 7456 : if (attr.is_protected && attr.use_assoc
4787 : 4 : && !(attr.pointer || attr.proc_pointer))
4788 : : {
4789 : 3 : gfc_error ("Pointer assignment target has PROTECTED "
4790 : : "attribute at %L", &rvalue->where);
4791 : 3 : return false;
4792 : : }
4793 : :
4794 : : /* F2008, C725. For PURE also C1283. */
4795 : 7453 : if (rvalue->expr_type == EXPR_VARIABLE
4796 : 7453 : && gfc_is_coindexed (rvalue))
4797 : : {
4798 : 4 : gfc_ref *ref;
4799 : 5 : for (ref = rvalue->ref; ref; ref = ref->next)
4800 : 5 : if (ref->type == REF_ARRAY && ref->u.ar.codimen)
4801 : : {
4802 : 4 : gfc_error ("Data target at %L shall not have a coindex",
4803 : : &rvalue->where);
4804 : 4 : return false;
4805 : : }
4806 : : }
4807 : :
4808 : : /* Warn for assignments of contiguous pointers to targets which is not
4809 : : contiguous. Be lenient in the definition of what counts as
4810 : : contiguous. */
4811 : :
4812 : 7449 : if (lhs_attr.contiguous
4813 : 74 : && lhs_attr.dimension > 0)
4814 : : {
4815 : 70 : if (gfc_is_not_contiguous (rvalue))
4816 : : {
4817 : 6 : gfc_error ("Assignment to contiguous pointer from "
4818 : : "non-contiguous target at %L", &rvalue->where);
4819 : 6 : return false;
4820 : : }
4821 : 64 : if (!gfc_is_simply_contiguous (rvalue, false, true))
4822 : 14 : gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
4823 : : "non-contiguous target at %L", &rvalue->where);
4824 : : }
4825 : :
4826 : : /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4827 : 7443 : if (warn_target_lifetime
4828 : 15 : && rvalue->expr_type == EXPR_VARIABLE
4829 : 15 : && !rvalue->symtree->n.sym->attr.save
4830 : 15 : && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer
4831 : 13 : && !rvalue->symtree->n.sym->attr.host_assoc
4832 : 11 : && !rvalue->symtree->n.sym->attr.in_common
4833 : 11 : && !rvalue->symtree->n.sym->attr.use_assoc
4834 : 11 : && !rvalue->symtree->n.sym->attr.dummy)
4835 : : {
4836 : 9 : bool warn;
4837 : 9 : gfc_namespace *ns;
4838 : :
4839 : 18 : warn = lvalue->symtree->n.sym->attr.dummy
4840 : 9 : || lvalue->symtree->n.sym->attr.result
4841 : 8 : || lvalue->symtree->n.sym->attr.function
4842 : 7 : || (lvalue->symtree->n.sym->attr.host_assoc
4843 : 4 : && lvalue->symtree->n.sym->ns
4844 : 4 : != rvalue->symtree->n.sym->ns)
4845 : 4 : || lvalue->symtree->n.sym->attr.use_assoc
4846 : 13 : || lvalue->symtree->n.sym->attr.in_common;
4847 : :
4848 : 9 : if (rvalue->symtree->n.sym->ns->proc_name
4849 : 9 : && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE
4850 : 3 : && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM)
4851 : : for (ns = rvalue->symtree->n.sym->ns;
4852 : 5 : ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
4853 : : ns = ns->parent)
4854 : 3 : if (ns->parent == lvalue->symtree->n.sym->ns)
4855 : : {
4856 : : warn = true;
4857 : : break;
4858 : : }
4859 : :
4860 : 9 : if (warn)
4861 : 5 : gfc_warning (OPT_Wtarget_lifetime,
4862 : : "Pointer at %L in pointer assignment might outlive the "
4863 : : "pointer target", &lvalue->where);
4864 : : }
4865 : :
4866 : : return true;
4867 : : }
4868 : :
4869 : :
4870 : : /* Relative of gfc_check_assign() except that the lvalue is a single
4871 : : symbol. Used for initialization assignments. */
4872 : :
4873 : : bool
4874 : 477716 : gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
4875 : : {
4876 : 477716 : gfc_expr lvalue;
4877 : 477716 : bool r;
4878 : 477716 : bool pointer, proc_pointer;
4879 : :
4880 : 477716 : memset (&lvalue, '\0', sizeof (gfc_expr));
4881 : :
4882 : 477716 : if (sym && sym->attr.pdt_template && comp && comp->initializer)
4883 : : {
4884 : 151 : int i, flag;
4885 : 151 : gfc_expr *param_expr;
4886 : 151 : flag = 0;
4887 : :
4888 : 151 : if (comp->as && comp->as->type == AS_EXPLICIT
4889 : 7 : && !(comp->ts.type == BT_DERIVED
4890 : 6 : && comp->ts.u.derived->attr.pdt_template))
4891 : : {
4892 : : /* Are the bounds of the array parameterized? */
4893 : 2 : for (i = 0; i < comp->as->rank; i++)
4894 : : {
4895 : 1 : param_expr = gfc_copy_expr (comp->as->lower[i]);
4896 : 1 : if (gfc_simplify_expr (param_expr, 1)
4897 : 1 : && param_expr->expr_type != EXPR_CONSTANT)
4898 : 0 : flag++;
4899 : 1 : gfc_free_expr (param_expr);
4900 : 1 : param_expr = gfc_copy_expr (comp->as->upper[i]);
4901 : 1 : if (gfc_simplify_expr (param_expr, 1)
4902 : 1 : && param_expr->expr_type != EXPR_CONSTANT)
4903 : 1 : flag++;
4904 : 1 : gfc_free_expr (param_expr);
4905 : : }
4906 : : }
4907 : :
4908 : : /* Is the character length parameterized? */
4909 : 151 : if (comp->ts.type == BT_CHARACTER && comp->ts.u.cl->length)
4910 : : {
4911 : 1 : param_expr = gfc_copy_expr (comp->ts.u.cl->length);
4912 : 1 : if (gfc_simplify_expr (param_expr, 1)
4913 : 1 : && param_expr->expr_type != EXPR_CONSTANT)
4914 : 1 : flag++;
4915 : 1 : gfc_free_expr (param_expr);
4916 : : }
4917 : :
4918 : 151 : if (flag)
4919 : : {
4920 : 2 : gfc_error ("The component %qs at %L of derived type %qs has "
4921 : : "paramterized type or array length parameters, which is "
4922 : : "not compatible with a default initializer",
4923 : 2 : comp->name, &comp->initializer->where, sym->name);
4924 : 2 : return false;
4925 : : }
4926 : : }
4927 : :
4928 : 477714 : lvalue.expr_type = EXPR_VARIABLE;
4929 : 477714 : lvalue.ts = sym->ts;
4930 : 477714 : if (sym->as)
4931 : : {
4932 : 16483 : lvalue.rank = sym->as->rank;
4933 : 16483 : lvalue.corank = sym->as->corank;
4934 : : }
4935 : 477714 : lvalue.symtree = XCNEW (gfc_symtree);
4936 : 477714 : lvalue.symtree->n.sym = sym;
4937 : 477714 : lvalue.where = sym->declared_at;
4938 : :
4939 : 477714 : if (comp)
4940 : : {
4941 : 27693 : lvalue.ref = gfc_get_ref ();
4942 : 27693 : lvalue.ref->type = REF_COMPONENT;
4943 : 27693 : lvalue.ref->u.c.component = comp;
4944 : 27693 : lvalue.ref->u.c.sym = sym;
4945 : 27693 : lvalue.ts = comp->ts;
4946 : 27693 : lvalue.rank = comp->as ? comp->as->rank : 0;
4947 : 27693 : lvalue.corank = comp->as ? comp->as->corank : 0;
4948 : 27693 : lvalue.where = comp->loc;
4949 : 1016 : pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)
4950 : 28709 : ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
4951 : 27693 : proc_pointer = comp->attr.proc_pointer;
4952 : : }
4953 : : else
4954 : : {
4955 : 2706 : pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)
4956 : 452727 : ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
4957 : 450021 : proc_pointer = sym->attr.proc_pointer;
4958 : : }
4959 : :
4960 : 477714 : if (pointer || proc_pointer)
4961 : 5519 : r = gfc_check_pointer_assign (&lvalue, rvalue, false, true);
4962 : : else
4963 : : {
4964 : : /* If a conversion function, e.g., __convert_i8_i4, was inserted
4965 : : into an array constructor, we should check if it can be reduced
4966 : : as an initialization expression. */
4967 : 472195 : if (rvalue->expr_type == EXPR_FUNCTION
4968 : 43 : && rvalue->value.function.isym
4969 : 30 : && (rvalue->value.function.isym->conversion == 1))
4970 : 0 : gfc_check_init_expr (rvalue);
4971 : :
4972 : 472195 : r = gfc_check_assign (&lvalue, rvalue, 1);
4973 : : }
4974 : :
4975 : 477714 : free (lvalue.symtree);
4976 : 477714 : free (lvalue.ref);
4977 : :
4978 : 477714 : if (!r)
4979 : : return r;
4980 : :
4981 : 477663 : if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer)
4982 : : {
4983 : : /* F08:C461. Additional checks for pointer initialization. */
4984 : 227 : symbol_attribute attr;
4985 : 227 : attr = gfc_expr_attr (rvalue);
4986 : 227 : if (attr.allocatable)
4987 : : {
4988 : 2 : gfc_error ("Pointer initialization target at %L "
4989 : : "must not be ALLOCATABLE", &rvalue->where);
4990 : 13 : return false;
4991 : : }
4992 : 225 : if (!attr.target || attr.pointer)
4993 : : {
4994 : 1 : gfc_error ("Pointer initialization target at %L "
4995 : : "must have the TARGET attribute", &rvalue->where);
4996 : 1 : return false;
4997 : : }
4998 : :
4999 : 224 : if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
5000 : 14 : && rvalue->symtree->n.sym->ns->proc_name
5001 : 14 : && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
5002 : : {
5003 : 4 : rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
5004 : 4 : attr.save = SAVE_IMPLICIT;
5005 : : }
5006 : :
5007 : 224 : if (!attr.save)
5008 : : {
5009 : 10 : gfc_error ("Pointer initialization target at %L "
5010 : : "must have the SAVE attribute", &rvalue->where);
5011 : 10 : return false;
5012 : : }
5013 : : }
5014 : :
5015 : 477650 : if (proc_pointer && rvalue->expr_type != EXPR_NULL)
5016 : : {
5017 : : /* F08:C1220. Additional checks for procedure pointer initialization. */
5018 : 59 : symbol_attribute attr = gfc_expr_attr (rvalue);
5019 : 59 : if (attr.proc_pointer)
5020 : : {
5021 : 1 : gfc_error ("Procedure pointer initialization target at %L "
5022 : : "may not be a procedure pointer", &rvalue->where);
5023 : 3 : return false;
5024 : : }
5025 : 58 : if (attr.proc == PROC_INTERNAL)
5026 : : {
5027 : 1 : gfc_error ("Internal procedure %qs is invalid in "
5028 : : "procedure pointer initialization at %L",
5029 : 1 : rvalue->symtree->name, &rvalue->where);
5030 : 1 : return false;
5031 : : }
5032 : 57 : if (attr.dummy)
5033 : : {
5034 : 1 : gfc_error ("Dummy procedure %qs is invalid in "
5035 : : "procedure pointer initialization at %L",
5036 : 1 : rvalue->symtree->name, &rvalue->where);
5037 : 1 : return false;
5038 : : }
5039 : : }
5040 : :
5041 : : return true;
5042 : : }
5043 : :
5044 : : /* Build an initializer for a local integer, real, complex, logical, or
5045 : : character variable, based on the command line flags finit-local-zero,
5046 : : finit-integer=, finit-real=, finit-logical=, and finit-character=.
5047 : : With force, an initializer is ALWAYS generated. */
5048 : :
5049 : : static gfc_expr *
5050 : 100377 : gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force)
5051 : : {
5052 : 100377 : gfc_expr *init_expr;
5053 : :
5054 : : /* Try to build an initializer expression. */
5055 : 100377 : init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
5056 : :
5057 : : /* If we want to force generation, make sure we default to zero. */
5058 : 100377 : gfc_init_local_real init_real = flag_init_real;
5059 : 100377 : int init_logical = gfc_option.flag_init_logical;
5060 : 100377 : if (force)
5061 : : {
5062 : 210 : if (init_real == GFC_INIT_REAL_OFF)
5063 : : init_real = GFC_INIT_REAL_ZERO;
5064 : 210 : if (init_logical == GFC_INIT_LOGICAL_OFF)
5065 : 40 : init_logical = GFC_INIT_LOGICAL_FALSE;
5066 : : }
5067 : :
5068 : : /* We will only initialize integers, reals, complex, logicals, and
5069 : : characters, and only if the corresponding command-line flags
5070 : : were set. Otherwise, we free init_expr and return null. */
5071 : 100377 : switch (ts->type)
5072 : : {
5073 : 52875 : case BT_INTEGER:
5074 : 52875 : if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
5075 : 285 : mpz_set_si (init_expr->value.integer,
5076 : : gfc_option.flag_init_integer_value);
5077 : : else
5078 : : {
5079 : 52590 : gfc_free_expr (init_expr);
5080 : 52590 : init_expr = NULL;
5081 : : }
5082 : : break;
5083 : :
5084 : 15783 : case BT_REAL:
5085 : 15783 : switch (init_real)
5086 : : {
5087 : 0 : case GFC_INIT_REAL_SNAN:
5088 : 0 : init_expr->is_snan = 1;
5089 : : /* Fall through. */
5090 : 48 : case GFC_INIT_REAL_NAN:
5091 : 48 : mpfr_set_nan (init_expr->value.real);
5092 : 48 : break;
5093 : :
5094 : 26 : case GFC_INIT_REAL_INF:
5095 : 26 : mpfr_set_inf (init_expr->value.real, 1);
5096 : 26 : break;
5097 : :
5098 : 24 : case GFC_INIT_REAL_NEG_INF:
5099 : 24 : mpfr_set_inf (init_expr->value.real, -1);
5100 : 24 : break;
5101 : :
5102 : 63 : case GFC_INIT_REAL_ZERO:
5103 : 63 : mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
5104 : 63 : break;
5105 : :
5106 : 15622 : default:
5107 : 15622 : gfc_free_expr (init_expr);
5108 : 15622 : init_expr = NULL;
5109 : 15622 : break;
5110 : : }
5111 : : break;
5112 : :
5113 : 1675 : case BT_COMPLEX:
5114 : 1675 : switch (init_real)
5115 : : {
5116 : 0 : case GFC_INIT_REAL_SNAN:
5117 : 0 : init_expr->is_snan = 1;
5118 : : /* Fall through. */
5119 : 12 : case GFC_INIT_REAL_NAN:
5120 : 12 : mpfr_set_nan (mpc_realref (init_expr->value.complex));
5121 : 12 : mpfr_set_nan (mpc_imagref (init_expr->value.complex));
5122 : 12 : break;
5123 : :
5124 : 0 : case GFC_INIT_REAL_INF:
5125 : 0 : mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
5126 : 0 : mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
5127 : 0 : break;
5128 : :
5129 : 0 : case GFC_INIT_REAL_NEG_INF:
5130 : 0 : mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
5131 : 0 : mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
5132 : 0 : break;
5133 : :
5134 : 24 : case GFC_INIT_REAL_ZERO:
5135 : 24 : mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
5136 : 24 : break;
5137 : :
5138 : 1639 : default:
5139 : 1639 : gfc_free_expr (init_expr);
5140 : 1639 : init_expr = NULL;
5141 : 1639 : break;
5142 : : }
5143 : : break;
5144 : :
5145 : 4925 : case BT_LOGICAL:
5146 : 4925 : if (init_logical == GFC_INIT_LOGICAL_FALSE)
5147 : 39 : init_expr->value.logical = 0;
5148 : 4886 : else if (init_logical == GFC_INIT_LOGICAL_TRUE)
5149 : 26 : init_expr->value.logical = 1;
5150 : : else
5151 : : {
5152 : 4860 : gfc_free_expr (init_expr);
5153 : 4860 : init_expr = NULL;
5154 : : }
5155 : : break;
5156 : :
5157 : 9594 : case BT_CHARACTER:
5158 : : /* For characters, the length must be constant in order to
5159 : : create a default initializer. */
5160 : 9594 : if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
5161 : 83 : && ts->u.cl->length
5162 : 83 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
5163 : : {
5164 : 76 : HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
5165 : 76 : init_expr->value.character.length = char_len;
5166 : 76 : init_expr->value.character.string = gfc_get_wide_string (char_len+1);
5167 : 320 : for (size_t i = 0; i < (size_t) char_len; i++)
5168 : 244 : init_expr->value.character.string[i]
5169 : 244 : = (unsigned char) gfc_option.flag_init_character_value;
5170 : : }
5171 : : else
5172 : : {
5173 : 9518 : gfc_free_expr (init_expr);
5174 : 9518 : init_expr = NULL;
5175 : : }
5176 : 9518 : if (!init_expr
5177 : 9518 : && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
5178 : 7 : && ts->u.cl->length && flag_max_stack_var_size != 0)
5179 : : {
5180 : 6 : gfc_actual_arglist *arg;
5181 : 6 : init_expr = gfc_get_expr ();
5182 : 6 : init_expr->where = *where;
5183 : 6 : init_expr->ts = *ts;
5184 : 6 : init_expr->expr_type = EXPR_FUNCTION;
5185 : 12 : init_expr->value.function.isym =
5186 : 6 : gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
5187 : 6 : init_expr->value.function.name = "repeat";
5188 : 6 : arg = gfc_get_actual_arglist ();
5189 : 6 : arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1);
5190 : 6 : arg->expr->value.character.string[0] =
5191 : 6 : gfc_option.flag_init_character_value;
5192 : 6 : arg->next = gfc_get_actual_arglist ();
5193 : 6 : arg->next->expr = gfc_copy_expr (ts->u.cl->length);
5194 : 6 : init_expr->value.function.actual = arg;
5195 : : }
5196 : : break;
5197 : :
5198 : 15525 : default:
5199 : 15525 : gfc_free_expr (init_expr);
5200 : 15525 : init_expr = NULL;
5201 : : }
5202 : :
5203 : 100377 : return init_expr;
5204 : : }
5205 : :
5206 : : /* Invoke gfc_build_init_expr to create an initializer expression, but do not
5207 : : * require that an expression be built. */
5208 : :
5209 : : gfc_expr *
5210 : 100167 : gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
5211 : : {
5212 : 100167 : return gfc_build_init_expr (ts, where, false);
5213 : : }
5214 : :
5215 : : /* Apply an initialization expression to a typespec. Can be used for symbols or
5216 : : components. Similar to add_init_expr_to_sym in decl.cc; could probably be
5217 : : combined with some effort. */
5218 : :
5219 : : void
5220 : 17352 : gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
5221 : : {
5222 : 17352 : if (ts->type == BT_CHARACTER && !attr->pointer && init
5223 : 355 : && ts->u.cl
5224 : 355 : && ts->u.cl->length
5225 : 355 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
5226 : 353 : && ts->u.cl->length->ts.type == BT_INTEGER)
5227 : : {
5228 : 353 : HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
5229 : :
5230 : 353 : if (init->expr_type == EXPR_CONSTANT)
5231 : 246 : gfc_set_constant_character_len (len, init, -1);
5232 : 107 : else if (init
5233 : 107 : && init->ts.type == BT_CHARACTER
5234 : 102 : && init->ts.u.cl && init->ts.u.cl->length
5235 : 102 : && mpz_cmp (ts->u.cl->length->value.integer,
5236 : 102 : init->ts.u.cl->length->value.integer))
5237 : : {
5238 : 0 : gfc_constructor *ctor;
5239 : 0 : ctor = gfc_constructor_first (init->value.constructor);
5240 : :
5241 : 0 : if (ctor)
5242 : : {
5243 : 0 : bool has_ts = (init->ts.u.cl
5244 : 0 : && init->ts.u.cl->length_from_typespec);
5245 : :
5246 : : /* Remember the length of the first element for checking
5247 : : that all elements *in the constructor* have the same
5248 : : length. This need not be the length of the LHS! */
5249 : 0 : gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
5250 : 0 : gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
5251 : 0 : gfc_charlen_t first_len = ctor->expr->value.character.length;
5252 : :
5253 : 0 : for ( ; ctor; ctor = gfc_constructor_next (ctor))
5254 : 0 : if (ctor->expr->expr_type == EXPR_CONSTANT)
5255 : : {
5256 : 0 : gfc_set_constant_character_len (len, ctor->expr,
5257 : : has_ts ? -1 : first_len);
5258 : 0 : if (!ctor->expr->ts.u.cl)
5259 : 0 : ctor->expr->ts.u.cl
5260 : 0 : = gfc_new_charlen (gfc_current_ns, ts->u.cl);
5261 : : else
5262 : 0 : ctor->expr->ts.u.cl->length
5263 : 0 : = gfc_copy_expr (ts->u.cl->length);
5264 : : }
5265 : : }
5266 : : }
5267 : : }
5268 : 17352 : }
5269 : :
5270 : :
5271 : : /* Check whether an expression is a structure constructor and whether it has
5272 : : other values than NULL. */
5273 : :
5274 : : static bool
5275 : 846 : is_non_empty_structure_constructor (gfc_expr * e)
5276 : : {
5277 : 846 : if (e->expr_type != EXPR_STRUCTURE)
5278 : : return false;
5279 : :
5280 : 846 : gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
5281 : 2238 : while (cons)
5282 : : {
5283 : 961 : if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
5284 : : return true;
5285 : 546 : cons = gfc_constructor_next (cons);
5286 : : }
5287 : : return false;
5288 : : }
5289 : :
5290 : :
5291 : : /* Check for default initializer; sym->value is not enough
5292 : : as it is also set for EXPR_NULL of allocatables. */
5293 : :
5294 : : bool
5295 : 7745 : gfc_has_default_initializer (gfc_symbol *der)
5296 : : {
5297 : 7745 : static hash_set<gfc_symbol *> seen_derived_types;
5298 : 7745 : gfc_component *c;
5299 : : /* The rewrite to a result variable and breaks is only needed, because
5300 : : there is no scope_guard in C++ yet. */
5301 : 7745 : bool result = false;
5302 : :
5303 : 7745 : gcc_assert (gfc_fl_struct (der->attr.flavor));
5304 : 7745 : seen_derived_types.add (der);
5305 : 16224 : for (c = der->components; c; c = c->next)
5306 : 8420 : if (gfc_bt_struct (c->ts.type)
5307 : 10117 : && !seen_derived_types.contains (c->ts.u.derived))
5308 : : {
5309 : 1477 : if (!c->attr.pointer && !c->attr.proc_pointer
5310 : 1477 : && !(c->attr.allocatable && der == c->ts.u.derived)
5311 : 3086 : && ((c->initializer
5312 : 846 : && is_non_empty_structure_constructor (c->initializer))
5313 : 1062 : || gfc_has_default_initializer (c->ts.u.derived)))
5314 : : {
5315 : : result = true;
5316 : : break;
5317 : : }
5318 : 1139 : if (c->attr.pointer && c->initializer)
5319 : : {
5320 : : result = true;
5321 : : break;
5322 : : }
5323 : : }
5324 : : else
5325 : : {
5326 : 8504 : if (c->initializer)
5327 : : {
5328 : : result = true;
5329 : : break;
5330 : : }
5331 : : }
5332 : :
5333 : 7745 : seen_derived_types.remove (der);
5334 : 7745 : return result;
5335 : : }
5336 : :
5337 : :
5338 : : /*
5339 : : Generate an initializer expression which initializes the entirety of a union.
5340 : : A normal structure constructor is insufficient without undue effort, because
5341 : : components of maps may be oddly aligned/overlapped. (For example if a
5342 : : character is initialized from one map overtop a real from the other, only one
5343 : : byte of the real is actually initialized.) Unfortunately we don't know the
5344 : : size of the union right now, so we can't generate a proper initializer, but
5345 : : we use a NULL expr as a placeholder and do the right thing later in
5346 : : gfc_trans_subcomponent_assign.
5347 : : */
5348 : : static gfc_expr *
5349 : 15 : generate_union_initializer (gfc_component *un)
5350 : : {
5351 : 15 : if (un == NULL || un->ts.type != BT_UNION)
5352 : : return NULL;
5353 : :
5354 : 15 : gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
5355 : 15 : placeholder->ts = un->ts;
5356 : 15 : return placeholder;
5357 : : }
5358 : :
5359 : :
5360 : : /* Get the user-specified initializer for a union, if any. This means the user
5361 : : has said to initialize component(s) of a map. For simplicity's sake we
5362 : : only allow the user to initialize the first map. We don't have to worry
5363 : : about overlapping initializers as they are released early in resolution (see
5364 : : resolve_fl_struct). */
5365 : :
5366 : : static gfc_expr *
5367 : 15 : get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
5368 : : {
5369 : 15 : gfc_component *map;
5370 : 15 : gfc_expr *init=NULL;
5371 : :
5372 : 15 : if (!union_type || union_type->attr.flavor != FL_UNION)
5373 : : return NULL;
5374 : :
5375 : 48 : for (map = union_type->components; map; map = map->next)
5376 : : {
5377 : 33 : if (gfc_has_default_initializer (map->ts.u.derived))
5378 : : {
5379 : 0 : init = gfc_default_initializer (&map->ts);
5380 : 0 : if (map_p)
5381 : 0 : *map_p = map;
5382 : : break;
5383 : : }
5384 : : }
5385 : :
5386 : 15 : if (map_p && !init)
5387 : 15 : *map_p = NULL;
5388 : :
5389 : : return init;
5390 : : }
5391 : :
5392 : : static bool
5393 : 147196 : class_allocatable (gfc_component *comp)
5394 : : {
5395 : 2907 : return comp->ts.type == BT_CLASS && comp->attr.class_ok && CLASS_DATA (comp)
5396 : 150102 : && CLASS_DATA (comp)->attr.allocatable;
5397 : : }
5398 : :
5399 : : static bool
5400 : 268 : class_pointer (gfc_component *comp)
5401 : : {
5402 : 1 : return comp->ts.type == BT_CLASS && comp->attr.class_ok && CLASS_DATA (comp)
5403 : 269 : && CLASS_DATA (comp)->attr.pointer;
5404 : : }
5405 : :
5406 : : static bool
5407 : 164080 : comp_allocatable (gfc_component *comp)
5408 : : {
5409 : 164080 : return comp->attr.allocatable || class_allocatable (comp);
5410 : : }
5411 : :
5412 : : static bool
5413 : 271 : comp_pointer (gfc_component *comp)
5414 : : {
5415 : 271 : return comp->attr.pointer
5416 : 268 : || comp->attr.proc_pointer
5417 : 268 : || comp->attr.class_pointer
5418 : 539 : || class_pointer (comp);
5419 : : }
5420 : :
5421 : : /* Fetch or generate an initializer for the given component.
5422 : : Only generate an initializer if generate is true. */
5423 : :
5424 : : static gfc_expr *
5425 : 111933 : component_initializer (gfc_component *c, bool generate)
5426 : : {
5427 : 111933 : gfc_expr *init = NULL;
5428 : :
5429 : : /* Allocatable components always get EXPR_NULL.
5430 : : Pointer components are only initialized when generating, and only if they
5431 : : do not already have an initializer. */
5432 : 111933 : if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer))
5433 : : {
5434 : 11209 : init = gfc_get_null_expr (&c->loc);
5435 : 11209 : init->ts = c->ts;
5436 : 11209 : return init;
5437 : : }
5438 : :
5439 : : /* See if we can find the initializer immediately. */
5440 : 100724 : if (c->initializer || !generate)
5441 : : return c->initializer;
5442 : :
5443 : : /* Recursively handle derived type components. */
5444 : 243 : else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
5445 : 18 : init = gfc_generate_initializer (&c->ts, true);
5446 : :
5447 : 225 : else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
5448 : : {
5449 : 15 : gfc_component *map = NULL;
5450 : 15 : gfc_constructor *ctor;
5451 : 15 : gfc_expr *user_init;
5452 : :
5453 : : /* If we don't have a user initializer and we aren't generating one, this
5454 : : union has no initializer. */
5455 : 15 : user_init = get_union_initializer (c->ts.u.derived, &map);
5456 : 15 : if (!user_init && !generate)
5457 : : return NULL;
5458 : :
5459 : : /* Otherwise use a structure constructor. */
5460 : 15 : init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
5461 : : &c->loc);
5462 : 15 : init->ts = c->ts;
5463 : :
5464 : : /* If we are to generate an initializer for the union, add a constructor
5465 : : which initializes the whole union first. */
5466 : 15 : if (generate)
5467 : : {
5468 : 15 : ctor = gfc_constructor_get ();
5469 : 15 : ctor->expr = generate_union_initializer (c);
5470 : 15 : gfc_constructor_append (&init->value.constructor, ctor);
5471 : : }
5472 : :
5473 : : /* If we found an initializer in one of our maps, apply it. Note this
5474 : : is applied _after_ the entire-union initializer above if any. */
5475 : 15 : if (user_init)
5476 : : {
5477 : 0 : ctor = gfc_constructor_get ();
5478 : 0 : ctor->expr = user_init;
5479 : 0 : ctor->n.component = map;
5480 : 0 : gfc_constructor_append (&init->value.constructor, ctor);
5481 : : }
5482 : 15 : }
5483 : :
5484 : : /* Treat simple components like locals. */
5485 : : else
5486 : : {
5487 : : /* We MUST give an initializer, so force generation. */
5488 : 210 : init = gfc_build_init_expr (&c->ts, &c->loc, true);
5489 : 210 : gfc_apply_init (&c->ts, &c->attr, init);
5490 : : }
5491 : :
5492 : : return init;
5493 : : }
5494 : :
5495 : :
5496 : : /* Get an expression for a default initializer of a derived type. */
5497 : :
5498 : : gfc_expr *
5499 : 26065 : gfc_default_initializer (gfc_typespec *ts)
5500 : : {
5501 : 26065 : return gfc_generate_initializer (ts, false);
5502 : : }
5503 : :
5504 : : /* Generate an initializer expression for an iso_c_binding type
5505 : : such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
5506 : :
5507 : : static gfc_expr *
5508 : 3 : generate_isocbinding_initializer (gfc_symbol *derived)
5509 : : {
5510 : : /* The initializers have already been built into the c_null_[fun]ptr symbols
5511 : : from gen_special_c_interop_ptr. */
5512 : 3 : gfc_symtree *npsym = NULL;
5513 : 3 : if (0 == strcmp (derived->name, "c_ptr"))
5514 : 2 : gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym);
5515 : 1 : else if (0 == strcmp (derived->name, "c_funptr"))
5516 : 1 : gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym);
5517 : : else
5518 : 0 : gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
5519 : : " type, expected %<c_ptr%> or %<c_funptr%>");
5520 : 3 : if (npsym)
5521 : : {
5522 : 3 : gfc_expr *init = gfc_copy_expr (npsym->n.sym->value);
5523 : 3 : init->symtree = npsym;
5524 : 3 : init->ts.is_iso_c = true;
5525 : 3 : return init;
5526 : : }
5527 : :
5528 : : return NULL;
5529 : : }
5530 : :
5531 : : /* Get or generate an expression for a default initializer of a derived type.
5532 : : If -finit-derived is specified, generate default initialization expressions
5533 : : for components that lack them when generate is set. */
5534 : :
5535 : : gfc_expr *
5536 : 56463 : gfc_generate_initializer (gfc_typespec *ts, bool generate)
5537 : : {
5538 : 56463 : gfc_expr *init, *tmp;
5539 : 56463 : gfc_component *comp;
5540 : :
5541 : 56463 : generate = flag_init_derived && generate;
5542 : :
5543 : 56463 : if (ts->u.derived->ts.is_iso_c && generate)
5544 : 3 : return generate_isocbinding_initializer (ts->u.derived);
5545 : :
5546 : : /* See if we have a default initializer in this, but not in nested
5547 : : types (otherwise we could use gfc_has_default_initializer()).
5548 : : We don't need to check if we are going to generate them. */
5549 : 56460 : comp = ts->u.derived->components;
5550 : 56460 : if (!generate)
5551 : : {
5552 : 100490 : for (; comp; comp = comp->next)
5553 : 71723 : if (comp->initializer || comp_allocatable (comp))
5554 : : break;
5555 : : }
5556 : :
5557 : 56460 : if (!comp)
5558 : : return NULL;
5559 : :
5560 : 27693 : init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
5561 : : &ts->u.derived->declared_at);
5562 : 27693 : init->ts = *ts;
5563 : :
5564 : 139625 : for (comp = ts->u.derived->components; comp; comp = comp->next)
5565 : : {
5566 : 111933 : gfc_constructor *ctor = gfc_constructor_get();
5567 : :
5568 : : /* Fetch or generate an initializer for the component. */
5569 : 111933 : tmp = component_initializer (comp, generate);
5570 : 111933 : if (tmp)
5571 : : {
5572 : : /* Save the component ref for STRUCTUREs and UNIONs. */
5573 : 101629 : if (ts->u.derived->attr.flavor == FL_STRUCT
5574 : 101309 : || ts->u.derived->attr.flavor == FL_UNION)
5575 : 343 : ctor->n.component = comp;
5576 : :
5577 : : /* If the initializer was not generated, we need a copy. */
5578 : 101629 : ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
5579 : 101629 : if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind)
5580 : 17431 : && !comp->attr.pointer && !comp->attr.proc_pointer)
5581 : : {
5582 : 264 : bool val;
5583 : 264 : val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false);
5584 : 264 : if (val == false)
5585 : : return NULL;
5586 : : }
5587 : : }
5588 : :
5589 : 111932 : gfc_constructor_append (&init->value.constructor, ctor);
5590 : : }
5591 : :
5592 : : return init;
5593 : : }
5594 : :
5595 : :
5596 : : /* Given a symbol, create an expression node with that symbol as a
5597 : : variable. If the symbol is array valued, setup a reference of the
5598 : : whole array. */
5599 : :
5600 : : gfc_expr *
5601 : 12869 : gfc_get_variable_expr (gfc_symtree *var)
5602 : : {
5603 : 12869 : gfc_expr *e;
5604 : :
5605 : 12869 : e = gfc_get_expr ();
5606 : 12869 : e->expr_type = EXPR_VARIABLE;
5607 : 12869 : e->symtree = var;
5608 : 12869 : e->ts = var->n.sym->ts;
5609 : :
5610 : 12869 : if (var->n.sym->attr.flavor != FL_PROCEDURE
5611 : 8899 : && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
5612 : 6845 : || (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived
5613 : 4156 : && CLASS_DATA (var->n.sym)
5614 : 4156 : && CLASS_DATA (var->n.sym)->as)))
5615 : : {
5616 : 5494 : gfc_array_spec *as = var->n.sym->ts.type == BT_CLASS
5617 : 3774 : ? CLASS_DATA (var->n.sym)->as
5618 : : : var->n.sym->as;
5619 : 3774 : e->rank = as->rank;
5620 : 3774 : e->corank = as->corank;
5621 : 3774 : e->ref = gfc_get_ref ();
5622 : 3774 : e->ref->type = REF_ARRAY;
5623 : 3774 : e->ref->u.ar.type = AR_FULL;
5624 : 3774 : e->ref->u.ar.as = gfc_copy_array_spec (as);
5625 : : }
5626 : :
5627 : 12869 : return e;
5628 : : }
5629 : :
5630 : :
5631 : : /* Adds a full array reference to an expression, as needed. */
5632 : :
5633 : : void
5634 : 37190 : gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
5635 : : {
5636 : 37190 : gfc_ref *ref;
5637 : 37203 : for (ref = e->ref; ref; ref = ref->next)
5638 : 191 : if (!ref->next)
5639 : : break;
5640 : 37190 : if (ref)
5641 : : {
5642 : 178 : ref->next = gfc_get_ref ();
5643 : 178 : ref = ref->next;
5644 : : }
5645 : : else
5646 : : {
5647 : 37012 : e->ref = gfc_get_ref ();
5648 : 37012 : ref = e->ref;
5649 : : }
5650 : 37190 : ref->type = REF_ARRAY;
5651 : 37190 : ref->u.ar.type = AR_FULL;
5652 : 37190 : ref->u.ar.dimen = e->rank;
5653 : : /* Do not set the corank here, or resolve will not be able to set correct
5654 : : dimen-types for the coarray. */
5655 : 37190 : ref->u.ar.where = e->where;
5656 : 37190 : ref->u.ar.as = as;
5657 : 37190 : }
5658 : :
5659 : :
5660 : : gfc_expr *
5661 : 161788 : gfc_lval_expr_from_sym (gfc_symbol *sym)
5662 : : {
5663 : 161788 : gfc_expr *lval;
5664 : 161788 : gfc_array_spec *as;
5665 : 161788 : lval = gfc_get_expr ();
5666 : 161788 : lval->expr_type = EXPR_VARIABLE;
5667 : 161788 : lval->where = sym->declared_at;
5668 : 161788 : lval->ts = sym->ts;
5669 : 161788 : lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
5670 : :
5671 : : /* It will always be a full array. */
5672 : 161788 : as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
5673 : 161788 : lval->rank = as ? as->rank : 0;
5674 : 161788 : lval->corank = as ? as->corank : 0;
5675 : 161788 : if (lval->rank || lval->corank)
5676 : 35696 : gfc_add_full_array_ref (lval, as);
5677 : 161788 : return lval;
5678 : : }
5679 : :
5680 : :
5681 : : /* Returns the array_spec of a full array expression. A NULL is
5682 : : returned otherwise. */
5683 : : gfc_array_spec *
5684 : 25123 : gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
5685 : : {
5686 : 25123 : gfc_array_spec *as;
5687 : 25123 : gfc_ref *ref;
5688 : :
5689 : 25123 : if (expr->rank == 0)
5690 : : return NULL;
5691 : :
5692 : : /* Follow any component references. */
5693 : 25123 : if (expr->expr_type == EXPR_VARIABLE
5694 : 25123 : || expr->expr_type == EXPR_CONSTANT)
5695 : : {
5696 : 19237 : if (expr->symtree)
5697 : 19237 : as = expr->symtree->n.sym->as;
5698 : : else
5699 : : as = NULL;
5700 : :
5701 : 40350 : for (ref = expr->ref; ref; ref = ref->next)
5702 : : {
5703 : 21113 : switch (ref->type)
5704 : : {
5705 : 1707 : case REF_COMPONENT:
5706 : 1707 : as = ref->u.c.component->as;
5707 : 1707 : continue;
5708 : :
5709 : 24 : case REF_SUBSTRING:
5710 : 24 : case REF_INQUIRY:
5711 : 24 : continue;
5712 : :
5713 : 19382 : case REF_ARRAY:
5714 : 19382 : {
5715 : 19382 : switch (ref->u.ar.type)
5716 : : {
5717 : 2126 : case AR_ELEMENT:
5718 : 2126 : case AR_SECTION:
5719 : 2126 : case AR_UNKNOWN:
5720 : 2126 : as = NULL;
5721 : 2126 : continue;
5722 : :
5723 : : case AR_FULL:
5724 : : break;
5725 : : }
5726 : : break;
5727 : : }
5728 : : }
5729 : : }
5730 : : }
5731 : : else
5732 : : as = NULL;
5733 : :
5734 : : return as;
5735 : : }
5736 : :
5737 : :
5738 : : /* General expression traversal function. */
5739 : :
5740 : : bool
5741 : 944470 : gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
5742 : : bool (*func)(gfc_expr *, gfc_symbol *, int*),
5743 : : int f)
5744 : : {
5745 : 944470 : gfc_array_ref ar;
5746 : 944470 : gfc_ref *ref;
5747 : 944470 : gfc_actual_arglist *args;
5748 : 944470 : gfc_constructor *c;
5749 : 944470 : int i;
5750 : :
5751 : 944470 : if (!expr)
5752 : : return false;
5753 : :
5754 : 466502 : if ((*func) (expr, sym, &f))
5755 : : return true;
5756 : :
5757 : : /* Descend into length type parameter of character expressions only for
5758 : : non-negative f. */
5759 : 459653 : if (f >= 0
5760 : 437820 : && expr->ts.type == BT_CHARACTER
5761 : 11749 : && expr->ts.u.cl
5762 : 4262 : && expr->ts.u.cl->length
5763 : 2250 : && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
5764 : 460582 : && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
5765 : : return true;
5766 : :
5767 : 459652 : switch (expr->expr_type)
5768 : : {
5769 : 17385 : case EXPR_PPC:
5770 : 17385 : case EXPR_COMPCALL:
5771 : 17385 : case EXPR_FUNCTION:
5772 : 40889 : for (args = expr->value.function.actual; args; args = args->next)
5773 : : {
5774 : 23609 : if (gfc_traverse_expr (args->expr, sym, func, f))
5775 : : return true;
5776 : : }
5777 : : break;
5778 : :
5779 : : case EXPR_VARIABLE:
5780 : : case EXPR_CONSTANT:
5781 : : case EXPR_NULL:
5782 : : case EXPR_SUBSTRING:
5783 : : break;
5784 : :
5785 : 4643 : case EXPR_STRUCTURE:
5786 : 4643 : case EXPR_ARRAY:
5787 : 4643 : for (c = gfc_constructor_first (expr->value.constructor);
5788 : 28583 : c; c = gfc_constructor_next (c))
5789 : : {
5790 : 23940 : if (gfc_traverse_expr (c->expr, sym, func, f))
5791 : : return true;
5792 : 23940 : if (c->iterator)
5793 : : {
5794 : 489 : if (gfc_traverse_expr (c->iterator->var, sym, func, f))
5795 : : return true;
5796 : 489 : if (gfc_traverse_expr (c->iterator->start, sym, func, f))
5797 : : return true;
5798 : 489 : if (gfc_traverse_expr (c->iterator->end, sym, func, f))
5799 : : return true;
5800 : 489 : if (gfc_traverse_expr (c->iterator->step, sym, func, f))
5801 : : return true;
5802 : : }
5803 : : }
5804 : : break;
5805 : :
5806 : 9557 : case EXPR_OP:
5807 : 9557 : if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
5808 : : return true;
5809 : 7851 : if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
5810 : : return true;
5811 : : break;
5812 : :
5813 : 6 : case EXPR_CONDITIONAL:
5814 : 6 : if (gfc_traverse_expr (expr->value.conditional.condition, sym, func, f))
5815 : : return true;
5816 : 6 : if (gfc_traverse_expr (expr->value.conditional.true_expr, sym, func, f))
5817 : : return true;
5818 : 6 : if (gfc_traverse_expr (expr->value.conditional.false_expr, sym, func, f))
5819 : : return true;
5820 : : break;
5821 : :
5822 : 0 : default:
5823 : 0 : gcc_unreachable ();
5824 : 457462 : break;
5825 : : }
5826 : :
5827 : 457462 : ref = expr->ref;
5828 : 468499 : while (ref != NULL)
5829 : : {
5830 : 15060 : switch (ref->type)
5831 : : {
5832 : 13265 : case REF_ARRAY:
5833 : 13265 : ar = ref->u.ar;
5834 : 157225 : for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
5835 : : {
5836 : 147806 : if (gfc_traverse_expr (ar.start[i], sym, func, f))
5837 : : return true;
5838 : 143961 : if (gfc_traverse_expr (ar.end[i], sym, func, f))
5839 : : return true;
5840 : 143960 : if (gfc_traverse_expr (ar.stride[i], sym, func, f))
5841 : : return true;
5842 : : }
5843 : : break;
5844 : :
5845 : 801 : case REF_SUBSTRING:
5846 : 801 : if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
5847 : : return true;
5848 : 629 : if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
5849 : : return true;
5850 : : break;
5851 : :
5852 : 990 : case REF_COMPONENT:
5853 : 990 : if (f >= 0
5854 : 975 : && ref->u.c.component->ts.type == BT_CHARACTER
5855 : 91 : && ref->u.c.component->ts.u.cl
5856 : 91 : && ref->u.c.component->ts.u.cl->length
5857 : 91 : && ref->u.c.component->ts.u.cl->length->expr_type
5858 : : != EXPR_CONSTANT
5859 : 990 : && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
5860 : : sym, func, f))
5861 : : return true;
5862 : :
5863 : 990 : if (ref->u.c.component->as)
5864 : 432 : for (i = 0; i < ref->u.c.component->as->rank
5865 : 824 : + ref->u.c.component->as->corank; i++)
5866 : : {
5867 : 432 : if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
5868 : : sym, func, f))
5869 : : return true;
5870 : 432 : if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
5871 : : sym, func, f))
5872 : : return true;
5873 : : }
5874 : : break;
5875 : :
5876 : : case REF_INQUIRY:
5877 : : return false;
5878 : :
5879 : 0 : default:
5880 : 0 : gcc_unreachable ();
5881 : : }
5882 : 11037 : ref = ref->next;
5883 : : }
5884 : : return false;
5885 : : }
5886 : :
5887 : : /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5888 : :
5889 : : static bool
5890 : 3927 : expr_set_symbols_referenced (gfc_expr *expr,
5891 : : gfc_symbol *sym ATTRIBUTE_UNUSED,
5892 : : int *f ATTRIBUTE_UNUSED)
5893 : : {
5894 : 3927 : if (expr->expr_type != EXPR_VARIABLE)
5895 : : return false;
5896 : 933 : gfc_set_sym_referenced (expr->symtree->n.sym);
5897 : 933 : return false;
5898 : : }
5899 : :
5900 : : void
5901 : 1238 : gfc_expr_set_symbols_referenced (gfc_expr *expr)
5902 : : {
5903 : 1238 : gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
5904 : 1238 : }
5905 : :
5906 : :
5907 : : /* Determine if an expression is a procedure pointer component and return
5908 : : the component in that case. Otherwise return NULL. */
5909 : :
5910 : : gfc_component *
5911 : 3235308 : gfc_get_proc_ptr_comp (gfc_expr *expr)
5912 : : {
5913 : 3235308 : gfc_ref *ref;
5914 : :
5915 : 3235308 : if (!expr || !expr->ref)
5916 : : return NULL;
5917 : :
5918 : : ref = expr->ref;
5919 : 248928 : while (ref->next)
5920 : : ref = ref->next;
5921 : :
5922 : 224568 : if (ref->type == REF_COMPONENT
5923 : 19921 : && ref->u.c.component->attr.proc_pointer)
5924 : 8992 : return ref->u.c.component;
5925 : :
5926 : : return NULL;
5927 : : }
5928 : :
5929 : :
5930 : : /* Determine if an expression is a procedure pointer component. */
5931 : :
5932 : : bool
5933 : 1112715 : gfc_is_proc_ptr_comp (gfc_expr *expr)
5934 : : {
5935 : 1112715 : return (gfc_get_proc_ptr_comp (expr) != NULL);
5936 : : }
5937 : :
5938 : :
5939 : : /* Determine if an expression is a function with an allocatable class scalar
5940 : : result. */
5941 : : bool
5942 : 391136 : gfc_is_alloc_class_scalar_function (gfc_expr *expr)
5943 : : {
5944 : 391136 : if (expr->expr_type == EXPR_FUNCTION
5945 : 72420 : && ((expr->value.function.esym
5946 : 40499 : && expr->value.function.esym->result
5947 : 40498 : && expr->value.function.esym->result->ts.type == BT_CLASS
5948 : 1026 : && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
5949 : 893 : && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
5950 : 71799 : || (expr->ts.type == BT_CLASS
5951 : 760 : && CLASS_DATA (expr)->attr.allocatable
5952 : 397 : && !CLASS_DATA (expr)->attr.dimension)))
5953 : 861 : return true;
5954 : :
5955 : : return false;
5956 : : }
5957 : :
5958 : :
5959 : : /* Determine if an expression is a function with an allocatable class array
5960 : : result. */
5961 : : bool
5962 : 167353 : gfc_is_class_array_function (gfc_expr *expr)
5963 : : {
5964 : 167353 : if (expr->expr_type == EXPR_FUNCTION
5965 : 80826 : && expr->value.function.esym
5966 : 44120 : && expr->value.function.esym->result
5967 : 44119 : && expr->value.function.esym->result->ts.type == BT_CLASS
5968 : 2427 : && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
5969 : 1557 : && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable
5970 : 312 : || CLASS_DATA (expr->value.function.esym->result)->attr.pointer))
5971 : 1557 : return true;
5972 : :
5973 : : return false;
5974 : : }
5975 : :
5976 : :
5977 : : /* Walk an expression tree and check each variable encountered for being typed.
5978 : : If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5979 : : mode as is a basic arithmetic expression using those; this is for things in
5980 : : legacy-code like:
5981 : :
5982 : : INTEGER :: arr(n), n
5983 : : INTEGER :: arr(n + 1), n
5984 : :
5985 : : The namespace is needed for IMPLICIT typing. */
5986 : :
5987 : : static gfc_namespace* check_typed_ns;
5988 : :
5989 : : static bool
5990 : 81108 : expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
5991 : : int* f ATTRIBUTE_UNUSED)
5992 : : {
5993 : 81108 : bool t;
5994 : :
5995 : 81108 : if (e->expr_type != EXPR_VARIABLE)
5996 : : return false;
5997 : :
5998 : 2432 : gcc_assert (e->symtree);
5999 : 2432 : t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
6000 : : true, e->where);
6001 : :
6002 : 2432 : return (!t);
6003 : : }
6004 : :
6005 : : bool
6006 : 87137 : gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
6007 : : {
6008 : 87137 : bool error_found;
6009 : :
6010 : : /* If this is a top-level variable or EXPR_OP, do the check with strict given
6011 : : to us. */
6012 : 87137 : if (!strict)
6013 : : {
6014 : 86812 : if (e->expr_type == EXPR_VARIABLE && !e->ref)
6015 : 8462 : return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
6016 : :
6017 : 78350 : if (e->expr_type == EXPR_OP)
6018 : : {
6019 : 1771 : bool t = true;
6020 : :
6021 : 1771 : gcc_assert (e->value.op.op1);
6022 : 1771 : t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
6023 : :
6024 : 1771 : if (t && e->value.op.op2)
6025 : 1396 : t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
6026 : :
6027 : 1771 : return t;
6028 : : }
6029 : : }
6030 : :
6031 : : /* Otherwise, walk the expression and do it strictly. */
6032 : 76904 : check_typed_ns = ns;
6033 : 76904 : error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
6034 : :
6035 : 76904 : return error_found ? false : true;
6036 : : }
6037 : :
6038 : :
6039 : : /* This function returns true if it contains any references to PDT KIND
6040 : : or LEN parameters. */
6041 : :
6042 : : static bool
6043 : 168619 : derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
6044 : : int* f ATTRIBUTE_UNUSED)
6045 : : {
6046 : 168619 : if (e->expr_type != EXPR_VARIABLE)
6047 : : return false;
6048 : :
6049 : 2867 : gcc_assert (e->symtree);
6050 : 2867 : if (e->symtree->n.sym->attr.pdt_kind
6051 : 2555 : || e->symtree->n.sym->attr.pdt_len)
6052 : 652 : return true;
6053 : :
6054 : : return false;
6055 : : }
6056 : :
6057 : :
6058 : : bool
6059 : 138072 : gfc_derived_parameter_expr (gfc_expr *e)
6060 : : {
6061 : 138072 : return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0);
6062 : : }
6063 : :
6064 : :
6065 : : /* This function returns the overall type of a type parameter spec list.
6066 : : If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
6067 : : parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
6068 : : unless derived is not NULL. In this latter case, all the LEN parameters
6069 : : must be either assumed or deferred for the return argument to be set to
6070 : : anything other than SPEC_EXPLICIT. */
6071 : :
6072 : : gfc_param_spec_type
6073 : 117 : gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
6074 : : {
6075 : 117 : gfc_param_spec_type res = SPEC_EXPLICIT;
6076 : 117 : gfc_component *c;
6077 : 117 : bool seen_assumed = false;
6078 : 117 : bool seen_deferred = false;
6079 : 117 : bool seen_len = false;
6080 : :
6081 : 117 : if (derived == NULL)
6082 : : {
6083 : 189 : for (; param_list; param_list = param_list->next)
6084 : 130 : if (param_list->spec_type == SPEC_ASSUMED
6085 : 130 : || param_list->spec_type == SPEC_DEFERRED)
6086 : : return param_list->spec_type;
6087 : : }
6088 : : else
6089 : : {
6090 : 161 : for (; param_list; param_list = param_list->next)
6091 : : {
6092 : 107 : c = gfc_find_component (derived, param_list->name,
6093 : : true, true, NULL);
6094 : 107 : gcc_assert (c != NULL);
6095 : 107 : if (c->attr.pdt_kind)
6096 : 62 : continue;
6097 : 45 : else if (param_list->spec_type == SPEC_EXPLICIT)
6098 : : return SPEC_EXPLICIT;
6099 : 41 : seen_assumed = param_list->spec_type == SPEC_ASSUMED;
6100 : 41 : seen_deferred = param_list->spec_type == SPEC_DEFERRED;
6101 : 41 : if (c->attr.pdt_len)
6102 : 41 : seen_len = true;
6103 : : if (seen_assumed && seen_deferred)
6104 : : return SPEC_EXPLICIT;
6105 : : }
6106 : 54 : res = (seen_assumed || !seen_len) ? SPEC_ASSUMED : SPEC_DEFERRED;
6107 : : }
6108 : : return res;
6109 : : }
6110 : :
6111 : :
6112 : : bool
6113 : 20591 : gfc_ref_this_image (gfc_ref *ref)
6114 : : {
6115 : 20591 : int n;
6116 : :
6117 : 20591 : gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
6118 : :
6119 : 44916 : for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
6120 : 27196 : if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
6121 : : return false;
6122 : :
6123 : : return true;
6124 : : }
6125 : :
6126 : : gfc_expr *
6127 : 2060 : gfc_find_team_co (gfc_expr *e, enum gfc_array_ref_team_type req_team_type)
6128 : : {
6129 : 2060 : gfc_ref *ref;
6130 : :
6131 : 3017 : for (ref = e->ref; ref; ref = ref->next)
6132 : 974 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
6133 : 974 : && ref->u.ar.team_type == req_team_type)
6134 : 17 : return ref->u.ar.team;
6135 : :
6136 : 2043 : if (e->expr_type == EXPR_FUNCTION && e->value.function.actual->expr)
6137 : 2191 : for (ref = e->value.function.actual->expr->ref; ref;
6138 : 1105 : ref = ref->next)
6139 : 1112 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
6140 : 1086 : && ref->u.ar.team_type == req_team_type)
6141 : 7 : return ref->u.ar.team;
6142 : :
6143 : : return NULL;
6144 : : }
6145 : :
6146 : : gfc_expr *
6147 : 1030 : gfc_find_stat_co (gfc_expr *e)
6148 : : {
6149 : 1030 : gfc_ref *ref;
6150 : :
6151 : 1030 : for (ref = e->ref; ref; ref = ref->next)
6152 : 487 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6153 : 487 : return ref->u.ar.stat;
6154 : :
6155 : 543 : if (e->value.function.actual->expr)
6156 : 556 : for (ref = e->value.function.actual->expr->ref; ref;
6157 : 13 : ref = ref->next)
6158 : 556 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6159 : 543 : return ref->u.ar.stat;
6160 : :
6161 : : return NULL;
6162 : : }
6163 : :
6164 : : bool
6165 : 838030 : gfc_is_coindexed (gfc_expr *e)
6166 : : {
6167 : 838030 : gfc_ref *ref;
6168 : :
6169 : 838030 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
6170 : 532 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
6171 : 0 : e = e->value.function.actual->expr;
6172 : :
6173 : 1246859 : for (ref = e->ref; ref; ref = ref->next)
6174 : 424612 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
6175 : 15783 : return !gfc_ref_this_image (ref);
6176 : :
6177 : : return false;
6178 : : }
6179 : :
6180 : :
6181 : : /* Coarrays are variables with a corank but not being coindexed. However, also
6182 : : the following is a coarray: A subobject of a coarray is a coarray if it does
6183 : : not have any cosubscripts, vector subscripts, allocatable component
6184 : : selection, or pointer component selection. (F2008, 2.4.7) */
6185 : :
6186 : : bool
6187 : 167815 : gfc_is_coarray (gfc_expr *e)
6188 : : {
6189 : 167815 : gfc_ref *ref;
6190 : 167815 : gfc_symbol *sym;
6191 : 167815 : gfc_component *comp;
6192 : 167815 : bool coindexed;
6193 : 167815 : bool coarray;
6194 : 167815 : int i;
6195 : :
6196 : 167815 : if (e->expr_type != EXPR_VARIABLE)
6197 : : return false;
6198 : :
6199 : 165245 : coindexed = false;
6200 : 165245 : sym = e->symtree->n.sym;
6201 : :
6202 : 165245 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
6203 : 17112 : coarray = CLASS_DATA (sym)->attr.codimension;
6204 : : else
6205 : 148133 : coarray = sym->attr.codimension;
6206 : :
6207 : 350572 : for (ref = e->ref; ref; ref = ref->next)
6208 : 185327 : switch (ref->type)
6209 : : {
6210 : 25689 : case REF_COMPONENT:
6211 : 25689 : comp = ref->u.c.component;
6212 : 25689 : if (comp->ts.type == BT_CLASS && comp->attr.class_ok
6213 : 2403 : && (CLASS_DATA (comp)->attr.class_pointer
6214 : 2098 : || CLASS_DATA (comp)->attr.allocatable))
6215 : : {
6216 : 2403 : coindexed = false;
6217 : 2403 : coarray = CLASS_DATA (comp)->attr.codimension;
6218 : : }
6219 : 23286 : else if (comp->attr.pointer || comp->attr.allocatable)
6220 : : {
6221 : 21842 : coindexed = false;
6222 : 21842 : coarray = comp->attr.codimension;
6223 : : }
6224 : : break;
6225 : :
6226 : 159200 : case REF_ARRAY:
6227 : 159200 : if (!coarray)
6228 : : break;
6229 : :
6230 : 4807 : if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
6231 : : {
6232 : : coindexed = true;
6233 : : break;
6234 : : }
6235 : :
6236 : 7791 : for (i = 0; i < ref->u.ar.dimen; i++)
6237 : 3409 : if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6238 : : {
6239 : : coarray = false;
6240 : : break;
6241 : : }
6242 : : break;
6243 : :
6244 : : case REF_SUBSTRING:
6245 : : case REF_INQUIRY:
6246 : : break;
6247 : : }
6248 : :
6249 : 165245 : return coarray && !coindexed;
6250 : : }
6251 : :
6252 : :
6253 : : /* Check whether the expression has an ultimate allocatable component.
6254 : : Being itself allocatable does not count. */
6255 : : bool
6256 : 342 : gfc_has_ultimate_allocatable (gfc_expr *e)
6257 : : {
6258 : 342 : gfc_ref *ref, *last = NULL;
6259 : :
6260 : 342 : if (e->expr_type != EXPR_VARIABLE)
6261 : : return false;
6262 : :
6263 : 585 : for (ref = e->ref; ref; ref = ref->next)
6264 : 243 : if (ref->type == REF_COMPONENT)
6265 : 10 : last = ref;
6266 : :
6267 : 342 : if (last && last->u.c.component->ts.type == BT_CLASS)
6268 : 0 : return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
6269 : 9 : else if (last && last->u.c.component->ts.type == BT_DERIVED)
6270 : 1 : return last->u.c.component->ts.u.derived->attr.alloc_comp;
6271 : 333 : else if (last)
6272 : : return false;
6273 : :
6274 : 333 : if (e->ts.type == BT_CLASS)
6275 : 4 : return CLASS_DATA (e)->attr.alloc_comp;
6276 : 329 : else if (e->ts.type == BT_DERIVED)
6277 : 147 : return e->ts.u.derived->attr.alloc_comp;
6278 : : else
6279 : : return false;
6280 : : }
6281 : :
6282 : :
6283 : : /* Check whether the expression has an pointer component.
6284 : : Being itself a pointer does not count. */
6285 : : bool
6286 : 306 : gfc_has_ultimate_pointer (gfc_expr *e)
6287 : : {
6288 : 306 : gfc_ref *ref, *last = NULL;
6289 : :
6290 : 306 : if (e->expr_type != EXPR_VARIABLE)
6291 : : return false;
6292 : :
6293 : 749 : for (ref = e->ref; ref; ref = ref->next)
6294 : 443 : if (ref->type == REF_COMPONENT)
6295 : 99 : last = ref;
6296 : :
6297 : 306 : if (last && last->u.c.component->ts.type == BT_CLASS)
6298 : 0 : return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
6299 : 96 : else if (last && last->u.c.component->ts.type == BT_DERIVED)
6300 : 4 : return last->u.c.component->ts.u.derived->attr.pointer_comp;
6301 : 210 : else if (last)
6302 : : return false;
6303 : :
6304 : 210 : if (e->ts.type == BT_CLASS)
6305 : 2 : return CLASS_DATA (e)->attr.pointer_comp;
6306 : 208 : else if (e->ts.type == BT_DERIVED)
6307 : 6 : return e->ts.u.derived->attr.pointer_comp;
6308 : : else
6309 : : return false;
6310 : : }
6311 : :
6312 : :
6313 : : /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
6314 : : Note: A scalar is not regarded as "simply contiguous" by the standard.
6315 : : if bool is not strict, some further checks are done - for instance,
6316 : : a "(::1)" is accepted. */
6317 : :
6318 : : bool
6319 : 21504 : gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
6320 : : {
6321 : 21504 : bool colon;
6322 : 21504 : int i;
6323 : 21504 : gfc_array_ref *ar = NULL;
6324 : 21504 : gfc_ref *ref, *part_ref = NULL;
6325 : 21504 : gfc_symbol *sym;
6326 : :
6327 : 21504 : if (expr->expr_type == EXPR_ARRAY)
6328 : : return true;
6329 : :
6330 : 21188 : if (expr->expr_type == EXPR_NULL)
6331 : : {
6332 : : /* F2018:16.9.144 NULL ([MOLD]):
6333 : : "If MOLD is present, the characteristics are the same as MOLD."
6334 : : "If MOLD is absent, the characteristics of the result are
6335 : : determined by the entity with which the reference is associated."
6336 : : F2018:15.3.2.2 characteristics attributes include CONTIGUOUS. */
6337 : 7 : if (expr->ts.type == BT_UNKNOWN)
6338 : : return true;
6339 : : else
6340 : 6 : return (gfc_variable_attr (expr, NULL).contiguous
6341 : 12 : || gfc_variable_attr (expr, NULL).allocatable);
6342 : : }
6343 : :
6344 : 21181 : if (expr->expr_type == EXPR_FUNCTION)
6345 : : {
6346 : 360 : if (expr->value.function.isym)
6347 : : /* TRANSPOSE is the only intrinsic that may return a
6348 : : non-contiguous array. It's treated as a special case in
6349 : : gfc_conv_expr_descriptor too. */
6350 : 298 : return (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
6351 : 62 : else if (expr->value.function.esym)
6352 : : /* Only a pointer to an array without the contiguous attribute
6353 : : can be non-contiguous as a result value. */
6354 : 60 : return (expr->value.function.esym->result->attr.contiguous
6355 : 96 : || !expr->value.function.esym->result->attr.pointer);
6356 : : else
6357 : : {
6358 : : /* Type-bound procedures. */
6359 : 2 : gfc_symbol *s = expr->symtree->n.sym;
6360 : 2 : if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED)
6361 : : return false;
6362 : :
6363 : 2 : gfc_ref *rc = NULL;
6364 : 7 : for (gfc_ref *r = expr->ref; r; r = r->next)
6365 : 5 : if (r->type == REF_COMPONENT)
6366 : 5 : rc = r;
6367 : :
6368 : 2 : if (rc == NULL || rc->u.c.component == NULL
6369 : 2 : || rc->u.c.component->ts.interface == NULL)
6370 : : return false;
6371 : :
6372 : 2 : return rc->u.c.component->ts.interface->attr.contiguous;
6373 : : }
6374 : : }
6375 : 20821 : else if (expr->expr_type != EXPR_VARIABLE)
6376 : : return false;
6377 : :
6378 : 20768 : if (!permit_element && expr->rank == 0)
6379 : : return false;
6380 : :
6381 : 44097 : for (ref = expr->ref; ref; ref = ref->next)
6382 : : {
6383 : 23421 : if (ar)
6384 : : return false; /* Array shall be last part-ref. */
6385 : :
6386 : 23345 : if (ref->type == REF_COMPONENT)
6387 : : part_ref = ref;
6388 : 20735 : else if (ref->type == REF_SUBSTRING)
6389 : : return false;
6390 : 20728 : else if (ref->type == REF_INQUIRY)
6391 : : return false;
6392 : 20720 : else if (ref->u.ar.type != AR_ELEMENT)
6393 : 20117 : ar = &ref->u.ar;
6394 : : }
6395 : :
6396 : 20676 : sym = expr->symtree->n.sym;
6397 : 20676 : if ((part_ref
6398 : 2319 : && part_ref->u.c.component
6399 : 2319 : && !part_ref->u.c.component->attr.contiguous
6400 : 2310 : && IS_POINTER (part_ref->u.c.component))
6401 : : || (!part_ref
6402 : 18357 : && expr->ts.type != BT_CLASS
6403 : 18267 : && !sym->attr.contiguous
6404 : 13298 : && (sym->attr.pointer
6405 : 11435 : || (sym->as && sym->as->type == AS_ASSUMED_RANK)
6406 : 11037 : || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))
6407 : : return false;
6408 : :
6409 : : /* An associate variable may point to a non-contiguous target. */
6410 : 16209 : if (ar && ar->type == AR_FULL
6411 : 9209 : && sym->attr.associate_var && !sym->attr.contiguous
6412 : 162 : && sym->assoc
6413 : 162 : && sym->assoc->target)
6414 : 162 : return gfc_is_simply_contiguous (sym->assoc->target, strict,
6415 : 162 : permit_element);
6416 : :
6417 : 15688 : if (!ar || ar->type == AR_FULL)
6418 : : return true;
6419 : :
6420 : 6641 : gcc_assert (ar->type == AR_SECTION);
6421 : :
6422 : : /* Check for simply contiguous array */
6423 : : colon = true;
6424 : 12769 : for (i = 0; i < ar->dimen; i++)
6425 : : {
6426 : 7399 : if (ar->dimen_type[i] == DIMEN_VECTOR)
6427 : : return false;
6428 : :
6429 : 7399 : if (ar->dimen_type[i] == DIMEN_ELEMENT)
6430 : : {
6431 : 25 : colon = false;
6432 : 25 : continue;
6433 : : }
6434 : :
6435 : 7374 : gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
6436 : :
6437 : :
6438 : : /* If the previous section was not contiguous, that's an error,
6439 : : unless we have effective only one element and checking is not
6440 : : strict. */
6441 : 7374 : if (!colon && (strict || !ar->start[i] || !ar->end[i]
6442 : 95 : || ar->start[i]->expr_type != EXPR_CONSTANT
6443 : 93 : || ar->end[i]->expr_type != EXPR_CONSTANT
6444 : 51 : || mpz_cmp (ar->start[i]->value.integer,
6445 : 51 : ar->end[i]->value.integer) != 0))
6446 : : return false;
6447 : :
6448 : : /* Following the standard, "(::1)" or - if known at compile time -
6449 : : "(lbound:ubound)" are not simply contiguous; if strict
6450 : : is false, they are regarded as simply contiguous. */
6451 : 7174 : if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
6452 : 1069 : || ar->stride[i]->ts.type != BT_INTEGER
6453 : 1069 : || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
6454 : : return false;
6455 : :
6456 : 6103 : if (ar->start[i]
6457 : 3905 : && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
6458 : 3859 : || !ar->as->lower[i]
6459 : 2130 : || ar->as->lower[i]->expr_type != EXPR_CONSTANT
6460 : 2130 : || mpz_cmp (ar->start[i]->value.integer,
6461 : 2130 : ar->as->lower[i]->value.integer) != 0))
6462 : 6103 : colon = false;
6463 : :
6464 : 6103 : if (ar->end[i]
6465 : 3936 : && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
6466 : 3427 : || !ar->as->upper[i]
6467 : 1988 : || ar->as->upper[i]->expr_type != EXPR_CONSTANT
6468 : 1988 : || mpz_cmp (ar->end[i]->value.integer,
6469 : 1988 : ar->as->upper[i]->value.integer) != 0))
6470 : 6128 : colon = false;
6471 : : }
6472 : :
6473 : : return true;
6474 : : }
6475 : :
6476 : : /* Return true if the expression is guaranteed to be non-contiguous,
6477 : : false if we cannot prove anything. It is probably best to call
6478 : : this after gfc_is_simply_contiguous. If neither of them returns
6479 : : true, we cannot say (at compile-time). */
6480 : :
6481 : : bool
6482 : 2658 : gfc_is_not_contiguous (gfc_expr *array)
6483 : : {
6484 : 2658 : int i;
6485 : 2658 : gfc_array_ref *ar = NULL;
6486 : 2658 : gfc_ref *ref;
6487 : 2658 : bool previous_incomplete;
6488 : :
6489 : 6612 : for (ref = array->ref; ref; ref = ref->next)
6490 : : {
6491 : : /* Array-ref shall be last ref. */
6492 : :
6493 : 4014 : if (ar && ar->type != AR_ELEMENT)
6494 : : return true;
6495 : :
6496 : 3954 : if (ref->type == REF_ARRAY)
6497 : 2656 : ar = &ref->u.ar;
6498 : : }
6499 : :
6500 : 2598 : if (ar == NULL || ar->type != AR_SECTION)
6501 : : return false;
6502 : :
6503 : : previous_incomplete = false;
6504 : :
6505 : : /* Check if we can prove that the array is not contiguous. */
6506 : :
6507 : 1525 : for (i = 0; i < ar->dimen; i++)
6508 : : {
6509 : 862 : mpz_t arr_size, ref_size;
6510 : :
6511 : 862 : if (gfc_ref_dimen_size (ar, i, &ref_size, NULL))
6512 : : {
6513 : 419 : if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size))
6514 : : {
6515 : : /* a(2:4,2:) is known to be non-contiguous, but
6516 : : a(2:4,i:i) can be contiguous. */
6517 : 61 : mpz_add_ui (arr_size, arr_size, 1L);
6518 : 61 : if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0)
6519 : : {
6520 : 6 : mpz_clear (arr_size);
6521 : 6 : mpz_clear (ref_size);
6522 : 13 : return true;
6523 : : }
6524 : 55 : else if (mpz_cmp (arr_size, ref_size) != 0)
6525 : 28 : previous_incomplete = true;
6526 : :
6527 : 55 : mpz_clear (arr_size);
6528 : : }
6529 : :
6530 : : /* Check for a(::2), i.e. where the stride is not unity.
6531 : : This is only done if there is more than one element in
6532 : : the reference along this dimension. */
6533 : :
6534 : 413 : if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION
6535 : 407 : && ar->dimen_type[i] == DIMEN_RANGE
6536 : 407 : && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT
6537 : 15 : && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)
6538 : : {
6539 : 7 : mpz_clear (ref_size);
6540 : 7 : return true;
6541 : : }
6542 : :
6543 : 406 : mpz_clear (ref_size);
6544 : : }
6545 : : }
6546 : : /* We didn't find anything definitive. */
6547 : : return false;
6548 : : }
6549 : :
6550 : : /* Build call to an intrinsic procedure. The number of arguments has to be
6551 : : passed (rather than ending the list with a NULL value) because we may
6552 : : want to add arguments but with a NULL-expression. */
6553 : :
6554 : : gfc_expr*
6555 : 20479 : gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
6556 : : locus where, unsigned numarg, ...)
6557 : : {
6558 : 20479 : gfc_expr* result;
6559 : 20479 : gfc_actual_arglist* atail;
6560 : 20479 : gfc_intrinsic_sym* isym;
6561 : 20479 : va_list ap;
6562 : 20479 : unsigned i;
6563 : 20479 : const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
6564 : :
6565 : 20479 : isym = gfc_intrinsic_function_by_id (id);
6566 : 20479 : gcc_assert (isym);
6567 : :
6568 : 20479 : result = gfc_get_expr ();
6569 : 20479 : result->expr_type = EXPR_FUNCTION;
6570 : 20479 : result->ts = isym->ts;
6571 : 20479 : result->where = where;
6572 : 20479 : result->value.function.name = mangled_name;
6573 : 20479 : result->value.function.isym = isym;
6574 : :
6575 : 20479 : gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
6576 : 20479 : gfc_commit_symbol (result->symtree->n.sym);
6577 : 20479 : gcc_assert (result->symtree
6578 : : && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
6579 : : || result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
6580 : 20479 : result->symtree->n.sym->intmod_sym_id = id;
6581 : 20479 : result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
6582 : 20479 : result->symtree->n.sym->attr.intrinsic = 1;
6583 : 20479 : result->symtree->n.sym->attr.artificial = 1;
6584 : :
6585 : 20479 : va_start (ap, numarg);
6586 : 20479 : atail = NULL;
6587 : 70805 : for (i = 0; i < numarg; ++i)
6588 : : {
6589 : 50326 : if (atail)
6590 : : {
6591 : 29847 : atail->next = gfc_get_actual_arglist ();
6592 : 29847 : atail = atail->next;
6593 : : }
6594 : : else
6595 : 20479 : atail = result->value.function.actual = gfc_get_actual_arglist ();
6596 : :
6597 : 50326 : atail->expr = va_arg (ap, gfc_expr*);
6598 : : }
6599 : 20479 : va_end (ap);
6600 : :
6601 : 20479 : return result;
6602 : : }
6603 : :
6604 : :
6605 : : /* Check if a symbol referenced in a submodule is declared in the ancestor
6606 : : module and not accessed by use-association, and that the submodule is a
6607 : : descendant. */
6608 : :
6609 : : static bool
6610 : 4 : sym_is_from_ancestor (gfc_symbol *sym)
6611 : : {
6612 : 4 : const char dot[2] = ".";
6613 : : /* Symbols take the form module.submodule_ or module.name_. */
6614 : 4 : char ancestor_module[2 * GFC_MAX_SYMBOL_LEN + 2];
6615 : 4 : char *ancestor;
6616 : :
6617 : 4 : if (sym == NULL
6618 : 4 : || sym->attr.use_assoc
6619 : 4 : || !sym->attr.used_in_submodule
6620 : 4 : || !sym->module
6621 : 4 : || !sym->ns->proc_name
6622 : 4 : || !sym->ns->proc_name->name)
6623 : : return false;
6624 : :
6625 : 4 : memset (ancestor_module, '\0', sizeof (ancestor_module));
6626 : 4 : strcpy (ancestor_module, sym->ns->proc_name->name);
6627 : 4 : ancestor = strtok (ancestor_module, dot);
6628 : 4 : return strcmp (ancestor, sym->module) == 0;
6629 : : }
6630 : :
6631 : :
6632 : : /* Check if an expression may appear in a variable definition context
6633 : : (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
6634 : : This is called from the various places when resolving
6635 : : the pieces that make up such a context.
6636 : : If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
6637 : : variables), some checks are not performed.
6638 : :
6639 : : Optionally, a possible error message can be suppressed if context is NULL
6640 : : and just the return status (true / false) be requested. */
6641 : :
6642 : : bool
6643 : 405399 : gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
6644 : : bool own_scope, const char* context)
6645 : : {
6646 : 405399 : gfc_symbol* sym = NULL;
6647 : 405399 : bool is_pointer;
6648 : 405399 : bool check_intentin;
6649 : 405399 : bool ptr_component;
6650 : 405399 : symbol_attribute attr;
6651 : 405399 : gfc_ref* ref;
6652 : 405399 : int i;
6653 : :
6654 : 405399 : if (e->expr_type == EXPR_VARIABLE)
6655 : : {
6656 : 405325 : gcc_assert (e->symtree);
6657 : 405325 : sym = e->symtree->n.sym;
6658 : : }
6659 : 74 : else if (e->expr_type == EXPR_FUNCTION)
6660 : : {
6661 : 18 : gcc_assert (e->symtree);
6662 : 18 : sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
6663 : : }
6664 : :
6665 : 405399 : attr = gfc_expr_attr (e);
6666 : 405399 : if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
6667 : : {
6668 : 16 : if (!(gfc_option.allow_std & GFC_STD_F2008))
6669 : : {
6670 : 1 : if (context)
6671 : 1 : gfc_error ("Fortran 2008: Pointer functions in variable definition"
6672 : : " context (%s) at %L", context, &e->where);
6673 : 1 : return false;
6674 : : }
6675 : : }
6676 : 405383 : else if (e->expr_type != EXPR_VARIABLE)
6677 : : {
6678 : 58 : if (context)
6679 : 55 : gfc_error ("Non-variable expression in variable definition context (%s)"
6680 : : " at %L", context, &e->where);
6681 : 58 : return false;
6682 : : }
6683 : :
6684 : 405340 : if (!pointer && sym->attr.flavor == FL_PARAMETER)
6685 : : {
6686 : 5 : if (context)
6687 : 5 : gfc_error ("Named constant %qs in variable definition context (%s)"
6688 : : " at %L", sym->name, context, &e->where);
6689 : 5 : return false;
6690 : : }
6691 : 388624 : if (!pointer && sym->attr.flavor != FL_VARIABLE
6692 : 10475 : && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
6693 : 562 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)
6694 : 3 : && !(sym->attr.flavor == FL_PROCEDURE
6695 : 3 : && sym->attr.function && attr.pointer))
6696 : : {
6697 : 0 : if (context)
6698 : 0 : gfc_error ("%qs in variable definition context (%s) at %L is not"
6699 : : " a variable", sym->name, context, &e->where);
6700 : 0 : return false;
6701 : : }
6702 : :
6703 : : /* Find out whether the expr is a pointer; this also means following
6704 : : component references to the last one. */
6705 : 405335 : is_pointer = (attr.pointer || attr.proc_pointer);
6706 : 405335 : if (pointer && !is_pointer)
6707 : : {
6708 : 5 : if (context)
6709 : 5 : gfc_error ("Non-POINTER in pointer association context (%s)"
6710 : : " at %L", context, &e->where);
6711 : 5 : return false;
6712 : : }
6713 : :
6714 : 405330 : if (e->ts.type == BT_DERIVED
6715 : 20170 : && e->ts.u.derived == NULL)
6716 : : {
6717 : 1 : if (context)
6718 : 1 : gfc_error ("Type inaccessible in variable definition context (%s) "
6719 : : "at %L", context, &e->where);
6720 : 1 : return false;
6721 : : }
6722 : :
6723 : : /* F2008, C1303. */
6724 : 405329 : if (!alloc_obj
6725 : 374198 : && (attr.lock_comp
6726 : 374198 : || (e->ts.type == BT_DERIVED
6727 : 15587 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6728 : 24 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
6729 : : {
6730 : 3 : if (context)
6731 : 3 : gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6732 : : context, &e->where);
6733 : 3 : return false;
6734 : : }
6735 : :
6736 : : /* TS18508, C702/C203. */
6737 : 374195 : if (!alloc_obj
6738 : : && (attr.lock_comp
6739 : 374195 : || (e->ts.type == BT_DERIVED
6740 : 15584 : && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6741 : 21 : && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
6742 : : {
6743 : 0 : if (context)
6744 : 0 : gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6745 : : context, &e->where);
6746 : 0 : return false;
6747 : : }
6748 : :
6749 : : /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6750 : : component of sub-component of a pointer; we need to distinguish
6751 : : assignment to a pointer component from pointer-assignment to a pointer
6752 : : component. Note that (normal) assignment to procedure pointers is not
6753 : : possible. */
6754 : 405326 : check_intentin = !own_scope;
6755 : 13869 : ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived
6756 : 13869 : && CLASS_DATA (sym))
6757 : 419195 : ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
6758 : 532619 : for (ref = e->ref; ref && check_intentin; ref = ref->next)
6759 : : {
6760 : 127301 : if (ptr_component && ref->type == REF_COMPONENT)
6761 : 127301 : check_intentin = false;
6762 : 127301 : if (ref->type == REF_COMPONENT)
6763 : : {
6764 : 29622 : gfc_component *comp = ref->u.c.component;
6765 : 2443 : ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok)
6766 : 32065 : ? CLASS_DATA (comp)->attr.class_pointer
6767 : 27179 : : comp->attr.pointer;
6768 : 29622 : if (ptr_component && !pointer)
6769 : 4184 : check_intentin = false;
6770 : : }
6771 : 127301 : if (ref->type == REF_INQUIRY
6772 : 90 : && (ref->u.i == INQUIRY_KIND || ref->u.i == INQUIRY_LEN))
6773 : : {
6774 : 8 : if (context)
6775 : 16 : gfc_error ("%qs parameter inquiry for %qs in "
6776 : : "variable definition context (%s) at %L",
6777 : : ref->u.i == INQUIRY_KIND ? "KIND" : "LEN",
6778 : : sym->name, context, &e->where);
6779 : 8 : return false;
6780 : : }
6781 : : }
6782 : :
6783 : 405318 : if (check_intentin
6784 : 394505 : && (sym->attr.intent == INTENT_IN
6785 : 394415 : || (sym->attr.select_type_temporary && sym->assoc
6786 : 1315 : && sym->assoc->target && sym->assoc->target->symtree
6787 : 1315 : && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN)))
6788 : : {
6789 : 92 : if (pointer && is_pointer)
6790 : : {
6791 : 16 : if (context)
6792 : 16 : gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6793 : : " association context (%s) at %L",
6794 : : sym->name, context, &e->where);
6795 : 16 : return false;
6796 : : }
6797 : 76 : if (!pointer && !is_pointer && !sym->attr.pointer)
6798 : : {
6799 : 22 : const char *name = sym->attr.select_type_temporary
6800 : 24 : ? sym->assoc->target->symtree->name : sym->name;
6801 : 24 : if (context)
6802 : 17 : gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6803 : : " definition context (%s) at %L",
6804 : : name, context, &e->where);
6805 : 24 : return false;
6806 : : }
6807 : : }
6808 : :
6809 : : /* PROTECTED and use-associated. */
6810 : 405278 : if (sym->attr.is_protected
6811 : 264 : && (sym->attr.use_assoc
6812 : 201 : || (sym->attr.used_in_submodule && !sym_is_from_ancestor (sym)))
6813 : 405342 : && check_intentin)
6814 : : {
6815 : 57 : if (pointer && is_pointer)
6816 : : {
6817 : 15 : if (context)
6818 : 15 : gfc_error ("Variable %qs is PROTECTED and cannot appear in a "
6819 : : "pointer association context (%s) at %L",
6820 : : sym->name, context, &e->where);
6821 : 15 : return false;
6822 : : }
6823 : 42 : if (!pointer && !is_pointer)
6824 : : {
6825 : 24 : if (context)
6826 : 23 : gfc_error ("Variable %qs is PROTECTED and cannot appear in a "
6827 : : "variable definition context (%s) at %L",
6828 : : sym->name, context, &e->where);
6829 : 24 : return false;
6830 : : }
6831 : : }
6832 : :
6833 : : /* Variable not assignable from a PURE procedure but appears in
6834 : : variable definition context. */
6835 : 1202664 : own_scope = own_scope
6836 : 405239 : || (sym->attr.result && sym->ns->proc_name
6837 : 8480 : && sym == sym->ns->proc_name->result);
6838 : 392194 : if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
6839 : : {
6840 : 8 : if (context)
6841 : 8 : gfc_error ("Variable %qs cannot appear in a variable definition"
6842 : : " context (%s) at %L in PURE procedure",
6843 : : sym->name, context, &e->where);
6844 : 8 : return false;
6845 : : }
6846 : :
6847 : 383561 : if (!pointer && context && gfc_implicit_pure (NULL)
6848 : 417385 : && gfc_impure_variable (sym))
6849 : : {
6850 : 1082 : gfc_namespace *ns;
6851 : 1082 : gfc_symbol *sym;
6852 : :
6853 : 1156 : for (ns = gfc_current_ns; ns; ns = ns->parent)
6854 : : {
6855 : 1156 : sym = ns->proc_name;
6856 : 1156 : if (sym == NULL)
6857 : : break;
6858 : 1156 : if (sym->attr.flavor == FL_PROCEDURE)
6859 : : {
6860 : 1082 : sym->attr.implicit_pure = 0;
6861 : 1082 : break;
6862 : : }
6863 : : }
6864 : : }
6865 : : /* Check variable definition context for associate-names. */
6866 : 405231 : if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
6867 : : {
6868 : 1259 : const char* name;
6869 : 1259 : gfc_association_list* assoc;
6870 : :
6871 : 1259 : gcc_assert (sym->assoc->target);
6872 : :
6873 : : /* If this is a SELECT TYPE temporary (the association is used internally
6874 : : for SELECT TYPE), silently go over to the target. */
6875 : 1259 : if (sym->attr.select_type_temporary)
6876 : : {
6877 : 898 : gfc_expr* t = sym->assoc->target;
6878 : :
6879 : 898 : gcc_assert (t->expr_type == EXPR_VARIABLE);
6880 : 898 : name = t->symtree->name;
6881 : :
6882 : 898 : if (t->symtree->n.sym->assoc)
6883 : : assoc = t->symtree->n.sym->assoc;
6884 : : else
6885 : 826 : assoc = sym->assoc;
6886 : : }
6887 : : else
6888 : : {
6889 : 361 : name = sym->name;
6890 : 361 : assoc = sym->assoc;
6891 : : }
6892 : 1259 : gcc_assert (name && assoc);
6893 : :
6894 : : /* Is association to a valid variable? */
6895 : 1259 : if (!assoc->variable)
6896 : : {
6897 : 9 : if (context)
6898 : : {
6899 : 9 : if (assoc->target->expr_type == EXPR_VARIABLE
6900 : 9 : && gfc_has_vector_index (assoc->target))
6901 : 4 : gfc_error ("%qs at %L associated to vector-indexed target"
6902 : : " cannot be used in a variable definition"
6903 : : " context (%s)",
6904 : : name, &e->where, context);
6905 : : else
6906 : 5 : gfc_error ("%qs at %L associated to expression"
6907 : : " cannot be used in a variable definition"
6908 : : " context (%s)",
6909 : : name, &e->where, context);
6910 : : }
6911 : 9 : return false;
6912 : : }
6913 : 1250 : else if (context && gfc_is_ptr_fcn (assoc->target))
6914 : : {
6915 : 5 : if (!gfc_notify_std (GFC_STD_F2018, "%qs at %L associated to "
6916 : : "pointer function target being used in a "
6917 : : "variable definition context (%s)", name,
6918 : : &e->where, context))
6919 : : return false;
6920 : 1 : else if (gfc_has_vector_index (e))
6921 : : {
6922 : 0 : gfc_error ("%qs at %L associated to vector-indexed target"
6923 : : " cannot be used in a variable definition"
6924 : : " context (%s)",
6925 : : name, &e->where, context);
6926 : 0 : return false;
6927 : : }
6928 : : }
6929 : :
6930 : : /* Target must be allowed to appear in a variable definition context. */
6931 : 1246 : if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
6932 : : {
6933 : 1 : if (context)
6934 : 1 : gfc_error ("Associate-name %qs cannot appear in a variable"
6935 : : " definition context (%s) at %L because its target"
6936 : : " at %L cannot, either",
6937 : : name, context, &e->where,
6938 : 1 : &assoc->target->where);
6939 : 1 : return false;
6940 : : }
6941 : : }
6942 : :
6943 : : /* Check for same value in vector expression subscript. */
6944 : :
6945 : 405217 : if (e->rank > 0)
6946 : 152920 : for (ref = e->ref; ref != NULL; ref = ref->next)
6947 : 76424 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
6948 : 19610 : for (i = 0; i < GFC_MAX_DIMENSIONS
6949 : 30634 : && ref->u.ar.dimen_type[i] != 0; i++)
6950 : 19617 : if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
6951 : : {
6952 : 243 : gfc_expr *arr = ref->u.ar.start[i];
6953 : 243 : if (arr->expr_type == EXPR_ARRAY)
6954 : : {
6955 : 56 : gfc_constructor *c, *n;
6956 : 56 : gfc_expr *ec, *en;
6957 : :
6958 : 56 : for (c = gfc_constructor_first (arr->value.constructor);
6959 : 191 : c != NULL; c = gfc_constructor_next (c))
6960 : : {
6961 : 142 : if (c == NULL || c->iterator != NULL)
6962 : 12 : continue;
6963 : :
6964 : 130 : ec = c->expr;
6965 : :
6966 : 275 : for (n = gfc_constructor_next (c); n != NULL;
6967 : 145 : n = gfc_constructor_next (n))
6968 : : {
6969 : 152 : if (n->iterator != NULL)
6970 : 12 : continue;
6971 : :
6972 : 140 : en = n->expr;
6973 : 140 : if (gfc_dep_compare_expr (ec, en) == 0)
6974 : : {
6975 : 7 : if (context)
6976 : 7 : gfc_error_now ("Elements with the same value "
6977 : : "at %L and %L in vector "
6978 : : "subscript in a variable "
6979 : : "definition context (%s)",
6980 : : &(ec->where), &(en->where),
6981 : : context);
6982 : 7 : return false;
6983 : : }
6984 : : }
6985 : : }
6986 : : }
6987 : : }
6988 : :
6989 : : return true;
6990 : : }
6991 : :
6992 : : gfc_expr*
6993 : 12 : gfc_pdt_find_component_copy_initializer (gfc_symbol *sym, const char *name)
6994 : : {
6995 : : /* The actual length of a pdt is in its components. In the
6996 : : initializer of the current ref is only the default value.
6997 : : Therefore traverse the chain of components and pick the correct
6998 : : one's initializer expressions. */
6999 : 12 : for (gfc_component *comp = sym->ts.u.derived->components; comp != NULL;
7000 : 0 : comp = comp->next)
7001 : : {
7002 : 12 : if (!strcmp (comp->name, name))
7003 : 12 : return gfc_copy_expr (comp->initializer);
7004 : : }
7005 : : return NULL;
7006 : : }
|
