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