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