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