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