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