]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Routines for manipulation of expression nodes. |
85ec4feb | 2 | Copyright (C) 2000-2018 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Andy Vaught |
4 | ||
9fc4d79b | 5 | This file is part of GCC. |
6de9cd9a | 6 | |
9fc4d79b TS |
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 | |
d234d788 | 9 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 10 | version. |
6de9cd9a | 11 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
16 | |
17 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
18 | along with GCC; see the file COPYING3. If not see |
19 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
20 | |
21 | #include "config.h" | |
d22e4895 | 22 | #include "system.h" |
953bee7c | 23 | #include "coretypes.h" |
1916bcb5 | 24 | #include "options.h" |
6de9cd9a DN |
25 | #include "gfortran.h" |
26 | #include "arith.h" | |
27 | #include "match.h" | |
00a4618b | 28 | #include "target-memory.h" /* for gfc_convert_boz */ |
b7e75771 | 29 | #include "constructor.h" |
f622221a | 30 | #include "tree.h" |
6de9cd9a | 31 | |
b7e75771 JD |
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.c (gfc_get_variable_expr) | |
39 | symbol.c (gfc_lval_expr_from_sym) | |
40 | TODO: Merge these functions, if possible. */ | |
41 | ||
42 | /* Get a new expression node. */ | |
6de9cd9a DN |
43 | |
44 | gfc_expr * | |
45 | gfc_get_expr (void) | |
46 | { | |
47 | gfc_expr *e; | |
48 | ||
ece3f663 | 49 | e = XCNEW (gfc_expr); |
6de9cd9a | 50 | gfc_clear_ts (&e->ts); |
6de9cd9a DN |
51 | e->shape = NULL; |
52 | e->ref = NULL; | |
53 | e->symtree = NULL; | |
6de9cd9a DN |
54 | return e; |
55 | } | |
56 | ||
57 | ||
b7e75771 JD |
58 | /* Get a new expression node that is an array constructor |
59 | of given type and kind. */ | |
6de9cd9a | 60 | |
b7e75771 JD |
61 | gfc_expr * |
62 | gfc_get_array_expr (bt type, int kind, locus *where) | |
6de9cd9a | 63 | { |
b7e75771 | 64 | gfc_expr *e; |
6de9cd9a | 65 | |
b7e75771 JD |
66 | e = gfc_get_expr (); |
67 | e->expr_type = EXPR_ARRAY; | |
68 | e->value.constructor = NULL; | |
69 | e->rank = 1; | |
70 | e->shape = NULL; | |
71 | ||
72 | e->ts.type = type; | |
73 | e->ts.kind = kind; | |
74 | if (where) | |
75 | e->where = *where; | |
76 | ||
77 | return e; | |
6de9cd9a DN |
78 | } |
79 | ||
80 | ||
b7e75771 | 81 | /* Get a new expression node that is the NULL expression. */ |
6de9cd9a | 82 | |
b7e75771 JD |
83 | gfc_expr * |
84 | gfc_get_null_expr (locus *where) | |
6de9cd9a | 85 | { |
b7e75771 | 86 | gfc_expr *e; |
6de9cd9a | 87 | |
b7e75771 JD |
88 | e = gfc_get_expr (); |
89 | e->expr_type = EXPR_NULL; | |
90 | e->ts.type = BT_UNKNOWN; | |
6de9cd9a | 91 | |
b7e75771 JD |
92 | if (where) |
93 | e->where = *where; | |
94 | ||
95 | return e; | |
96 | } | |
97 | ||
98 | ||
99 | /* Get a new expression node that is an operator expression node. */ | |
100 | ||
101 | gfc_expr * | |
102 | gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, | |
103 | gfc_expr *op1, gfc_expr *op2) | |
104 | { | |
105 | gfc_expr *e; | |
106 | ||
107 | e = gfc_get_expr (); | |
108 | e->expr_type = EXPR_OP; | |
109 | e->value.op.op = op; | |
110 | e->value.op.op1 = op1; | |
111 | e->value.op.op2 = op2; | |
112 | ||
113 | if (where) | |
114 | e->where = *where; | |
115 | ||
116 | 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 | gfc_get_structure_constructor_expr (bt type, int kind, locus *where) | |
125 | { | |
126 | gfc_expr *e; | |
127 | ||
128 | e = gfc_get_expr (); | |
129 | e->expr_type = EXPR_STRUCTURE; | |
130 | e->value.constructor = NULL; | |
131 | ||
132 | e->ts.type = type; | |
133 | e->ts.kind = kind; | |
134 | if (where) | |
135 | e->where = *where; | |
136 | ||
137 | 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 | gfc_get_constant_expr (bt type, int kind, locus *where) | |
145 | { | |
146 | gfc_expr *e; | |
147 | ||
148 | if (!where) | |
a4d9b221 TB |
149 | gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be " |
150 | "NULL"); | |
b7e75771 JD |
151 | |
152 | e = gfc_get_expr (); | |
153 | ||
154 | e->expr_type = EXPR_CONSTANT; | |
155 | e->ts.type = type; | |
156 | e->ts.kind = kind; | |
157 | e->where = *where; | |
158 | ||
159 | switch (type) | |
6de9cd9a | 160 | { |
b7e75771 JD |
161 | case BT_INTEGER: |
162 | mpz_init (e->value.integer); | |
163 | break; | |
6de9cd9a | 164 | |
b7e75771 JD |
165 | case BT_REAL: |
166 | gfc_set_model_kind (kind); | |
167 | mpfr_init (e->value.real); | |
168 | break; | |
6de9cd9a | 169 | |
b7e75771 JD |
170 | case BT_COMPLEX: |
171 | gfc_set_model_kind (kind); | |
172 | mpc_init2 (e->value.complex, mpfr_get_default_prec()); | |
173 | break; | |
6de9cd9a | 174 | |
b7e75771 JD |
175 | default: |
176 | break; | |
6de9cd9a DN |
177 | } |
178 | ||
b7e75771 | 179 | return e; |
6de9cd9a DN |
180 | } |
181 | ||
182 | ||
b7e75771 JD |
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. */ | |
6de9cd9a | 186 | |
b7e75771 | 187 | gfc_expr * |
f622221a | 188 | gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len) |
6de9cd9a | 189 | { |
b7e75771 JD |
190 | gfc_expr *e; |
191 | gfc_char_t *dest; | |
6de9cd9a | 192 | |
b7e75771 | 193 | if (!src) |
6de9cd9a | 194 | { |
b7e75771 JD |
195 | dest = gfc_get_wide_string (len + 1); |
196 | gfc_wide_memset (dest, ' ', len); | |
197 | dest[len] = '\0'; | |
198 | } | |
199 | else | |
200 | dest = gfc_char_to_widechar (src); | |
6de9cd9a | 201 | |
b7e75771 JD |
202 | e = gfc_get_constant_expr (BT_CHARACTER, kind, |
203 | where ? where : &gfc_current_locus); | |
204 | e->value.character.string = dest; | |
205 | e->value.character.length = len; | |
206 | ||
207 | return e; | |
208 | } | |
209 | ||
210 | ||
211 | /* Get a new expression node that is an integer constant. */ | |
212 | ||
213 | gfc_expr * | |
f622221a | 214 | gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value) |
b7e75771 JD |
215 | { |
216 | gfc_expr *p; | |
217 | p = gfc_get_constant_expr (BT_INTEGER, kind, | |
218 | where ? where : &gfc_current_locus); | |
219 | ||
f622221a JB |
220 | const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT); |
221 | wi::to_mpz (w, p->value.integer, SIGNED); | |
b7e75771 JD |
222 | |
223 | return p; | |
224 | } | |
225 | ||
226 | ||
227 | /* Get a new expression node that is a logical constant. */ | |
228 | ||
229 | gfc_expr * | |
230 | gfc_get_logical_expr (int kind, locus *where, bool value) | |
231 | { | |
232 | gfc_expr *p; | |
233 | p = gfc_get_constant_expr (BT_LOGICAL, kind, | |
234 | where ? where : &gfc_current_locus); | |
235 | ||
236 | p->value.logical = value; | |
237 | ||
238 | return p; | |
239 | } | |
240 | ||
241 | ||
242 | gfc_expr * | |
243 | gfc_get_iokind_expr (locus *where, io_kind k) | |
244 | { | |
245 | 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 | e = gfc_get_expr (); | |
252 | e->expr_type = EXPR_CONSTANT; | |
253 | e->ts.type = BT_LOGICAL; | |
254 | e->value.iokind = k; | |
255 | e->where = *where; | |
256 | ||
257 | 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 | gfc_copy_expr (gfc_expr *p) | |
266 | { | |
267 | gfc_expr *q; | |
268 | gfc_char_t *s; | |
269 | char *c; | |
270 | ||
271 | if (p == NULL) | |
272 | return NULL; | |
273 | ||
274 | q = gfc_get_expr (); | |
275 | *q = *p; | |
276 | ||
277 | switch (q->expr_type) | |
278 | { | |
279 | case EXPR_SUBSTRING: | |
280 | s = gfc_get_wide_string (p->value.character.length + 1); | |
281 | q->value.character.string = s; | |
282 | memcpy (s, p->value.character.string, | |
283 | (p->value.character.length + 1) * sizeof (gfc_char_t)); | |
284 | break; | |
285 | ||
286 | case EXPR_CONSTANT: | |
287 | /* Copy target representation, if it exists. */ | |
288 | if (p->representation.string) | |
6de9cd9a | 289 | { |
b7e75771 JD |
290 | c = XCNEWVEC (char, p->representation.length + 1); |
291 | q->representation.string = c; | |
292 | memcpy (c, p->representation.string, (p->representation.length + 1)); | |
293 | } | |
294 | ||
295 | /* Copy the values of any pointer components of p->value. */ | |
296 | switch (q->ts.type) | |
297 | { | |
298 | case BT_INTEGER: | |
299 | mpz_init_set (q->value.integer, p->value.integer); | |
300 | break; | |
301 | ||
302 | case BT_REAL: | |
303 | gfc_set_model_kind (q->ts.kind); | |
304 | mpfr_init (q->value.real); | |
305 | mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); | |
306 | break; | |
307 | ||
308 | case BT_COMPLEX: | |
309 | gfc_set_model_kind (q->ts.kind); | |
310 | mpc_init2 (q->value.complex, mpfr_get_default_prec()); | |
311 | mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); | |
312 | break; | |
313 | ||
314 | case BT_CHARACTER: | |
315 | if (p->representation.string) | |
316 | q->value.character.string | |
317 | = gfc_char_to_widechar (q->representation.string); | |
318 | else | |
6de9cd9a | 319 | { |
b7e75771 JD |
320 | s = gfc_get_wide_string (p->value.character.length + 1); |
321 | q->value.character.string = s; | |
6de9cd9a | 322 | |
b7e75771 JD |
323 | /* This is the case for the C_NULL_CHAR named constant. */ |
324 | if (p->value.character.length == 0 | |
325 | && (p->ts.is_c_interop || p->ts.is_iso_c)) | |
326 | { | |
327 | *s = '\0'; | |
328 | /* Need to set the length to 1 to make sure the NUL | |
329 | terminator is copied. */ | |
330 | q->value.character.length = 1; | |
331 | } | |
332 | else | |
333 | memcpy (s, p->value.character.string, | |
334 | (p->value.character.length + 1) * sizeof (gfc_char_t)); | |
335 | } | |
6de9cd9a DN |
336 | break; |
337 | ||
b7e75771 JD |
338 | case BT_HOLLERITH: |
339 | case BT_LOGICAL: | |
f6288c24 | 340 | case_bt_struct: |
b7e75771 | 341 | case BT_CLASS: |
45a69325 | 342 | case BT_ASSUMED: |
b7e75771 JD |
343 | break; /* Already done. */ |
344 | ||
345 | case BT_PROCEDURE: | |
346 | case BT_VOID: | |
347 | /* Should never be reached. */ | |
348 | case BT_UNKNOWN: | |
349 | gfc_internal_error ("gfc_copy_expr(): Bad expr node"); | |
350 | /* Not reached. */ | |
351 | } | |
352 | ||
353 | break; | |
354 | ||
355 | case EXPR_OP: | |
356 | switch (q->value.op.op) | |
357 | { | |
358 | case INTRINSIC_NOT: | |
359 | case INTRINSIC_PARENTHESES: | |
360 | case INTRINSIC_UPLUS: | |
361 | case INTRINSIC_UMINUS: | |
362 | q->value.op.op1 = gfc_copy_expr (p->value.op.op1); | |
6de9cd9a DN |
363 | break; |
364 | ||
b7e75771 JD |
365 | default: /* Binary operators. */ |
366 | q->value.op.op1 = gfc_copy_expr (p->value.op.op1); | |
367 | q->value.op.op2 = gfc_copy_expr (p->value.op.op2); | |
6de9cd9a DN |
368 | break; |
369 | } | |
370 | ||
b7e75771 JD |
371 | break; |
372 | ||
373 | case EXPR_FUNCTION: | |
374 | q->value.function.actual = | |
375 | gfc_copy_actual_arglist (p->value.function.actual); | |
376 | break; | |
377 | ||
378 | case EXPR_COMPCALL: | |
379 | case EXPR_PPC: | |
380 | q->value.compcall.actual = | |
381 | gfc_copy_actual_arglist (p->value.compcall.actual); | |
382 | q->value.compcall.tbp = p->value.compcall.tbp; | |
383 | break; | |
384 | ||
385 | case EXPR_STRUCTURE: | |
386 | case EXPR_ARRAY: | |
387 | q->value.constructor = gfc_constructor_copy (p->value.constructor); | |
388 | break; | |
389 | ||
390 | case EXPR_VARIABLE: | |
391 | case EXPR_NULL: | |
392 | break; | |
6de9cd9a | 393 | } |
b7e75771 JD |
394 | |
395 | q->shape = gfc_copy_shape (p->shape, p->rank); | |
396 | ||
397 | q->ref = gfc_copy_ref (p->ref); | |
398 | ||
5bab4c96 PT |
399 | if (p->param_list) |
400 | q->param_list = gfc_copy_actual_arglist (p->param_list); | |
401 | ||
b7e75771 | 402 | return q; |
6de9cd9a DN |
403 | } |
404 | ||
405 | ||
7d7212ec MM |
406 | void |
407 | gfc_clear_shape (mpz_t *shape, int rank) | |
408 | { | |
409 | int i; | |
410 | ||
411 | for (i = 0; i < rank; i++) | |
412 | mpz_clear (shape[i]); | |
413 | } | |
414 | ||
415 | ||
416 | void | |
417 | gfc_free_shape (mpz_t **shape, int rank) | |
418 | { | |
d54e80ce MM |
419 | if (*shape == NULL) |
420 | return; | |
421 | ||
7d7212ec MM |
422 | gfc_clear_shape (*shape, rank); |
423 | free (*shape); | |
424 | *shape = NULL; | |
425 | } | |
426 | ||
427 | ||
6de9cd9a DN |
428 | /* Workhorse function for gfc_free_expr() that frees everything |
429 | beneath an expression node, but not the node itself. This is | |
430 | useful when we want to simplify a node and replace it with | |
431 | something else or the expression node belongs to another structure. */ | |
432 | ||
433 | static void | |
636dff67 | 434 | free_expr0 (gfc_expr *e) |
6de9cd9a | 435 | { |
6de9cd9a DN |
436 | switch (e->expr_type) |
437 | { | |
438 | case EXPR_CONSTANT: | |
20585ad6 | 439 | /* Free any parts of the value that need freeing. */ |
6de9cd9a DN |
440 | switch (e->ts.type) |
441 | { | |
442 | case BT_INTEGER: | |
443 | mpz_clear (e->value.integer); | |
444 | break; | |
445 | ||
446 | case BT_REAL: | |
f8e566e5 | 447 | mpfr_clear (e->value.real); |
6de9cd9a DN |
448 | break; |
449 | ||
450 | case BT_CHARACTER: | |
cede9502 | 451 | free (e->value.character.string); |
6de9cd9a DN |
452 | break; |
453 | ||
454 | case BT_COMPLEX: | |
eb6f9a86 | 455 | mpc_clear (e->value.complex); |
6de9cd9a DN |
456 | break; |
457 | ||
458 | default: | |
459 | break; | |
460 | } | |
461 | ||
00660189 | 462 | /* Free the representation. */ |
04695783 | 463 | free (e->representation.string); |
20585ad6 | 464 | |
6de9cd9a DN |
465 | break; |
466 | ||
467 | case EXPR_OP: | |
58b03ab2 TS |
468 | if (e->value.op.op1 != NULL) |
469 | gfc_free_expr (e->value.op.op1); | |
470 | if (e->value.op.op2 != NULL) | |
471 | gfc_free_expr (e->value.op.op2); | |
6de9cd9a DN |
472 | break; |
473 | ||
474 | case EXPR_FUNCTION: | |
475 | gfc_free_actual_arglist (e->value.function.actual); | |
476 | break; | |
477 | ||
8e1f752a | 478 | case EXPR_COMPCALL: |
713485cc | 479 | case EXPR_PPC: |
8e1f752a DK |
480 | gfc_free_actual_arglist (e->value.compcall.actual); |
481 | break; | |
482 | ||
6de9cd9a DN |
483 | case EXPR_VARIABLE: |
484 | break; | |
485 | ||
486 | case EXPR_ARRAY: | |
487 | case EXPR_STRUCTURE: | |
b7e75771 | 488 | gfc_constructor_free (e->value.constructor); |
6de9cd9a DN |
489 | break; |
490 | ||
491 | case EXPR_SUBSTRING: | |
cede9502 | 492 | free (e->value.character.string); |
6de9cd9a DN |
493 | break; |
494 | ||
495 | case EXPR_NULL: | |
496 | break; | |
497 | ||
498 | default: | |
499 | gfc_internal_error ("free_expr0(): Bad expr type"); | |
500 | } | |
501 | ||
502 | /* Free a shape array. */ | |
d54e80ce | 503 | gfc_free_shape (&e->shape, e->rank); |
b7e75771 JD |
504 | |
505 | gfc_free_ref_list (e->ref); | |
506 | ||
5bab4c96 PT |
507 | gfc_free_actual_arglist (e->param_list); |
508 | ||
b7e75771 JD |
509 | memset (e, '\0', sizeof (gfc_expr)); |
510 | } | |
511 | ||
512 | ||
513 | /* Free an expression node and everything beneath it. */ | |
514 | ||
515 | void | |
516 | gfc_free_expr (gfc_expr *e) | |
517 | { | |
518 | if (e == NULL) | |
519 | return; | |
520 | free_expr0 (e); | |
cede9502 | 521 | free (e); |
b7e75771 JD |
522 | } |
523 | ||
524 | ||
525 | /* Free an argument list and everything below it. */ | |
526 | ||
527 | void | |
528 | gfc_free_actual_arglist (gfc_actual_arglist *a1) | |
529 | { | |
530 | gfc_actual_arglist *a2; | |
531 | ||
532 | while (a1) | |
533 | { | |
534 | a2 = a1->next; | |
5bab4c96 | 535 | if (a1->expr) |
b7e75771 | 536 | gfc_free_expr (a1->expr); |
cede9502 | 537 | free (a1); |
b7e75771 JD |
538 | a1 = a2; |
539 | } | |
540 | } | |
541 | ||
542 | ||
543 | /* Copy an arglist structure and all of the arguments. */ | |
544 | ||
545 | gfc_actual_arglist * | |
546 | gfc_copy_actual_arglist (gfc_actual_arglist *p) | |
547 | { | |
548 | gfc_actual_arglist *head, *tail, *new_arg; | |
549 | ||
550 | head = tail = NULL; | |
551 | ||
552 | for (; p; p = p->next) | |
553 | { | |
554 | new_arg = gfc_get_actual_arglist (); | |
555 | *new_arg = *p; | |
556 | ||
557 | new_arg->expr = gfc_copy_expr (p->expr); | |
558 | new_arg->next = NULL; | |
559 | ||
560 | if (head == NULL) | |
561 | head = new_arg; | |
562 | else | |
563 | tail->next = new_arg; | |
564 | ||
565 | tail = new_arg; | |
566 | } | |
567 | ||
568 | return head; | |
569 | } | |
570 | ||
571 | ||
572 | /* Free a list of reference structures. */ | |
573 | ||
574 | void | |
575 | gfc_free_ref_list (gfc_ref *p) | |
576 | { | |
577 | gfc_ref *q; | |
578 | int i; | |
579 | ||
580 | for (; p; p = q) | |
581 | { | |
582 | q = p->next; | |
6de9cd9a | 583 | |
b7e75771 JD |
584 | switch (p->type) |
585 | { | |
586 | case REF_ARRAY: | |
587 | for (i = 0; i < GFC_MAX_DIMENSIONS; i++) | |
588 | { | |
589 | gfc_free_expr (p->u.ar.start[i]); | |
590 | gfc_free_expr (p->u.ar.end[i]); | |
591 | gfc_free_expr (p->u.ar.stride[i]); | |
592 | } | |
6de9cd9a | 593 | |
b7e75771 | 594 | break; |
6de9cd9a | 595 | |
b7e75771 JD |
596 | case REF_SUBSTRING: |
597 | gfc_free_expr (p->u.ss.start); | |
598 | gfc_free_expr (p->u.ss.end); | |
599 | break; | |
6de9cd9a | 600 | |
b7e75771 JD |
601 | case REF_COMPONENT: |
602 | break; | |
603 | } | |
6de9cd9a | 604 | |
cede9502 | 605 | free (p); |
b7e75771 | 606 | } |
6de9cd9a DN |
607 | } |
608 | ||
609 | ||
610 | /* Graft the *src expression onto the *dest subexpression. */ | |
611 | ||
612 | void | |
636dff67 | 613 | gfc_replace_expr (gfc_expr *dest, gfc_expr *src) |
6de9cd9a | 614 | { |
6de9cd9a DN |
615 | free_expr0 (dest); |
616 | *dest = *src; | |
cede9502 | 617 | free (src); |
6de9cd9a DN |
618 | } |
619 | ||
620 | ||
621 | /* Try to extract an integer constant from the passed expression node. | |
51f03c6b JJ |
622 | Return true if some error occurred, false on success. If REPORT_ERROR |
623 | is non-zero, emit error, for positive REPORT_ERROR using gfc_error, | |
624 | for negative using gfc_error_now. */ | |
6de9cd9a | 625 | |
51f03c6b JJ |
626 | bool |
627 | gfc_extract_int (gfc_expr *expr, int *result, int report_error) | |
6de9cd9a | 628 | { |
18a4e7e3 PT |
629 | gfc_ref *ref; |
630 | ||
631 | /* A KIND component is a parameter too. The expression for it | |
632 | is stored in the initializer and should be consistent with | |
633 | the tests below. */ | |
634 | if (gfc_expr_attr(expr).pdt_kind) | |
635 | { | |
636 | for (ref = expr->ref; ref; ref = ref->next) | |
637 | { | |
638 | if (ref->u.c.component->attr.pdt_kind) | |
639 | expr = ref->u.c.component->initializer; | |
640 | } | |
641 | } | |
642 | ||
6de9cd9a | 643 | if (expr->expr_type != EXPR_CONSTANT) |
51f03c6b JJ |
644 | { |
645 | if (report_error > 0) | |
646 | gfc_error ("Constant expression required at %C"); | |
647 | else if (report_error < 0) | |
648 | gfc_error_now ("Constant expression required at %C"); | |
649 | return true; | |
650 | } | |
6de9cd9a DN |
651 | |
652 | if (expr->ts.type != BT_INTEGER) | |
51f03c6b JJ |
653 | { |
654 | if (report_error > 0) | |
655 | gfc_error ("Integer expression required at %C"); | |
656 | else if (report_error < 0) | |
657 | gfc_error_now ("Integer expression required at %C"); | |
658 | return true; | |
659 | } | |
6de9cd9a DN |
660 | |
661 | if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) | |
662 | || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) | |
663 | { | |
51f03c6b JJ |
664 | if (report_error > 0) |
665 | gfc_error ("Integer value too large in expression at %C"); | |
666 | else if (report_error < 0) | |
667 | gfc_error_now ("Integer value too large in expression at %C"); | |
668 | return true; | |
6de9cd9a DN |
669 | } |
670 | ||
671 | *result = (int) mpz_get_si (expr->value.integer); | |
672 | ||
51f03c6b | 673 | return false; |
6de9cd9a DN |
674 | } |
675 | ||
676 | ||
f622221a JB |
677 | /* Same as gfc_extract_int, but use a HWI. */ |
678 | ||
679 | bool | |
680 | gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error) | |
681 | { | |
682 | gfc_ref *ref; | |
683 | ||
684 | /* A KIND component is a parameter too. The expression for it is | |
685 | stored in the initializer and should be consistent with the tests | |
686 | below. */ | |
687 | if (gfc_expr_attr(expr).pdt_kind) | |
688 | { | |
689 | for (ref = expr->ref; ref; ref = ref->next) | |
690 | { | |
691 | if (ref->u.c.component->attr.pdt_kind) | |
692 | expr = ref->u.c.component->initializer; | |
693 | } | |
694 | } | |
695 | ||
696 | if (expr->expr_type != EXPR_CONSTANT) | |
697 | { | |
698 | if (report_error > 0) | |
699 | gfc_error ("Constant expression required at %C"); | |
700 | else if (report_error < 0) | |
701 | gfc_error_now ("Constant expression required at %C"); | |
702 | return true; | |
703 | } | |
704 | ||
705 | if (expr->ts.type != BT_INTEGER) | |
706 | { | |
707 | if (report_error > 0) | |
708 | gfc_error ("Integer expression required at %C"); | |
709 | else if (report_error < 0) | |
710 | gfc_error_now ("Integer expression required at %C"); | |
711 | return true; | |
712 | } | |
713 | ||
714 | /* Use long_long_integer_type_node to determine when to saturate. */ | |
715 | const wide_int val = wi::from_mpz (long_long_integer_type_node, | |
716 | expr->value.integer, false); | |
717 | ||
718 | if (!wi::fits_shwi_p (val)) | |
719 | { | |
720 | if (report_error > 0) | |
721 | gfc_error ("Integer value too large in expression at %C"); | |
722 | else if (report_error < 0) | |
723 | gfc_error_now ("Integer value too large in expression at %C"); | |
724 | return true; | |
725 | } | |
726 | ||
727 | *result = val.to_shwi (); | |
728 | ||
729 | return false; | |
730 | } | |
731 | ||
732 | ||
6de9cd9a DN |
733 | /* Recursively copy a list of reference structures. */ |
734 | ||
8e1f752a DK |
735 | gfc_ref * |
736 | gfc_copy_ref (gfc_ref *src) | |
6de9cd9a DN |
737 | { |
738 | gfc_array_ref *ar; | |
739 | gfc_ref *dest; | |
740 | ||
741 | if (src == NULL) | |
742 | return NULL; | |
743 | ||
744 | dest = gfc_get_ref (); | |
745 | dest->type = src->type; | |
746 | ||
747 | switch (src->type) | |
748 | { | |
749 | case REF_ARRAY: | |
750 | ar = gfc_copy_array_ref (&src->u.ar); | |
751 | dest->u.ar = *ar; | |
cede9502 | 752 | free (ar); |
6de9cd9a DN |
753 | break; |
754 | ||
755 | case REF_COMPONENT: | |
756 | dest->u.c = src->u.c; | |
757 | break; | |
758 | ||
759 | case REF_SUBSTRING: | |
760 | dest->u.ss = src->u.ss; | |
761 | dest->u.ss.start = gfc_copy_expr (src->u.ss.start); | |
762 | dest->u.ss.end = gfc_copy_expr (src->u.ss.end); | |
763 | break; | |
764 | } | |
765 | ||
8e1f752a | 766 | dest->next = gfc_copy_ref (src->next); |
6de9cd9a DN |
767 | |
768 | return dest; | |
769 | } | |
770 | ||
771 | ||
636dff67 | 772 | /* Detect whether an expression has any vector index array references. */ |
4075a94e PT |
773 | |
774 | int | |
775 | gfc_has_vector_index (gfc_expr *e) | |
776 | { | |
636dff67 | 777 | gfc_ref *ref; |
4075a94e PT |
778 | int i; |
779 | for (ref = e->ref; ref; ref = ref->next) | |
780 | if (ref->type == REF_ARRAY) | |
781 | for (i = 0; i < ref->u.ar.dimen; i++) | |
782 | if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) | |
783 | return 1; | |
784 | return 0; | |
785 | } | |
786 | ||
787 | ||
6de9cd9a DN |
788 | /* Copy a shape array. */ |
789 | ||
790 | mpz_t * | |
636dff67 | 791 | gfc_copy_shape (mpz_t *shape, int rank) |
6de9cd9a DN |
792 | { |
793 | mpz_t *new_shape; | |
794 | int n; | |
795 | ||
796 | if (shape == NULL) | |
797 | return NULL; | |
798 | ||
799 | new_shape = gfc_get_shape (rank); | |
800 | ||
801 | for (n = 0; n < rank; n++) | |
802 | mpz_init_set (new_shape[n], shape[n]); | |
803 | ||
804 | return new_shape; | |
805 | } | |
806 | ||
807 | ||
94538bd1 | 808 | /* Copy a shape array excluding dimension N, where N is an integer |
eea58adb | 809 | constant expression. Dimensions are numbered in Fortran style -- |
94538bd1 VL |
810 | starting with ONE. |
811 | ||
812 | So, if the original shape array contains R elements | |
813 | { s1 ... sN-1 sN sN+1 ... sR-1 sR} | |
814 | the result contains R-1 elements: | |
815 | { s1 ... sN-1 sN+1 ... sR-1} | |
816 | ||
817 | If anything goes wrong -- N is not a constant, its value is out | |
66e4ab31 | 818 | of range -- or anything else, just returns NULL. */ |
94538bd1 VL |
819 | |
820 | mpz_t * | |
636dff67 | 821 | gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) |
94538bd1 VL |
822 | { |
823 | mpz_t *new_shape, *s; | |
824 | int i, n; | |
825 | ||
8b704316 | 826 | if (shape == NULL |
94538bd1 VL |
827 | || rank <= 1 |
828 | || dim == NULL | |
8b704316 | 829 | || dim->expr_type != EXPR_CONSTANT |
94538bd1 VL |
830 | || dim->ts.type != BT_INTEGER) |
831 | return NULL; | |
832 | ||
833 | n = mpz_get_si (dim->value.integer); | |
66e4ab31 | 834 | n--; /* Convert to zero based index. */ |
37e860a2 | 835 | if (n < 0 || n >= rank) |
94538bd1 VL |
836 | return NULL; |
837 | ||
636dff67 | 838 | s = new_shape = gfc_get_shape (rank - 1); |
94538bd1 VL |
839 | |
840 | for (i = 0; i < rank; i++) | |
841 | { | |
842 | if (i == n) | |
636dff67 | 843 | continue; |
94538bd1 VL |
844 | mpz_init_set (*s, shape[i]); |
845 | s++; | |
846 | } | |
847 | ||
848 | return new_shape; | |
849 | } | |
850 | ||
636dff67 | 851 | |
6de9cd9a DN |
852 | /* Return the maximum kind of two expressions. In general, higher |
853 | kind numbers mean more precision for numeric types. */ | |
854 | ||
855 | int | |
636dff67 | 856 | gfc_kind_max (gfc_expr *e1, gfc_expr *e2) |
6de9cd9a | 857 | { |
6de9cd9a DN |
858 | return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; |
859 | } | |
860 | ||
861 | ||
862 | /* Returns nonzero if the type is numeric, zero otherwise. */ | |
863 | ||
864 | static int | |
865 | numeric_type (bt type) | |
866 | { | |
6de9cd9a DN |
867 | return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; |
868 | } | |
869 | ||
870 | ||
871 | /* Returns nonzero if the typespec is a numeric type, zero otherwise. */ | |
872 | ||
873 | int | |
636dff67 | 874 | gfc_numeric_ts (gfc_typespec *ts) |
6de9cd9a | 875 | { |
6de9cd9a DN |
876 | return numeric_type (ts->type); |
877 | } | |
878 | ||
879 | ||
6de9cd9a DN |
880 | /* Return an expression node with an optional argument list attached. |
881 | A variable number of gfc_expr pointers are strung together in an | |
882 | argument list with a NULL pointer terminating the list. */ | |
883 | ||
884 | gfc_expr * | |
636dff67 | 885 | gfc_build_conversion (gfc_expr *e) |
6de9cd9a DN |
886 | { |
887 | gfc_expr *p; | |
888 | ||
889 | p = gfc_get_expr (); | |
890 | p->expr_type = EXPR_FUNCTION; | |
891 | p->symtree = NULL; | |
6de9cd9a DN |
892 | p->value.function.actual = gfc_get_actual_arglist (); |
893 | p->value.function.actual->expr = e; | |
894 | ||
895 | return p; | |
896 | } | |
897 | ||
898 | ||
899 | /* Given an expression node with some sort of numeric binary | |
900 | expression, insert type conversions required to make the operands | |
dcea1b2f DF |
901 | have the same type. Conversion warnings are disabled if wconversion |
902 | is set to 0. | |
6de9cd9a DN |
903 | |
904 | The exception is that the operands of an exponential don't have to | |
905 | have the same type. If possible, the base is promoted to the type | |
906 | of the exponent. For example, 1**2.3 becomes 1.0**2.3, but | |
f7b529fa | 907 | 1.0**2 stays as it is. */ |
6de9cd9a DN |
908 | |
909 | void | |
dcea1b2f | 910 | gfc_type_convert_binary (gfc_expr *e, int wconversion) |
6de9cd9a DN |
911 | { |
912 | gfc_expr *op1, *op2; | |
913 | ||
58b03ab2 TS |
914 | op1 = e->value.op.op1; |
915 | op2 = e->value.op.op2; | |
6de9cd9a DN |
916 | |
917 | if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) | |
918 | { | |
919 | gfc_clear_ts (&e->ts); | |
920 | return; | |
921 | } | |
922 | ||
923 | /* Kind conversions of same type. */ | |
924 | if (op1->ts.type == op2->ts.type) | |
925 | { | |
6de9cd9a DN |
926 | if (op1->ts.kind == op2->ts.kind) |
927 | { | |
636dff67 | 928 | /* No type conversions. */ |
6de9cd9a DN |
929 | e->ts = op1->ts; |
930 | goto done; | |
931 | } | |
932 | ||
933 | if (op1->ts.kind > op2->ts.kind) | |
dcea1b2f | 934 | gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); |
6de9cd9a | 935 | else |
dcea1b2f | 936 | gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); |
6de9cd9a DN |
937 | |
938 | e->ts = op1->ts; | |
939 | goto done; | |
940 | } | |
941 | ||
942 | /* Integer combined with real or complex. */ | |
943 | if (op2->ts.type == BT_INTEGER) | |
944 | { | |
945 | e->ts = op1->ts; | |
946 | ||
687fcae7 | 947 | /* Special case for ** operator. */ |
a1ee985f | 948 | if (e->value.op.op == INTRINSIC_POWER) |
6de9cd9a DN |
949 | goto done; |
950 | ||
dcea1b2f | 951 | gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); |
6de9cd9a DN |
952 | goto done; |
953 | } | |
954 | ||
955 | if (op1->ts.type == BT_INTEGER) | |
956 | { | |
957 | e->ts = op2->ts; | |
dcea1b2f | 958 | gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); |
6de9cd9a DN |
959 | goto done; |
960 | } | |
961 | ||
962 | /* Real combined with complex. */ | |
963 | e->ts.type = BT_COMPLEX; | |
964 | if (op1->ts.kind > op2->ts.kind) | |
965 | e->ts.kind = op1->ts.kind; | |
966 | else | |
967 | e->ts.kind = op2->ts.kind; | |
968 | if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) | |
dcea1b2f | 969 | gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); |
6de9cd9a | 970 | if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) |
dcea1b2f | 971 | gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); |
6de9cd9a DN |
972 | |
973 | done: | |
974 | return; | |
975 | } | |
976 | ||
977 | ||
068b961b | 978 | /* Determine if an expression is constant in the sense of F08:7.1.12. |
7a28353e | 979 | * This function expects that the expression has already been simplified. */ |
6de9cd9a | 980 | |
7a28353e | 981 | bool |
636dff67 | 982 | gfc_is_constant_expr (gfc_expr *e) |
6de9cd9a DN |
983 | { |
984 | gfc_constructor *c; | |
985 | gfc_actual_arglist *arg; | |
6de9cd9a DN |
986 | |
987 | if (e == NULL) | |
7a28353e | 988 | return true; |
6de9cd9a DN |
989 | |
990 | switch (e->expr_type) | |
991 | { | |
992 | case EXPR_OP: | |
b7e75771 JD |
993 | return (gfc_is_constant_expr (e->value.op.op1) |
994 | && (e->value.op.op2 == NULL | |
995 | || gfc_is_constant_expr (e->value.op.op2))); | |
6de9cd9a DN |
996 | |
997 | case EXPR_VARIABLE: | |
5bab4c96 PT |
998 | /* The only context in which this can occur is in a parameterized |
999 | derived type declaration, so returning true is OK. */ | |
1000 | if (e->symtree->n.sym->attr.pdt_len | |
1001 | || e->symtree->n.sym->attr.pdt_kind) | |
1002 | return true; | |
7a28353e | 1003 | return false; |
6de9cd9a DN |
1004 | |
1005 | case EXPR_FUNCTION: | |
687ea68f TB |
1006 | case EXPR_PPC: |
1007 | case EXPR_COMPCALL: | |
0126595f TB |
1008 | gcc_assert (e->symtree || e->value.function.esym |
1009 | || e->value.function.isym); | |
1010 | ||
6de9cd9a | 1011 | /* Call to intrinsic with at least one argument. */ |
6de9cd9a DN |
1012 | if (e->value.function.isym && e->value.function.actual) |
1013 | { | |
1014 | for (arg = e->value.function.actual; arg; arg = arg->next) | |
b7e75771 | 1015 | if (!gfc_is_constant_expr (arg->expr)) |
7a28353e | 1016 | return false; |
6de9cd9a | 1017 | } |
83f3bd62 | 1018 | |
83f3bd62 JD |
1019 | if (e->value.function.isym |
1020 | && (e->value.function.isym->elemental | |
1021 | || e->value.function.isym->pure | |
1022 | || e->value.function.isym->inquiry | |
1023 | || e->value.function.isym->transformational)) | |
7a28353e | 1024 | return true; |
83f3bd62 | 1025 | |
7a28353e | 1026 | return false; |
6de9cd9a DN |
1027 | |
1028 | case EXPR_CONSTANT: | |
1029 | case EXPR_NULL: | |
7a28353e | 1030 | return true; |
6de9cd9a DN |
1031 | |
1032 | case EXPR_SUBSTRING: | |
b7e75771 JD |
1033 | return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) |
1034 | && gfc_is_constant_expr (e->ref->u.ss.end)); | |
6de9cd9a | 1035 | |
8e1e41e7 | 1036 | case EXPR_ARRAY: |
6de9cd9a | 1037 | case EXPR_STRUCTURE: |
8e1e41e7 PT |
1038 | c = gfc_constructor_first (e->value.constructor); |
1039 | if ((e->expr_type == EXPR_ARRAY) && c && c->iterator) | |
1040 | return gfc_constant_ac (e); | |
1041 | ||
1042 | for (; c; c = gfc_constructor_next (c)) | |
6de9cd9a | 1043 | if (!gfc_is_constant_expr (c->expr)) |
7a28353e | 1044 | return false; |
6de9cd9a | 1045 | |
7a28353e | 1046 | return true; |
6de9cd9a | 1047 | |
6de9cd9a DN |
1048 | |
1049 | default: | |
1050 | gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); | |
7a28353e | 1051 | return false; |
6de9cd9a | 1052 | } |
6de9cd9a DN |
1053 | } |
1054 | ||
1055 | ||
1d6b7f39 PT |
1056 | /* Is true if an array reference is followed by a component or substring |
1057 | reference. */ | |
1058 | bool | |
1059 | is_subref_array (gfc_expr * e) | |
1060 | { | |
1061 | gfc_ref * ref; | |
1062 | bool seen_array; | |
1063 | ||
1064 | if (e->expr_type != EXPR_VARIABLE) | |
1065 | return false; | |
1066 | ||
1067 | if (e->symtree->n.sym->attr.subref_array_pointer) | |
1068 | return true; | |
1069 | ||
ff3598bc PT |
1070 | if (e->symtree->n.sym->ts.type == BT_CLASS |
1071 | && e->symtree->n.sym->attr.dummy | |
1072 | && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer) | |
1073 | return true; | |
1074 | ||
1d6b7f39 PT |
1075 | seen_array = false; |
1076 | for (ref = e->ref; ref; ref = ref->next) | |
1077 | { | |
1078 | if (ref->type == REF_ARRAY | |
1079 | && ref->u.ar.type != AR_ELEMENT) | |
1080 | seen_array = true; | |
1081 | ||
1082 | if (seen_array | |
1083 | && ref->type != REF_ARRAY) | |
1084 | return seen_array; | |
1085 | } | |
1086 | return false; | |
1087 | } | |
1088 | ||
1089 | ||
6de9cd9a DN |
1090 | /* Try to collapse intrinsic expressions. */ |
1091 | ||
524af0d6 | 1092 | static bool |
636dff67 | 1093 | simplify_intrinsic_op (gfc_expr *p, int type) |
6de9cd9a | 1094 | { |
3bed9dd0 | 1095 | gfc_intrinsic_op op; |
6de9cd9a DN |
1096 | gfc_expr *op1, *op2, *result; |
1097 | ||
a1ee985f | 1098 | if (p->value.op.op == INTRINSIC_USER) |
524af0d6 | 1099 | return true; |
6de9cd9a | 1100 | |
58b03ab2 TS |
1101 | op1 = p->value.op.op1; |
1102 | op2 = p->value.op.op2; | |
a1ee985f | 1103 | op = p->value.op.op; |
6de9cd9a | 1104 | |
524af0d6 JB |
1105 | if (!gfc_simplify_expr (op1, type)) |
1106 | return false; | |
1107 | if (!gfc_simplify_expr (op2, type)) | |
1108 | return false; | |
6de9cd9a DN |
1109 | |
1110 | if (!gfc_is_constant_expr (op1) | |
1111 | || (op2 != NULL && !gfc_is_constant_expr (op2))) | |
524af0d6 | 1112 | return true; |
6de9cd9a | 1113 | |
66e4ab31 | 1114 | /* Rip p apart. */ |
58b03ab2 TS |
1115 | p->value.op.op1 = NULL; |
1116 | p->value.op.op2 = NULL; | |
6de9cd9a | 1117 | |
3bed9dd0 | 1118 | switch (op) |
6de9cd9a | 1119 | { |
2414e1d6 | 1120 | case INTRINSIC_PARENTHESES: |
2f118814 TS |
1121 | result = gfc_parentheses (op1); |
1122 | break; | |
1123 | ||
1124 | case INTRINSIC_UPLUS: | |
6de9cd9a DN |
1125 | result = gfc_uplus (op1); |
1126 | break; | |
1127 | ||
1128 | case INTRINSIC_UMINUS: | |
1129 | result = gfc_uminus (op1); | |
1130 | break; | |
1131 | ||
1132 | case INTRINSIC_PLUS: | |
1133 | result = gfc_add (op1, op2); | |
1134 | break; | |
1135 | ||
1136 | case INTRINSIC_MINUS: | |
1137 | result = gfc_subtract (op1, op2); | |
1138 | break; | |
1139 | ||
1140 | case INTRINSIC_TIMES: | |
1141 | result = gfc_multiply (op1, op2); | |
1142 | break; | |
1143 | ||
1144 | case INTRINSIC_DIVIDE: | |
1145 | result = gfc_divide (op1, op2); | |
1146 | break; | |
1147 | ||
1148 | case INTRINSIC_POWER: | |
1149 | result = gfc_power (op1, op2); | |
1150 | break; | |
1151 | ||
1152 | case INTRINSIC_CONCAT: | |
1153 | result = gfc_concat (op1, op2); | |
1154 | break; | |
1155 | ||
1156 | case INTRINSIC_EQ: | |
3bed9dd0 DF |
1157 | case INTRINSIC_EQ_OS: |
1158 | result = gfc_eq (op1, op2, op); | |
6de9cd9a DN |
1159 | break; |
1160 | ||
1161 | case INTRINSIC_NE: | |
3bed9dd0 DF |
1162 | case INTRINSIC_NE_OS: |
1163 | result = gfc_ne (op1, op2, op); | |
6de9cd9a DN |
1164 | break; |
1165 | ||
1166 | case INTRINSIC_GT: | |
3bed9dd0 DF |
1167 | case INTRINSIC_GT_OS: |
1168 | result = gfc_gt (op1, op2, op); | |
6de9cd9a DN |
1169 | break; |
1170 | ||
1171 | case INTRINSIC_GE: | |
3bed9dd0 DF |
1172 | case INTRINSIC_GE_OS: |
1173 | result = gfc_ge (op1, op2, op); | |
6de9cd9a DN |
1174 | break; |
1175 | ||
1176 | case INTRINSIC_LT: | |
3bed9dd0 DF |
1177 | case INTRINSIC_LT_OS: |
1178 | result = gfc_lt (op1, op2, op); | |
6de9cd9a DN |
1179 | break; |
1180 | ||
1181 | case INTRINSIC_LE: | |
3bed9dd0 DF |
1182 | case INTRINSIC_LE_OS: |
1183 | result = gfc_le (op1, op2, op); | |
6de9cd9a DN |
1184 | break; |
1185 | ||
1186 | case INTRINSIC_NOT: | |
1187 | result = gfc_not (op1); | |
1188 | break; | |
1189 | ||
1190 | case INTRINSIC_AND: | |
1191 | result = gfc_and (op1, op2); | |
1192 | break; | |
1193 | ||
1194 | case INTRINSIC_OR: | |
1195 | result = gfc_or (op1, op2); | |
1196 | break; | |
1197 | ||
1198 | case INTRINSIC_EQV: | |
1199 | result = gfc_eqv (op1, op2); | |
1200 | break; | |
1201 | ||
1202 | case INTRINSIC_NEQV: | |
1203 | result = gfc_neqv (op1, op2); | |
1204 | break; | |
1205 | ||
1206 | default: | |
1207 | gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); | |
1208 | } | |
1209 | ||
1210 | if (result == NULL) | |
1211 | { | |
1212 | gfc_free_expr (op1); | |
1213 | gfc_free_expr (op2); | |
524af0d6 | 1214 | return false; |
6de9cd9a DN |
1215 | } |
1216 | ||
0e9a445b PT |
1217 | result->rank = p->rank; |
1218 | result->where = p->where; | |
6de9cd9a DN |
1219 | gfc_replace_expr (p, result); |
1220 | ||
524af0d6 | 1221 | return true; |
6de9cd9a DN |
1222 | } |
1223 | ||
1224 | ||
1225 | /* Subroutine to simplify constructor expressions. Mutually recursive | |
1226 | with gfc_simplify_expr(). */ | |
1227 | ||
524af0d6 | 1228 | static bool |
b7e75771 | 1229 | simplify_constructor (gfc_constructor_base base, int type) |
6de9cd9a | 1230 | { |
b7e75771 | 1231 | gfc_constructor *c; |
28d08315 PT |
1232 | gfc_expr *p; |
1233 | ||
b7e75771 | 1234 | for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) |
6de9cd9a DN |
1235 | { |
1236 | if (c->iterator | |
524af0d6 JB |
1237 | && (!gfc_simplify_expr(c->iterator->start, type) |
1238 | || !gfc_simplify_expr (c->iterator->end, type) | |
1239 | || !gfc_simplify_expr (c->iterator->step, type))) | |
1240 | return false; | |
6de9cd9a | 1241 | |
28d08315 PT |
1242 | if (c->expr) |
1243 | { | |
1244 | /* Try and simplify a copy. Replace the original if successful | |
1245 | but keep going through the constructor at all costs. Not | |
1246 | doing so can make a dog's dinner of complicated things. */ | |
1247 | p = gfc_copy_expr (c->expr); | |
1248 | ||
524af0d6 | 1249 | if (!gfc_simplify_expr (p, type)) |
28d08315 PT |
1250 | { |
1251 | gfc_free_expr (p); | |
1252 | continue; | |
1253 | } | |
1254 | ||
1255 | gfc_replace_expr (c->expr, p); | |
1256 | } | |
6de9cd9a DN |
1257 | } |
1258 | ||
524af0d6 | 1259 | return true; |
6de9cd9a DN |
1260 | } |
1261 | ||
1262 | ||
1263 | /* Pull a single array element out of an array constructor. */ | |
1264 | ||
524af0d6 | 1265 | static bool |
b7e75771 | 1266 | find_array_element (gfc_constructor_base base, gfc_array_ref *ar, |
636dff67 | 1267 | gfc_constructor **rval) |
6de9cd9a DN |
1268 | { |
1269 | unsigned long nelemen; | |
1270 | int i; | |
1271 | mpz_t delta; | |
1272 | mpz_t offset; | |
4c6b3ec7 PT |
1273 | mpz_t span; |
1274 | mpz_t tmp; | |
b7e75771 | 1275 | gfc_constructor *cons; |
a4a11197 | 1276 | gfc_expr *e; |
524af0d6 | 1277 | bool t; |
a4a11197 | 1278 | |
524af0d6 | 1279 | t = true; |
a4a11197 | 1280 | e = NULL; |
6de9cd9a DN |
1281 | |
1282 | mpz_init_set_ui (offset, 0); | |
1283 | mpz_init (delta); | |
4c6b3ec7 PT |
1284 | mpz_init (tmp); |
1285 | mpz_init_set_ui (span, 1); | |
6de9cd9a DN |
1286 | for (i = 0; i < ar->dimen; i++) |
1287 | { | |
524af0d6 JB |
1288 | if (!gfc_reduce_init_expr (ar->as->lower[i]) |
1289 | || !gfc_reduce_init_expr (ar->as->upper[i])) | |
138b3340 | 1290 | { |
524af0d6 | 1291 | t = false; |
138b3340 MM |
1292 | cons = NULL; |
1293 | goto depart; | |
1294 | } | |
1295 | ||
36abe895 | 1296 | e = ar->start[i]; |
a4a11197 | 1297 | if (e->expr_type != EXPR_CONSTANT) |
6de9cd9a DN |
1298 | { |
1299 | cons = NULL; | |
a4a11197 | 1300 | goto depart; |
6de9cd9a | 1301 | } |
5bcb0cc3 | 1302 | |
138b3340 MM |
1303 | gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT |
1304 | && ar->as->lower[i]->expr_type == EXPR_CONSTANT); | |
1305 | ||
5bcb0cc3 | 1306 | /* Check the bounds. */ |
0c6ce8b0 | 1307 | if ((ar->as->upper[i] |
3b35a6f8 L |
1308 | && mpz_cmp (e->value.integer, |
1309 | ar->as->upper[i]->value.integer) > 0) | |
138b3340 MM |
1310 | || (mpz_cmp (e->value.integer, |
1311 | ar->as->lower[i]->value.integer) < 0)) | |
a4a11197 | 1312 | { |
0c6ce8b0 | 1313 | gfc_error ("Index in dimension %d is out of bounds " |
a4a11197 PT |
1314 | "at %L", i + 1, &ar->c_where[i]); |
1315 | cons = NULL; | |
524af0d6 | 1316 | t = false; |
a4a11197 PT |
1317 | goto depart; |
1318 | } | |
1319 | ||
636dff67 | 1320 | mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); |
4c6b3ec7 | 1321 | mpz_mul (delta, delta, span); |
6de9cd9a | 1322 | mpz_add (offset, offset, delta); |
4c6b3ec7 PT |
1323 | |
1324 | mpz_set_ui (tmp, 1); | |
1325 | mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); | |
1326 | mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); | |
1327 | mpz_mul (span, span, tmp); | |
6de9cd9a DN |
1328 | } |
1329 | ||
b7e75771 JD |
1330 | for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); |
1331 | cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) | |
3b35a6f8 | 1332 | { |
b7e75771 | 1333 | if (cons->iterator) |
3b35a6f8 | 1334 | { |
b7e75771 JD |
1335 | cons = NULL; |
1336 | goto depart; | |
3b35a6f8 L |
1337 | } |
1338 | } | |
6de9cd9a | 1339 | |
a4a11197 | 1340 | depart: |
6de9cd9a DN |
1341 | mpz_clear (delta); |
1342 | mpz_clear (offset); | |
4c6b3ec7 PT |
1343 | mpz_clear (span); |
1344 | mpz_clear (tmp); | |
a4a11197 PT |
1345 | *rval = cons; |
1346 | return t; | |
6de9cd9a DN |
1347 | } |
1348 | ||
1349 | ||
1350 | /* Find a component of a structure constructor. */ | |
1351 | ||
1352 | static gfc_constructor * | |
b7e75771 | 1353 | find_component_ref (gfc_constructor_base base, gfc_ref *ref) |
6de9cd9a | 1354 | { |
74a1c62f | 1355 | gfc_component *pick = ref->u.c.component; |
b7e75771 | 1356 | gfc_constructor *c = gfc_constructor_first (base); |
6de9cd9a | 1357 | |
74a1c62f JW |
1358 | gfc_symbol *dt = ref->u.c.sym; |
1359 | int ext = dt->attr.extension; | |
1360 | ||
1361 | /* For extended types, check if the desired component is in one of the | |
1362 | * parent types. */ | |
1363 | while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, | |
f6288c24 | 1364 | pick->name, true, true, NULL)) |
74a1c62f JW |
1365 | { |
1366 | dt = dt->components->ts.u.derived; | |
1367 | c = gfc_constructor_first (c->expr->value.constructor); | |
1368 | ext--; | |
1369 | } | |
1370 | ||
1371 | gfc_component *comp = dt->components; | |
6de9cd9a DN |
1372 | while (comp != pick) |
1373 | { | |
1374 | comp = comp->next; | |
b7e75771 | 1375 | c = gfc_constructor_next (c); |
6de9cd9a DN |
1376 | } |
1377 | ||
b7e75771 | 1378 | return c; |
6de9cd9a DN |
1379 | } |
1380 | ||
1381 | ||
1382 | /* Replace an expression with the contents of a constructor, removing | |
1383 | the subobject reference in the process. */ | |
1384 | ||
1385 | static void | |
636dff67 | 1386 | remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) |
6de9cd9a DN |
1387 | { |
1388 | gfc_expr *e; | |
1389 | ||
ff015c5b PT |
1390 | if (cons) |
1391 | { | |
1392 | e = cons->expr; | |
1393 | cons->expr = NULL; | |
1394 | } | |
1395 | else | |
1396 | e = gfc_copy_expr (p); | |
6de9cd9a DN |
1397 | e->ref = p->ref->next; |
1398 | p->ref->next = NULL; | |
1399 | gfc_replace_expr (p, e); | |
1400 | } | |
1401 | ||
1402 | ||
a4a11197 PT |
1403 | /* Pull an array section out of an array constructor. */ |
1404 | ||
524af0d6 | 1405 | static bool |
a4a11197 PT |
1406 | find_array_section (gfc_expr *expr, gfc_ref *ref) |
1407 | { | |
1408 | int idx; | |
1409 | int rank; | |
1410 | int d; | |
abe601c7 | 1411 | int shape_i; |
b1ccc24e | 1412 | int limit; |
a4a11197 | 1413 | long unsigned one = 1; |
abe601c7 | 1414 | bool incr_ctr; |
3e978d30 | 1415 | mpz_t start[GFC_MAX_DIMENSIONS]; |
a4a11197 PT |
1416 | mpz_t end[GFC_MAX_DIMENSIONS]; |
1417 | mpz_t stride[GFC_MAX_DIMENSIONS]; | |
1418 | mpz_t delta[GFC_MAX_DIMENSIONS]; | |
1419 | mpz_t ctr[GFC_MAX_DIMENSIONS]; | |
1420 | mpz_t delta_mpz; | |
1421 | mpz_t tmp_mpz; | |
1422 | mpz_t nelts; | |
1423 | mpz_t ptr; | |
b7e75771 JD |
1424 | gfc_constructor_base base; |
1425 | gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; | |
a4a11197 PT |
1426 | gfc_expr *begin; |
1427 | gfc_expr *finish; | |
1428 | gfc_expr *step; | |
1429 | gfc_expr *upper; | |
1430 | gfc_expr *lower; | |
524af0d6 | 1431 | bool t; |
a4a11197 | 1432 | |
524af0d6 | 1433 | t = true; |
a4a11197 PT |
1434 | |
1435 | base = expr->value.constructor; | |
1436 | expr->value.constructor = NULL; | |
1437 | ||
1438 | rank = ref->u.ar.as->rank; | |
1439 | ||
1440 | if (expr->shape == NULL) | |
1441 | expr->shape = gfc_get_shape (rank); | |
1442 | ||
1443 | mpz_init_set_ui (delta_mpz, one); | |
1444 | mpz_init_set_ui (nelts, one); | |
1445 | mpz_init (tmp_mpz); | |
1446 | ||
1447 | /* Do the initialization now, so that we can cleanup without | |
1448 | keeping track of where we were. */ | |
1449 | for (d = 0; d < rank; d++) | |
1450 | { | |
1451 | mpz_init (delta[d]); | |
3e978d30 | 1452 | mpz_init (start[d]); |
a4a11197 PT |
1453 | mpz_init (end[d]); |
1454 | mpz_init (ctr[d]); | |
1455 | mpz_init (stride[d]); | |
abe601c7 | 1456 | vecsub[d] = NULL; |
a4a11197 PT |
1457 | } |
1458 | ||
1459 | /* Build the counters to clock through the array reference. */ | |
abe601c7 | 1460 | shape_i = 0; |
a4a11197 PT |
1461 | for (d = 0; d < rank; d++) |
1462 | { | |
1463 | /* Make this stretch of code easier on the eye! */ | |
1464 | begin = ref->u.ar.start[d]; | |
1465 | finish = ref->u.ar.end[d]; | |
1466 | step = ref->u.ar.stride[d]; | |
1467 | lower = ref->u.ar.as->lower[d]; | |
1468 | upper = ref->u.ar.as->upper[d]; | |
1469 | ||
abe601c7 | 1470 | if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ |
636dff67 | 1471 | { |
b7e75771 | 1472 | gfc_constructor *ci; |
636dff67 | 1473 | gcc_assert (begin); |
945a98a4 | 1474 | |
28ec36ea | 1475 | if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) |
945a98a4 | 1476 | { |
524af0d6 | 1477 | t = false; |
945a98a4 TB |
1478 | goto cleanup; |
1479 | } | |
1480 | ||
636dff67 | 1481 | gcc_assert (begin->rank == 1); |
045ac367 | 1482 | /* Zero-sized arrays have no shape and no elements, stop early. */ |
8b704316 | 1483 | if (!begin->shape) |
045ac367 DF |
1484 | { |
1485 | mpz_init_set_ui (nelts, 0); | |
1486 | break; | |
1487 | } | |
a4a11197 | 1488 | |
b7e75771 | 1489 | vecsub[d] = gfc_constructor_first (begin->value.constructor); |
abe601c7 EE |
1490 | mpz_set (ctr[d], vecsub[d]->expr->value.integer); |
1491 | mpz_mul (nelts, nelts, begin->shape[0]); | |
1492 | mpz_set (expr->shape[shape_i++], begin->shape[0]); | |
a4a11197 | 1493 | |
abe601c7 | 1494 | /* Check bounds. */ |
b7e75771 | 1495 | for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) |
abe601c7 | 1496 | { |
b7e75771 JD |
1497 | if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 |
1498 | || mpz_cmp (ci->expr->value.integer, | |
636dff67 | 1499 | lower->value.integer) < 0) |
abe601c7 EE |
1500 | { |
1501 | gfc_error ("index in dimension %d is out of bounds " | |
1502 | "at %L", d + 1, &ref->u.ar.c_where[d]); | |
524af0d6 | 1503 | t = false; |
abe601c7 EE |
1504 | goto cleanup; |
1505 | } | |
1506 | } | |
636dff67 | 1507 | } |
a4a11197 | 1508 | else |
636dff67 | 1509 | { |
abe601c7 | 1510 | if ((begin && begin->expr_type != EXPR_CONSTANT) |
636dff67 SK |
1511 | || (finish && finish->expr_type != EXPR_CONSTANT) |
1512 | || (step && step->expr_type != EXPR_CONSTANT)) | |
abe601c7 | 1513 | { |
524af0d6 | 1514 | t = false; |
abe601c7 EE |
1515 | goto cleanup; |
1516 | } | |
c71d6a56 | 1517 | |
abe601c7 EE |
1518 | /* Obtain the stride. */ |
1519 | if (step) | |
1520 | mpz_set (stride[d], step->value.integer); | |
1521 | else | |
1522 | mpz_set_ui (stride[d], one); | |
a4a11197 | 1523 | |
abe601c7 EE |
1524 | if (mpz_cmp_ui (stride[d], 0) == 0) |
1525 | mpz_set_ui (stride[d], one); | |
a4a11197 | 1526 | |
abe601c7 EE |
1527 | /* Obtain the start value for the index. */ |
1528 | if (begin) | |
1529 | mpz_set (start[d], begin->value.integer); | |
1530 | else | |
1531 | mpz_set (start[d], lower->value.integer); | |
a4a11197 | 1532 | |
abe601c7 | 1533 | mpz_set (ctr[d], start[d]); |
a4a11197 | 1534 | |
abe601c7 EE |
1535 | /* Obtain the end value for the index. */ |
1536 | if (finish) | |
1537 | mpz_set (end[d], finish->value.integer); | |
1538 | else | |
1539 | mpz_set (end[d], upper->value.integer); | |
1540 | ||
1541 | /* Separate 'if' because elements sometimes arrive with | |
1542 | non-null end. */ | |
1543 | if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) | |
1544 | mpz_set (end [d], begin->value.integer); | |
1545 | ||
1546 | /* Check the bounds. */ | |
1547 | if (mpz_cmp (ctr[d], upper->value.integer) > 0 | |
1548 | || mpz_cmp (end[d], upper->value.integer) > 0 | |
1549 | || mpz_cmp (ctr[d], lower->value.integer) < 0 | |
1550 | || mpz_cmp (end[d], lower->value.integer) < 0) | |
1551 | { | |
1552 | gfc_error ("index in dimension %d is out of bounds " | |
1553 | "at %L", d + 1, &ref->u.ar.c_where[d]); | |
524af0d6 | 1554 | t = false; |
abe601c7 EE |
1555 | goto cleanup; |
1556 | } | |
a4a11197 | 1557 | |
abe601c7 | 1558 | /* Calculate the number of elements and the shape. */ |
e1e24dc1 | 1559 | mpz_set (tmp_mpz, stride[d]); |
abe601c7 EE |
1560 | mpz_add (tmp_mpz, end[d], tmp_mpz); |
1561 | mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); | |
1562 | mpz_div (tmp_mpz, tmp_mpz, stride[d]); | |
1563 | mpz_mul (nelts, nelts, tmp_mpz); | |
1564 | ||
636dff67 SK |
1565 | /* An element reference reduces the rank of the expression; don't |
1566 | add anything to the shape array. */ | |
8b704316 | 1567 | if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) |
abe601c7 EE |
1568 | mpz_set (expr->shape[shape_i++], tmp_mpz); |
1569 | } | |
a4a11197 PT |
1570 | |
1571 | /* Calculate the 'stride' (=delta) for conversion of the | |
1572 | counter values into the index along the constructor. */ | |
1573 | mpz_set (delta[d], delta_mpz); | |
1574 | mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); | |
1575 | mpz_add_ui (tmp_mpz, tmp_mpz, one); | |
1576 | mpz_mul (delta_mpz, delta_mpz, tmp_mpz); | |
1577 | } | |
1578 | ||
a4a11197 | 1579 | mpz_init (ptr); |
b7e75771 | 1580 | cons = gfc_constructor_first (base); |
a4a11197 PT |
1581 | |
1582 | /* Now clock through the array reference, calculating the index in | |
1583 | the source constructor and transferring the elements to the new | |
328ece7d | 1584 | constructor. */ |
636dff67 | 1585 | for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) |
a4a11197 | 1586 | { |
328ece7d | 1587 | mpz_init_set_ui (ptr, 0); |
a4a11197 | 1588 | |
abe601c7 | 1589 | incr_ctr = true; |
a4a11197 PT |
1590 | for (d = 0; d < rank; d++) |
1591 | { | |
1592 | mpz_set (tmp_mpz, ctr[d]); | |
636dff67 | 1593 | mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); |
a4a11197 PT |
1594 | mpz_mul (tmp_mpz, tmp_mpz, delta[d]); |
1595 | mpz_add (ptr, ptr, tmp_mpz); | |
1596 | ||
abe601c7 | 1597 | if (!incr_ctr) continue; |
a4a11197 | 1598 | |
636dff67 | 1599 | if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ |
abe601c7 EE |
1600 | { |
1601 | gcc_assert(vecsub[d]); | |
1602 | ||
b7e75771 JD |
1603 | if (!gfc_constructor_next (vecsub[d])) |
1604 | vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); | |
abe601c7 EE |
1605 | else |
1606 | { | |
b7e75771 | 1607 | vecsub[d] = gfc_constructor_next (vecsub[d]); |
abe601c7 EE |
1608 | incr_ctr = false; |
1609 | } | |
1610 | mpz_set (ctr[d], vecsub[d]->expr->value.integer); | |
1611 | } | |
a4a11197 | 1612 | else |
abe601c7 | 1613 | { |
8b704316 | 1614 | mpz_add (ctr[d], ctr[d], stride[d]); |
abe601c7 | 1615 | |
636dff67 SK |
1616 | if (mpz_cmp_ui (stride[d], 0) > 0 |
1617 | ? mpz_cmp (ctr[d], end[d]) > 0 | |
1618 | : mpz_cmp (ctr[d], end[d]) < 0) | |
abe601c7 EE |
1619 | mpz_set (ctr[d], start[d]); |
1620 | else | |
1621 | incr_ctr = false; | |
1622 | } | |
a4a11197 PT |
1623 | } |
1624 | ||
b1ccc24e | 1625 | limit = mpz_get_ui (ptr); |
c61819ff | 1626 | if (limit >= flag_max_array_constructor) |
b1ccc24e JD |
1627 | { |
1628 | gfc_error ("The number of elements in the array constructor " | |
1629 | "at %L requires an increase of the allowed %d " | |
1630 | "upper limit. See -fmax-array-constructor " | |
c61819ff | 1631 | "option", &expr->where, flag_max_array_constructor); |
524af0d6 | 1632 | return false; |
b1ccc24e JD |
1633 | } |
1634 | ||
1635 | cons = gfc_constructor_lookup (base, limit); | |
b7e75771 JD |
1636 | gcc_assert (cons); |
1637 | gfc_constructor_append_expr (&expr->value.constructor, | |
1638 | gfc_copy_expr (cons->expr), NULL); | |
a4a11197 PT |
1639 | } |
1640 | ||
1641 | mpz_clear (ptr); | |
a4a11197 PT |
1642 | |
1643 | cleanup: | |
1644 | ||
1645 | mpz_clear (delta_mpz); | |
1646 | mpz_clear (tmp_mpz); | |
1647 | mpz_clear (nelts); | |
1648 | for (d = 0; d < rank; d++) | |
1649 | { | |
1650 | mpz_clear (delta[d]); | |
3e978d30 | 1651 | mpz_clear (start[d]); |
a4a11197 PT |
1652 | mpz_clear (end[d]); |
1653 | mpz_clear (ctr[d]); | |
1654 | mpz_clear (stride[d]); | |
1655 | } | |
b7e75771 | 1656 | gfc_constructor_free (base); |
a4a11197 PT |
1657 | return t; |
1658 | } | |
1659 | ||
1660 | /* Pull a substring out of an expression. */ | |
1661 | ||
524af0d6 | 1662 | static bool |
a4a11197 PT |
1663 | find_substring_ref (gfc_expr *p, gfc_expr **newp) |
1664 | { | |
1665 | int end; | |
1666 | int start; | |
b35c5f01 | 1667 | int length; |
00660189 | 1668 | gfc_char_t *chr; |
a4a11197 PT |
1669 | |
1670 | if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT | |
636dff67 | 1671 | || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) |
524af0d6 | 1672 | return false; |
a4a11197 PT |
1673 | |
1674 | *newp = gfc_copy_expr (p); | |
cede9502 | 1675 | free ((*newp)->value.character.string); |
b35c5f01 | 1676 | |
636dff67 SK |
1677 | end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer); |
1678 | start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer); | |
b35c5f01 | 1679 | length = end - start + 1; |
a4a11197 | 1680 | |
00660189 | 1681 | chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); |
b35c5f01 | 1682 | (*newp)->value.character.length = length; |
00660189 FXC |
1683 | memcpy (chr, &p->value.character.string[start - 1], |
1684 | length * sizeof (gfc_char_t)); | |
b35c5f01 | 1685 | chr[length] = '\0'; |
524af0d6 | 1686 | return true; |
a4a11197 PT |
1687 | } |
1688 | ||
1689 | ||
1690 | ||
6de9cd9a DN |
1691 | /* Simplify a subobject reference of a constructor. This occurs when |
1692 | parameter variable values are substituted. */ | |
1693 | ||
524af0d6 | 1694 | static bool |
636dff67 | 1695 | simplify_const_ref (gfc_expr *p) |
6de9cd9a | 1696 | { |
b7e75771 | 1697 | gfc_constructor *cons, *c; |
a4a11197 | 1698 | gfc_expr *newp; |
ff015c5b | 1699 | gfc_ref *last_ref; |
6de9cd9a DN |
1700 | |
1701 | while (p->ref) | |
1702 | { | |
1703 | switch (p->ref->type) | |
1704 | { | |
1705 | case REF_ARRAY: | |
1706 | switch (p->ref->u.ar.type) | |
1707 | { | |
1708 | case AR_ELEMENT: | |
ff015c5b PT |
1709 | /* <type/kind spec>, parameter :: x(<int>) = scalar_expr |
1710 | will generate this. */ | |
1711 | if (p->expr_type != EXPR_ARRAY) | |
1712 | { | |
1713 | remove_subobject_ref (p, NULL); | |
1714 | break; | |
1715 | } | |
524af0d6 JB |
1716 | if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) |
1717 | return false; | |
a4a11197 | 1718 | |
6de9cd9a | 1719 | if (!cons) |
524af0d6 | 1720 | return true; |
a4a11197 | 1721 | |
6de9cd9a DN |
1722 | remove_subobject_ref (p, cons); |
1723 | break; | |
1724 | ||
a4a11197 | 1725 | case AR_SECTION: |
524af0d6 JB |
1726 | if (!find_array_section (p, p->ref)) |
1727 | return false; | |
a4a11197 PT |
1728 | p->ref->u.ar.type = AR_FULL; |
1729 | ||
66e4ab31 | 1730 | /* Fall through. */ |
a4a11197 | 1731 | |
6de9cd9a | 1732 | case AR_FULL: |
a4a11197 | 1733 | if (p->ref->next != NULL |
f6288c24 | 1734 | && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type))) |
6de9cd9a | 1735 | { |
b7e75771 JD |
1736 | for (c = gfc_constructor_first (p->value.constructor); |
1737 | c; c = gfc_constructor_next (c)) | |
a4a11197 | 1738 | { |
b7e75771 | 1739 | c->expr->ref = gfc_copy_ref (p->ref->next); |
524af0d6 JB |
1740 | if (!simplify_const_ref (c->expr)) |
1741 | return false; | |
d5551618 DK |
1742 | } |
1743 | ||
f6288c24 | 1744 | if (gfc_bt_struct (p->ts.type) |
ff015c5b | 1745 | && p->ref->next |
b7e75771 | 1746 | && (c = gfc_constructor_first (p->value.constructor))) |
d5551618 | 1747 | { |
ff015c5b | 1748 | /* There may have been component references. */ |
b7e75771 | 1749 | p->ts = c->expr->ts; |
ff015c5b | 1750 | } |
d5551618 | 1751 | |
ff015c5b PT |
1752 | last_ref = p->ref; |
1753 | for (; last_ref->next; last_ref = last_ref->next) {}; | |
d5551618 | 1754 | |
ff015c5b PT |
1755 | if (p->ts.type == BT_CHARACTER |
1756 | && last_ref->type == REF_SUBSTRING) | |
1757 | { | |
1758 | /* If this is a CHARACTER array and we possibly took | |
1759 | a substring out of it, update the type-spec's | |
1760 | character length according to the first element | |
1761 | (as all should have the same length). */ | |
f622221a | 1762 | gfc_charlen_t string_len; |
b7e75771 | 1763 | if ((c = gfc_constructor_first (p->value.constructor))) |
d5551618 | 1764 | { |
b7e75771 | 1765 | const gfc_expr* first = c->expr; |
d5551618 DK |
1766 | gcc_assert (first->expr_type == EXPR_CONSTANT); |
1767 | gcc_assert (first->ts.type == BT_CHARACTER); | |
1768 | string_len = first->value.character.length; | |
1769 | } | |
1770 | else | |
1771 | string_len = 0; | |
1772 | ||
bc21d315 | 1773 | if (!p->ts.u.cl) |
b76e28c6 JW |
1774 | p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, |
1775 | NULL); | |
1776 | else | |
1777 | gfc_free_expr (p->ts.u.cl->length); | |
1778 | ||
b7e75771 | 1779 | p->ts.u.cl->length |
f622221a | 1780 | = gfc_get_int_expr (gfc_charlen_int_kind, |
b7e75771 | 1781 | NULL, string_len); |
a4a11197 | 1782 | } |
6de9cd9a | 1783 | } |
a4a11197 PT |
1784 | gfc_free_ref_list (p->ref); |
1785 | p->ref = NULL; | |
6de9cd9a DN |
1786 | break; |
1787 | ||
1788 | default: | |
524af0d6 | 1789 | return true; |
6de9cd9a DN |
1790 | } |
1791 | ||
1792 | break; | |
1793 | ||
1794 | case REF_COMPONENT: | |
1795 | cons = find_component_ref (p->value.constructor, p->ref); | |
1796 | remove_subobject_ref (p, cons); | |
1797 | break; | |
1798 | ||
1799 | case REF_SUBSTRING: | |
524af0d6 JB |
1800 | if (!find_substring_ref (p, &newp)) |
1801 | return false; | |
a4a11197 PT |
1802 | |
1803 | gfc_replace_expr (p, newp); | |
1804 | gfc_free_ref_list (p->ref); | |
1805 | p->ref = NULL; | |
1806 | break; | |
6de9cd9a DN |
1807 | } |
1808 | } | |
1809 | ||
524af0d6 | 1810 | return true; |
6de9cd9a DN |
1811 | } |
1812 | ||
1813 | ||
1814 | /* Simplify a chain of references. */ | |
1815 | ||
524af0d6 | 1816 | static bool |
636dff67 | 1817 | simplify_ref_chain (gfc_ref *ref, int type) |
6de9cd9a DN |
1818 | { |
1819 | int n; | |
1820 | ||
1821 | for (; ref; ref = ref->next) | |
1822 | { | |
1823 | switch (ref->type) | |
1824 | { | |
1825 | case REF_ARRAY: | |
1826 | for (n = 0; n < ref->u.ar.dimen; n++) | |
1827 | { | |
524af0d6 JB |
1828 | if (!gfc_simplify_expr (ref->u.ar.start[n], type)) |
1829 | return false; | |
1830 | if (!gfc_simplify_expr (ref->u.ar.end[n], type)) | |
1831 | return false; | |
1832 | if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) | |
1833 | return false; | |
6de9cd9a DN |
1834 | } |
1835 | break; | |
1836 | ||
1837 | case REF_SUBSTRING: | |
524af0d6 JB |
1838 | if (!gfc_simplify_expr (ref->u.ss.start, type)) |
1839 | return false; | |
1840 | if (!gfc_simplify_expr (ref->u.ss.end, type)) | |
1841 | return false; | |
6de9cd9a DN |
1842 | break; |
1843 | ||
1844 | default: | |
1845 | break; | |
1846 | } | |
1847 | } | |
524af0d6 | 1848 | return true; |
6de9cd9a DN |
1849 | } |
1850 | ||
1851 | ||
1852 | /* Try to substitute the value of a parameter variable. */ | |
66e4ab31 | 1853 | |
524af0d6 | 1854 | static bool |
636dff67 | 1855 | simplify_parameter_variable (gfc_expr *p, int type) |
6de9cd9a DN |
1856 | { |
1857 | gfc_expr *e; | |
524af0d6 | 1858 | bool t; |
6de9cd9a DN |
1859 | |
1860 | e = gfc_copy_expr (p->symtree->n.sym->value); | |
a4a11197 | 1861 | if (e == NULL) |
524af0d6 | 1862 | return false; |
a4a11197 | 1863 | |
b9703d98 EE |
1864 | e->rank = p->rank; |
1865 | ||
c2fee3de DE |
1866 | /* Do not copy subobject refs for constant. */ |
1867 | if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) | |
8e1f752a | 1868 | e->ref = gfc_copy_ref (p->ref); |
6de9cd9a DN |
1869 | t = gfc_simplify_expr (e, type); |
1870 | ||
66e4ab31 | 1871 | /* Only use the simplification if it eliminated all subobject references. */ |
524af0d6 | 1872 | if (t && !e->ref) |
6de9cd9a DN |
1873 | gfc_replace_expr (p, e); |
1874 | else | |
1875 | gfc_free_expr (e); | |
1876 | ||
1877 | return t; | |
1878 | } | |
1879 | ||
1880 | /* Given an expression, simplify it by collapsing constant | |
1881 | expressions. Most simplification takes place when the expression | |
1882 | tree is being constructed. If an intrinsic function is simplified | |
1883 | at some point, we get called again to collapse the result against | |
1884 | other constants. | |
1885 | ||
1886 | We work by recursively simplifying expression nodes, simplifying | |
1887 | intrinsic functions where possible, which can lead to further | |
1888 | constant collapsing. If an operator has constant operand(s), we | |
1889 | rip the expression apart, and rebuild it, hoping that it becomes | |
1890 | something simpler. | |
1891 | ||
1892 | The expression type is defined for: | |
1893 | 0 Basic expression parsing | |
1894 | 1 Simplifying array constructors -- will substitute | |
636dff67 | 1895 | iterator values. |
524af0d6 JB |
1896 | Returns false on error, true otherwise. |
1897 | NOTE: Will return true even if the expression can not be simplified. */ | |
6de9cd9a | 1898 | |
524af0d6 | 1899 | bool |
636dff67 | 1900 | gfc_simplify_expr (gfc_expr *p, int type) |
6de9cd9a DN |
1901 | { |
1902 | gfc_actual_arglist *ap; | |
1903 | ||
1904 | if (p == NULL) | |
524af0d6 | 1905 | return true; |
6de9cd9a DN |
1906 | |
1907 | switch (p->expr_type) | |
1908 | { | |
1909 | case EXPR_CONSTANT: | |
1910 | case EXPR_NULL: | |
1911 | break; | |
1912 | ||
1913 | case EXPR_FUNCTION: | |
1914 | for (ap = p->value.function.actual; ap; ap = ap->next) | |
524af0d6 JB |
1915 | if (!gfc_simplify_expr (ap->expr, type)) |
1916 | return false; | |
6de9cd9a DN |
1917 | |
1918 | if (p->value.function.isym != NULL | |
1919 | && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) | |
524af0d6 | 1920 | return false; |
6de9cd9a DN |
1921 | |
1922 | break; | |
1923 | ||
1924 | case EXPR_SUBSTRING: | |
524af0d6 JB |
1925 | if (!simplify_ref_chain (p->ref, type)) |
1926 | return false; | |
6de9cd9a | 1927 | |
c2fee3de DE |
1928 | if (gfc_is_constant_expr (p)) |
1929 | { | |
00660189 | 1930 | gfc_char_t *s; |
f622221a | 1931 | HOST_WIDE_INT start, end; |
c2fee3de | 1932 | |
e8d4f3fc | 1933 | start = 0; |
9a251aa1 FXC |
1934 | if (p->ref && p->ref->u.ss.start) |
1935 | { | |
f622221a | 1936 | gfc_extract_hwi (p->ref->u.ss.start, &start); |
9a251aa1 FXC |
1937 | start--; /* Convert from one-based to zero-based. */ |
1938 | } | |
9a251aa1 | 1939 | |
e8d4f3fc | 1940 | end = p->value.character.length; |
9a251aa1 | 1941 | if (p->ref && p->ref->u.ss.end) |
f622221a | 1942 | gfc_extract_hwi (p->ref->u.ss.end, &end); |
9a251aa1 | 1943 | |
b8bc0ff7 FXC |
1944 | if (end < start) |
1945 | end = start; | |
7d0300ed | 1946 | |
00660189 FXC |
1947 | s = gfc_get_wide_string (end - start + 2); |
1948 | memcpy (s, p->value.character.string + start, | |
1949 | (end - start) * sizeof (gfc_char_t)); | |
636dff67 | 1950 | s[end - start + 1] = '\0'; /* TODO: C-style string. */ |
cede9502 | 1951 | free (p->value.character.string); |
c2fee3de DE |
1952 | p->value.character.string = s; |
1953 | p->value.character.length = end - start; | |
b76e28c6 | 1954 | p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); |
f622221a | 1955 | p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, |
b7e75771 JD |
1956 | NULL, |
1957 | p->value.character.length); | |
c2fee3de DE |
1958 | gfc_free_ref_list (p->ref); |
1959 | p->ref = NULL; | |
1960 | p->expr_type = EXPR_CONSTANT; | |
1961 | } | |
6de9cd9a DN |
1962 | break; |
1963 | ||
1964 | case EXPR_OP: | |
524af0d6 JB |
1965 | if (!simplify_intrinsic_op (p, type)) |
1966 | return false; | |
6de9cd9a DN |
1967 | break; |
1968 | ||
1969 | case EXPR_VARIABLE: | |
1970 | /* Only substitute array parameter variables if we are in an | |
636dff67 | 1971 | initialization expression, or we want a subsection. */ |
6de9cd9a | 1972 | if (p->symtree->n.sym->attr.flavor == FL_PARAMETER |
f2cbd86c | 1973 | && (gfc_init_expr_flag || p->ref |
22c30bc0 | 1974 | || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) |
6de9cd9a | 1975 | { |
524af0d6 JB |
1976 | if (!simplify_parameter_variable (p, type)) |
1977 | return false; | |
6de9cd9a DN |
1978 | break; |
1979 | } | |
1980 | ||
1981 | if (type == 1) | |
1982 | { | |
1983 | gfc_simplify_iterator_var (p); | |
1984 | } | |
1985 | ||
1986 | /* Simplify subcomponent references. */ | |
524af0d6 JB |
1987 | if (!simplify_ref_chain (p->ref, type)) |
1988 | return false; | |
6de9cd9a DN |
1989 | |
1990 | break; | |
1991 | ||
1992 | case EXPR_STRUCTURE: | |
1993 | case EXPR_ARRAY: | |
524af0d6 JB |
1994 | if (!simplify_ref_chain (p->ref, type)) |
1995 | return false; | |
6de9cd9a | 1996 | |
524af0d6 JB |
1997 | if (!simplify_constructor (p->value.constructor, type)) |
1998 | return false; | |
6de9cd9a | 1999 | |
636dff67 SK |
2000 | if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY |
2001 | && p->ref->u.ar.type == AR_FULL) | |
928f0490 | 2002 | gfc_expand_constructor (p, false); |
6de9cd9a | 2003 | |
524af0d6 JB |
2004 | if (!simplify_const_ref (p)) |
2005 | return false; | |
6de9cd9a DN |
2006 | |
2007 | break; | |
8e1f752a DK |
2008 | |
2009 | case EXPR_COMPCALL: | |
713485cc | 2010 | case EXPR_PPC: |
8e1f752a | 2011 | break; |
6de9cd9a DN |
2012 | } |
2013 | ||
524af0d6 | 2014 | return true; |
6de9cd9a DN |
2015 | } |
2016 | ||
2017 | ||
2018 | /* Returns the type of an expression with the exception that iterator | |
2019 | variables are automatically integers no matter what else they may | |
2020 | be declared as. */ | |
2021 | ||
2022 | static bt | |
636dff67 | 2023 | et0 (gfc_expr *e) |
6de9cd9a | 2024 | { |
524af0d6 | 2025 | if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) |
6de9cd9a DN |
2026 | return BT_INTEGER; |
2027 | ||
2028 | return e->ts.type; | |
2029 | } | |
2030 | ||
2031 | ||
396b2c19 PT |
2032 | /* Scalarize an expression for an elemental intrinsic call. */ |
2033 | ||
524af0d6 | 2034 | static bool |
396b2c19 PT |
2035 | scalarize_intrinsic_call (gfc_expr *e) |
2036 | { | |
2037 | gfc_actual_arglist *a, *b; | |
b7e75771 | 2038 | gfc_constructor_base ctor; |
3995f3a2 | 2039 | gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */ |
b7e75771 | 2040 | gfc_constructor *ci, *new_ctor; |
396b2c19 | 2041 | gfc_expr *expr, *old; |
679d9637 | 2042 | int n, i, rank[5], array_arg; |
8b704316 | 2043 | |
679d9637 PT |
2044 | /* Find which, if any, arguments are arrays. Assume that the old |
2045 | expression carries the type information and that the first arg | |
2046 | that is an array expression carries all the shape information.*/ | |
2047 | n = array_arg = 0; | |
05e6ff80 | 2048 | a = e->value.function.actual; |
679d9637 PT |
2049 | for (; a; a = a->next) |
2050 | { | |
2051 | n++; | |
c8d599e1 | 2052 | if (!a->expr || a->expr->expr_type != EXPR_ARRAY) |
679d9637 PT |
2053 | continue; |
2054 | array_arg = n; | |
2055 | expr = gfc_copy_expr (a->expr); | |
2056 | break; | |
2057 | } | |
2058 | ||
2059 | if (!array_arg) | |
524af0d6 | 2060 | return false; |
05e6ff80 PT |
2061 | |
2062 | old = gfc_copy_expr (e); | |
679d9637 | 2063 | |
b7e75771 | 2064 | gfc_constructor_free (expr->value.constructor); |
396b2c19 | 2065 | expr->value.constructor = NULL; |
396b2c19 | 2066 | expr->ts = old->ts; |
679d9637 | 2067 | expr->where = old->where; |
396b2c19 PT |
2068 | expr->expr_type = EXPR_ARRAY; |
2069 | ||
2070 | /* Copy the array argument constructors into an array, with nulls | |
2071 | for the scalars. */ | |
2072 | n = 0; | |
2073 | a = old->value.function.actual; | |
2074 | for (; a; a = a->next) | |
2075 | { | |
2076 | /* Check that this is OK for an initialization expression. */ | |
524af0d6 | 2077 | if (a->expr && !gfc_check_init_expr (a->expr)) |
396b2c19 PT |
2078 | goto cleanup; |
2079 | ||
2080 | rank[n] = 0; | |
2081 | if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) | |
2082 | { | |
2083 | rank[n] = a->expr->rank; | |
2084 | ctor = a->expr->symtree->n.sym->value->value.constructor; | |
b7e75771 | 2085 | args[n] = gfc_constructor_first (ctor); |
396b2c19 PT |
2086 | } |
2087 | else if (a->expr && a->expr->expr_type == EXPR_ARRAY) | |
2088 | { | |
2089 | if (a->expr->rank) | |
2090 | rank[n] = a->expr->rank; | |
2091 | else | |
2092 | rank[n] = 1; | |
b7e75771 JD |
2093 | ctor = gfc_constructor_copy (a->expr->value.constructor); |
2094 | args[n] = gfc_constructor_first (ctor); | |
396b2c19 PT |
2095 | } |
2096 | else | |
2097 | args[n] = NULL; | |
b7e75771 | 2098 | |
396b2c19 PT |
2099 | n++; |
2100 | } | |
2101 | ||
396b2c19 | 2102 | |
05e6ff80 | 2103 | /* Using the array argument as the master, step through the array |
396b2c19 PT |
2104 | calling the function for each element and advancing the array |
2105 | constructors together. */ | |
b7e75771 | 2106 | for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) |
396b2c19 | 2107 | { |
b7e75771 JD |
2108 | new_ctor = gfc_constructor_append_expr (&expr->value.constructor, |
2109 | gfc_copy_expr (old), NULL); | |
2110 | ||
2111 | gfc_free_actual_arglist (new_ctor->expr->value.function.actual); | |
2112 | a = NULL; | |
2113 | b = old->value.function.actual; | |
2114 | for (i = 0; i < n; i++) | |
2115 | { | |
2116 | if (a == NULL) | |
2117 | new_ctor->expr->value.function.actual | |
2118 | = a = gfc_get_actual_arglist (); | |
396b2c19 PT |
2119 | else |
2120 | { | |
b7e75771 JD |
2121 | a->next = gfc_get_actual_arglist (); |
2122 | a = a->next; | |
396b2c19 | 2123 | } |
396b2c19 | 2124 | |
b7e75771 JD |
2125 | if (args[i]) |
2126 | a->expr = gfc_copy_expr (args[i]->expr); | |
2127 | else | |
2128 | a->expr = gfc_copy_expr (b->expr); | |
2129 | ||
2130 | b = b->next; | |
2131 | } | |
396b2c19 | 2132 | |
b7e75771 JD |
2133 | /* Simplify the function calls. If the simplification fails, the |
2134 | error will be flagged up down-stream or the library will deal | |
2135 | with it. */ | |
2136 | gfc_simplify_expr (new_ctor->expr, 0); | |
396b2c19 | 2137 | |
b7e75771 JD |
2138 | for (i = 0; i < n; i++) |
2139 | if (args[i]) | |
2140 | args[i] = gfc_constructor_next (args[i]); | |
396b2c19 | 2141 | |
b7e75771 JD |
2142 | for (i = 1; i < n; i++) |
2143 | if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) | |
2144 | || (args[i] == NULL && args[array_arg - 1] != NULL))) | |
2145 | goto compliance; | |
396b2c19 PT |
2146 | } |
2147 | ||
2148 | free_expr0 (e); | |
2149 | *e = *expr; | |
efb63364 TB |
2150 | /* Free "expr" but not the pointers it contains. */ |
2151 | free (expr); | |
396b2c19 | 2152 | gfc_free_expr (old); |
524af0d6 | 2153 | return true; |
396b2c19 PT |
2154 | |
2155 | compliance: | |
2156 | gfc_error_now ("elemental function arguments at %C are not compliant"); | |
2157 | ||
2158 | cleanup: | |
2159 | gfc_free_expr (expr); | |
2160 | gfc_free_expr (old); | |
524af0d6 | 2161 | return false; |
396b2c19 PT |
2162 | } |
2163 | ||
2164 | ||
524af0d6 JB |
2165 | static bool |
2166 | check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) | |
6de9cd9a | 2167 | { |
58b03ab2 TS |
2168 | gfc_expr *op1 = e->value.op.op1; |
2169 | gfc_expr *op2 = e->value.op.op2; | |
6de9cd9a | 2170 | |
524af0d6 JB |
2171 | if (!(*check_function)(op1)) |
2172 | return false; | |
6de9cd9a | 2173 | |
a1ee985f | 2174 | switch (e->value.op.op) |
6de9cd9a DN |
2175 | { |
2176 | case INTRINSIC_UPLUS: | |
2177 | case INTRINSIC_UMINUS: | |
58b03ab2 | 2178 | if (!numeric_type (et0 (op1))) |
6de9cd9a DN |
2179 | goto not_numeric; |
2180 | break; | |
2181 | ||
2182 | case INTRINSIC_EQ: | |
3bed9dd0 | 2183 | case INTRINSIC_EQ_OS: |
6de9cd9a | 2184 | case INTRINSIC_NE: |
3bed9dd0 | 2185 | case INTRINSIC_NE_OS: |
6de9cd9a | 2186 | case INTRINSIC_GT: |
3bed9dd0 | 2187 | case INTRINSIC_GT_OS: |
6de9cd9a | 2188 | case INTRINSIC_GE: |
3bed9dd0 | 2189 | case INTRINSIC_GE_OS: |
6de9cd9a | 2190 | case INTRINSIC_LT: |
3bed9dd0 | 2191 | case INTRINSIC_LT_OS: |
6de9cd9a | 2192 | case INTRINSIC_LE: |
3bed9dd0 | 2193 | case INTRINSIC_LE_OS: |
524af0d6 JB |
2194 | if (!(*check_function)(op2)) |
2195 | return false; | |
8b704316 | 2196 | |
58b03ab2 TS |
2197 | if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) |
2198 | && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) | |
e063a048 TS |
2199 | { |
2200 | gfc_error ("Numeric or CHARACTER operands are required in " | |
2201 | "expression at %L", &e->where); | |
524af0d6 | 2202 | return false; |
e063a048 TS |
2203 | } |
2204 | break; | |
6de9cd9a DN |
2205 | |
2206 | case INTRINSIC_PLUS: | |
2207 | case INTRINSIC_MINUS: | |
2208 | case INTRINSIC_TIMES: | |
2209 | case INTRINSIC_DIVIDE: | |
2210 | case INTRINSIC_POWER: | |
524af0d6 JB |
2211 | if (!(*check_function)(op2)) |
2212 | return false; | |
6de9cd9a | 2213 | |
58b03ab2 | 2214 | if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) |
6de9cd9a DN |
2215 | goto not_numeric; |
2216 | ||
6de9cd9a DN |
2217 | break; |
2218 | ||
2219 | case INTRINSIC_CONCAT: | |
524af0d6 JB |
2220 | if (!(*check_function)(op2)) |
2221 | return false; | |
6de9cd9a | 2222 | |
58b03ab2 | 2223 | if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) |
6de9cd9a DN |
2224 | { |
2225 | gfc_error ("Concatenation operator in expression at %L " | |
58b03ab2 | 2226 | "must have two CHARACTER operands", &op1->where); |
524af0d6 | 2227 | return false; |
6de9cd9a DN |
2228 | } |
2229 | ||
58b03ab2 | 2230 | if (op1->ts.kind != op2->ts.kind) |
6de9cd9a DN |
2231 | { |
2232 | gfc_error ("Concat operator at %L must concatenate strings of the " | |
2233 | "same kind", &e->where); | |
524af0d6 | 2234 | return false; |
6de9cd9a DN |
2235 | } |
2236 | ||
2237 | break; | |
2238 | ||
2239 | case INTRINSIC_NOT: | |
58b03ab2 | 2240 | if (et0 (op1) != BT_LOGICAL) |
6de9cd9a DN |
2241 | { |
2242 | gfc_error (".NOT. operator in expression at %L must have a LOGICAL " | |
58b03ab2 | 2243 | "operand", &op1->where); |
524af0d6 | 2244 | return false; |
6de9cd9a DN |
2245 | } |
2246 | ||
2247 | break; | |
2248 | ||
2249 | case INTRINSIC_AND: | |
2250 | case INTRINSIC_OR: | |
2251 | case INTRINSIC_EQV: | |
2252 | case INTRINSIC_NEQV: | |
524af0d6 JB |
2253 | if (!(*check_function)(op2)) |
2254 | return false; | |
6de9cd9a | 2255 | |
58b03ab2 | 2256 | if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) |
6de9cd9a DN |
2257 | { |
2258 | gfc_error ("LOGICAL operands are required in expression at %L", | |
2259 | &e->where); | |
524af0d6 | 2260 | return false; |
6de9cd9a DN |
2261 | } |
2262 | ||
2263 | break; | |
2264 | ||
083cc293 TS |
2265 | case INTRINSIC_PARENTHESES: |
2266 | break; | |
2267 | ||
6de9cd9a DN |
2268 | default: |
2269 | gfc_error ("Only intrinsic operators can be used in expression at %L", | |
2270 | &e->where); | |
524af0d6 | 2271 | return false; |
6de9cd9a DN |
2272 | } |
2273 | ||
524af0d6 | 2274 | return true; |
6de9cd9a DN |
2275 | |
2276 | not_numeric: | |
2277 | gfc_error ("Numeric operands are required in expression at %L", &e->where); | |
2278 | ||
524af0d6 | 2279 | return false; |
6de9cd9a DN |
2280 | } |
2281 | ||
604df116 DF |
2282 | /* F2003, 7.1.7 (3): In init expression, allocatable components |
2283 | must not be data-initialized. */ | |
524af0d6 | 2284 | static bool |
604df116 DF |
2285 | check_alloc_comp_init (gfc_expr *e) |
2286 | { | |
b7e75771 | 2287 | gfc_component *comp; |
604df116 DF |
2288 | gfc_constructor *ctor; |
2289 | ||
2290 | gcc_assert (e->expr_type == EXPR_STRUCTURE); | |
103c4f75 | 2291 | gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS); |
604df116 | 2292 | |
b7e75771 JD |
2293 | for (comp = e->ts.u.derived->components, |
2294 | ctor = gfc_constructor_first (e->value.constructor); | |
2295 | comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) | |
604df116 | 2296 | { |
7430df97 | 2297 | if (comp->attr.allocatable && ctor->expr |
604df116 DF |
2298 | && ctor->expr->expr_type != EXPR_NULL) |
2299 | { | |
c4100eae MLI |
2300 | gfc_error ("Invalid initialization expression for ALLOCATABLE " |
2301 | "component %qs in structure constructor at %L", | |
2302 | comp->name, &ctor->expr->where); | |
524af0d6 | 2303 | return false; |
604df116 DF |
2304 | } |
2305 | } | |
2306 | ||
524af0d6 | 2307 | return true; |
604df116 | 2308 | } |
6de9cd9a | 2309 | |
e1633d82 DF |
2310 | static match |
2311 | check_init_expr_arguments (gfc_expr *e) | |
2312 | { | |
2313 | gfc_actual_arglist *ap; | |
6de9cd9a | 2314 | |
e1633d82 | 2315 | for (ap = e->value.function.actual; ap; ap = ap->next) |
524af0d6 | 2316 | if (!gfc_check_init_expr (ap->expr)) |
e1633d82 | 2317 | return MATCH_ERROR; |
6de9cd9a | 2318 | |
e1633d82 DF |
2319 | return MATCH_YES; |
2320 | } | |
2321 | ||
524af0d6 | 2322 | static bool check_restricted (gfc_expr *); |
ebb479cd | 2323 | |
e1633d82 DF |
2324 | /* F95, 7.1.6.1, Initialization expressions, (7) |
2325 | F2003, 7.1.7 Initialization expression, (8) */ | |
2326 | ||
2327 | static match | |
636dff67 | 2328 | check_inquiry (gfc_expr *e, int not_restricted) |
6de9cd9a DN |
2329 | { |
2330 | const char *name; | |
e1633d82 DF |
2331 | const char *const *functions; |
2332 | ||
2333 | static const char *const inquiry_func_f95[] = { | |
2334 | "lbound", "shape", "size", "ubound", | |
2335 | "bit_size", "len", "kind", | |
2336 | "digits", "epsilon", "huge", "maxexponent", "minexponent", | |
2337 | "precision", "radix", "range", "tiny", | |
2338 | NULL | |
2339 | }; | |
6de9cd9a | 2340 | |
e1633d82 DF |
2341 | static const char *const inquiry_func_f2003[] = { |
2342 | "lbound", "shape", "size", "ubound", | |
2343 | "bit_size", "len", "kind", | |
2344 | "digits", "epsilon", "huge", "maxexponent", "minexponent", | |
2345 | "precision", "radix", "range", "tiny", | |
2346 | "new_line", NULL | |
6de9cd9a DN |
2347 | }; |
2348 | ||
cadddfdd | 2349 | int i = 0; |
e1633d82 DF |
2350 | gfc_actual_arglist *ap; |
2351 | ||
2352 | if (!e->value.function.isym | |
2353 | || !e->value.function.isym->inquiry) | |
2354 | return MATCH_NO; | |
6de9cd9a | 2355 | |
e7f79e12 PT |
2356 | /* An undeclared parameter will get us here (PR25018). */ |
2357 | if (e->symtree == NULL) | |
e1633d82 | 2358 | return MATCH_NO; |
e7f79e12 | 2359 | |
cadddfdd TB |
2360 | if (e->symtree->n.sym->from_intmod) |
2361 | { | |
2362 | if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV | |
2363 | && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS | |
2364 | && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) | |
2365 | return MATCH_NO; | |
6de9cd9a | 2366 | |
cadddfdd TB |
2367 | if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING |
2368 | && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) | |
2369 | return MATCH_NO; | |
2370 | } | |
2371 | else | |
2372 | { | |
2373 | name = e->symtree->n.sym->name; | |
2374 | ||
2375 | functions = (gfc_option.warn_std & GFC_STD_F2003) | |
e1633d82 | 2376 | ? inquiry_func_f2003 : inquiry_func_f95; |
6de9cd9a | 2377 | |
cadddfdd TB |
2378 | for (i = 0; functions[i]; i++) |
2379 | if (strcmp (functions[i], name) == 0) | |
2380 | break; | |
6de9cd9a | 2381 | |
21c0a521 DM |
2382 | if (functions[i] == NULL) |
2383 | return MATCH_ERROR; | |
cadddfdd | 2384 | } |
6de9cd9a | 2385 | |
c2b27658 EE |
2386 | /* At this point we have an inquiry function with a variable argument. The |
2387 | type of the variable might be undefined, but we need it now, because the | |
e1633d82 | 2388 | arguments of these functions are not allowed to be undefined. */ |
6de9cd9a | 2389 | |
e1633d82 | 2390 | for (ap = e->value.function.actual; ap; ap = ap->next) |
6de9cd9a | 2391 | { |
e1633d82 DF |
2392 | if (!ap->expr) |
2393 | continue; | |
2394 | ||
2395 | if (ap->expr->ts.type == BT_UNKNOWN) | |
2396 | { | |
2397 | if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN | |
524af0d6 | 2398 | && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)) |
e1633d82 | 2399 | return MATCH_NO; |
6de9cd9a | 2400 | |
e1633d82 DF |
2401 | ap->expr->ts = ap->expr->symtree->n.sym->ts; |
2402 | } | |
2403 | ||
2404 | /* Assumed character length will not reduce to a constant expression | |
2405 | with LEN, as required by the standard. */ | |
2406 | if (i == 5 && not_restricted | |
2407 | && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER | |
e69afb29 SK |
2408 | && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL |
2409 | || ap->expr->symtree->n.sym->ts.deferred)) | |
e1633d82 | 2410 | { |
c4100eae | 2411 | gfc_error ("Assumed or deferred character length variable %qs " |
2f029c08 | 2412 | "in constant expression at %L", |
e69afb29 SK |
2413 | ap->expr->symtree->n.sym->name, |
2414 | &ap->expr->where); | |
e1633d82 DF |
2415 | return MATCH_ERROR; |
2416 | } | |
524af0d6 | 2417 | else if (not_restricted && !gfc_check_init_expr (ap->expr)) |
e1633d82 | 2418 | return MATCH_ERROR; |
ebb479cd PT |
2419 | |
2420 | if (not_restricted == 0 | |
2421 | && ap->expr->expr_type != EXPR_VARIABLE | |
524af0d6 | 2422 | && !check_restricted (ap->expr)) |
ebb479cd | 2423 | return MATCH_ERROR; |
26865ab4 SK |
2424 | |
2425 | if (not_restricted == 0 | |
2426 | && ap->expr->expr_type == EXPR_VARIABLE | |
2427 | && ap->expr->symtree->n.sym->attr.dummy | |
2428 | && ap->expr->symtree->n.sym->attr.optional) | |
2429 | return MATCH_NO; | |
6de9cd9a DN |
2430 | } |
2431 | ||
e1633d82 DF |
2432 | return MATCH_YES; |
2433 | } | |
2434 | ||
e7f79e12 | 2435 | |
e1633d82 DF |
2436 | /* F95, 7.1.6.1, Initialization expressions, (5) |
2437 | F2003, 7.1.7 Initialization expression, (5) */ | |
2438 | ||
2439 | static match | |
2440 | check_transformational (gfc_expr *e) | |
2441 | { | |
2442 | static const char * const trans_func_f95[] = { | |
2443 | "repeat", "reshape", "selected_int_kind", | |
2444 | "selected_real_kind", "transfer", "trim", NULL | |
2445 | }; | |
2446 | ||
8ec259c1 | 2447 | static const char * const trans_func_f2003[] = { |
a16d978f DF |
2448 | "all", "any", "count", "dot_product", "matmul", "null", "pack", |
2449 | "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", | |
c430a6f9 DF |
2450 | "selected_real_kind", "spread", "sum", "transfer", "transpose", |
2451 | "trim", "unpack", NULL | |
8ec259c1 DF |
2452 | }; |
2453 | ||
e1633d82 DF |
2454 | int i; |
2455 | const char *name; | |
8ec259c1 | 2456 | const char *const *functions; |
e1633d82 DF |
2457 | |
2458 | if (!e->value.function.isym | |
2459 | || !e->value.function.isym->transformational) | |
2460 | return MATCH_NO; | |
2461 | ||
2462 | name = e->symtree->n.sym->name; | |
2463 | ||
8b704316 | 2464 | functions = (gfc_option.allow_std & GFC_STD_F2003) |
8ec259c1 DF |
2465 | ? trans_func_f2003 : trans_func_f95; |
2466 | ||
e1633d82 DF |
2467 | /* NULL() is dealt with below. */ |
2468 | if (strcmp ("null", name) == 0) | |
2469 | return MATCH_NO; | |
2470 | ||
8ec259c1 DF |
2471 | for (i = 0; functions[i]; i++) |
2472 | if (strcmp (functions[i], name) == 0) | |
2473 | break; | |
e1633d82 | 2474 | |
8ec259c1 | 2475 | if (functions[i] == NULL) |
5ab0eadf | 2476 | { |
c4100eae MLI |
2477 | gfc_error ("transformational intrinsic %qs at %L is not permitted " |
2478 | "in an initialization expression", name, &e->where); | |
5ab0eadf DF |
2479 | return MATCH_ERROR; |
2480 | } | |
e1633d82 DF |
2481 | |
2482 | return check_init_expr_arguments (e); | |
2483 | } | |
2484 | ||
2485 | ||
2486 | /* F95, 7.1.6.1, Initialization expressions, (6) | |
2487 | F2003, 7.1.7 Initialization expression, (6) */ | |
2488 | ||
2489 | static match | |
2490 | check_null (gfc_expr *e) | |
2491 | { | |
2492 | if (strcmp ("null", e->symtree->n.sym->name) != 0) | |
2493 | return MATCH_NO; | |
2494 | ||
2495 | return check_init_expr_arguments (e); | |
2496 | } | |
2497 | ||
2498 | ||
2499 | static match | |
2500 | check_elemental (gfc_expr *e) | |
2501 | { | |
2502 | if (!e->value.function.isym | |
2503 | || !e->value.function.isym->elemental) | |
2504 | return MATCH_NO; | |
2505 | ||
c2916401 DF |
2506 | if (e->ts.type != BT_INTEGER |
2507 | && e->ts.type != BT_CHARACTER | |
524af0d6 JB |
2508 | && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " |
2509 | "initialization expression at %L", &e->where)) | |
e1633d82 DF |
2510 | return MATCH_ERROR; |
2511 | ||
2512 | return check_init_expr_arguments (e); | |
2513 | } | |
2514 | ||
2515 | ||
2516 | static match | |
2517 | check_conversion (gfc_expr *e) | |
2518 | { | |
2519 | if (!e->value.function.isym | |
2520 | || !e->value.function.isym->conversion) | |
2521 | return MATCH_NO; | |
2522 | ||
2523 | return check_init_expr_arguments (e); | |
6de9cd9a DN |
2524 | } |
2525 | ||
2526 | ||
2527 | /* Verify that an expression is an initialization expression. A side | |
2528 | effect is that the expression tree is reduced to a single constant | |
2529 | node if all goes well. This would normally happen when the | |
2530 | expression is constructed but function references are assumed to be | |
2531 | intrinsics in the context of initialization expressions. If | |
524af0d6 | 2532 | false is returned an error message has been generated. */ |
6de9cd9a | 2533 | |
524af0d6 | 2534 | bool |
7ac6a832 | 2535 | gfc_check_init_expr (gfc_expr *e) |
6de9cd9a | 2536 | { |
6de9cd9a | 2537 | match m; |
524af0d6 | 2538 | bool t; |
6de9cd9a DN |
2539 | |
2540 | if (e == NULL) | |
524af0d6 | 2541 | return true; |
6de9cd9a DN |
2542 | |
2543 | switch (e->expr_type) | |
2544 | { | |
2545 | case EXPR_OP: | |
7ac6a832 | 2546 | t = check_intrinsic_op (e, gfc_check_init_expr); |
524af0d6 | 2547 | if (t) |
6de9cd9a DN |
2548 | t = gfc_simplify_expr (e, 0); |
2549 | ||
2550 | break; | |
2551 | ||
2552 | case EXPR_FUNCTION: | |
524af0d6 | 2553 | t = false; |
396b2c19 | 2554 | |
21779d2e | 2555 | { |
3e6ab828 SK |
2556 | bool conversion; |
2557 | gfc_intrinsic_sym* isym = NULL; | |
8b198102 FXC |
2558 | gfc_symbol* sym = e->symtree->n.sym; |
2559 | ||
0e360db9 FXC |
2560 | /* Simplify here the intrinsics from the IEEE_ARITHMETIC and |
2561 | IEEE_EXCEPTIONS modules. */ | |
2562 | int mod = sym->from_intmod; | |
2563 | if (mod == INTMOD_NONE && sym->generic) | |
2564 | mod = sym->generic->sym->from_intmod; | |
2565 | if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS) | |
8b198102 | 2566 | { |
0e360db9 | 2567 | gfc_expr *new_expr = gfc_simplify_ieee_functions (e); |
8b198102 FXC |
2568 | if (new_expr) |
2569 | { | |
2570 | gfc_replace_expr (e, new_expr); | |
2571 | t = true; | |
2572 | break; | |
2573 | } | |
2574 | } | |
c3005b0f | 2575 | |
3e6ab828 SK |
2576 | /* If a conversion function, e.g., __convert_i8_i4, was inserted |
2577 | into an array constructor, we need to skip the error check here. | |
2578 | Conversion errors are caught below in scalarize_intrinsic_call. */ | |
2579 | conversion = e->value.function.isym | |
2580 | && (e->value.function.isym->conversion == 1); | |
2581 | ||
2582 | if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) | |
2583 | || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)) | |
21779d2e | 2584 | { |
c4100eae | 2585 | gfc_error ("Function %qs in initialization expression at %L " |
21779d2e DF |
2586 | "must be an intrinsic function", |
2587 | e->symtree->n.sym->name, &e->where); | |
2588 | break; | |
2589 | } | |
6de9cd9a | 2590 | |
21779d2e DF |
2591 | if ((m = check_conversion (e)) == MATCH_NO |
2592 | && (m = check_inquiry (e, 1)) == MATCH_NO | |
2593 | && (m = check_null (e)) == MATCH_NO | |
2594 | && (m = check_transformational (e)) == MATCH_NO | |
2595 | && (m = check_elemental (e)) == MATCH_NO) | |
2596 | { | |
c4100eae | 2597 | gfc_error ("Intrinsic function %qs at %L is not permitted " |
21779d2e DF |
2598 | "in an initialization expression", |
2599 | e->symtree->n.sym->name, &e->where); | |
2600 | m = MATCH_ERROR; | |
2601 | } | |
6de9cd9a | 2602 | |
40885767 | 2603 | if (m == MATCH_ERROR) |
524af0d6 | 2604 | return false; |
40885767 | 2605 | |
21779d2e DF |
2606 | /* Try to scalarize an elemental intrinsic function that has an |
2607 | array argument. */ | |
2608 | isym = gfc_find_function (e->symtree->n.sym->name); | |
2609 | if (isym && isym->elemental | |
3e6ab828 | 2610 | && (t = scalarize_intrinsic_call (e))) |
21779d2e DF |
2611 | break; |
2612 | } | |
6de9cd9a | 2613 | |
e1633d82 | 2614 | if (m == MATCH_YES) |
fd8e2796 | 2615 | t = gfc_simplify_expr (e, 0); |
e1633d82 | 2616 | |
6de9cd9a DN |
2617 | break; |
2618 | ||
2619 | case EXPR_VARIABLE: | |
524af0d6 | 2620 | t = true; |
6de9cd9a | 2621 | |
5bab4c96 | 2622 | /* This occurs when parsing pdt templates. */ |
18a4e7e3 | 2623 | if (gfc_expr_attr (e).pdt_kind) |
5bab4c96 PT |
2624 | break; |
2625 | ||
524af0d6 | 2626 | if (gfc_check_iter_variable (e)) |
6de9cd9a DN |
2627 | break; |
2628 | ||
2629 | if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) | |
2630 | { | |
106dbde4 DF |
2631 | /* A PARAMETER shall not be used to define itself, i.e. |
2632 | REAL, PARAMETER :: x = transfer(0, x) | |
2633 | is invalid. */ | |
2634 | if (!e->symtree->n.sym->value) | |
2635 | { | |
c4100eae MLI |
2636 | gfc_error ("PARAMETER %qs is used at %L before its definition " |
2637 | "is complete", e->symtree->n.sym->name, &e->where); | |
524af0d6 | 2638 | t = false; |
106dbde4 DF |
2639 | } |
2640 | else | |
2641 | t = simplify_parameter_variable (e, 0); | |
2642 | ||
6de9cd9a DN |
2643 | break; |
2644 | } | |
2645 | ||
2220652d PT |
2646 | if (gfc_in_match_data ()) |
2647 | break; | |
2648 | ||
524af0d6 | 2649 | t = false; |
e1633d82 DF |
2650 | |
2651 | if (e->symtree->n.sym->as) | |
2652 | { | |
2653 | switch (e->symtree->n.sym->as->type) | |
2654 | { | |
2655 | case AS_ASSUMED_SIZE: | |
c4100eae | 2656 | gfc_error ("Assumed size array %qs at %L is not permitted " |
e1633d82 DF |
2657 | "in an initialization expression", |
2658 | e->symtree->n.sym->name, &e->where); | |
5ab0eadf | 2659 | break; |
e1633d82 DF |
2660 | |
2661 | case AS_ASSUMED_SHAPE: | |
c4100eae | 2662 | gfc_error ("Assumed shape array %qs at %L is not permitted " |
e1633d82 DF |
2663 | "in an initialization expression", |
2664 | e->symtree->n.sym->name, &e->where); | |
5ab0eadf | 2665 | break; |
e1633d82 DF |
2666 | |
2667 | case AS_DEFERRED: | |
c4100eae | 2668 | gfc_error ("Deferred array %qs at %L is not permitted " |
e1633d82 DF |
2669 | "in an initialization expression", |
2670 | e->symtree->n.sym->name, &e->where); | |
5ab0eadf | 2671 | break; |
e1633d82 | 2672 | |
106dbde4 | 2673 | case AS_EXPLICIT: |
c4100eae | 2674 | gfc_error ("Array %qs at %L is a variable, which does " |
106dbde4 DF |
2675 | "not reduce to a constant expression", |
2676 | e->symtree->n.sym->name, &e->where); | |
2677 | break; | |
2678 | ||
e1633d82 DF |
2679 | default: |
2680 | gcc_unreachable(); | |
2681 | } | |
2682 | } | |
2683 | else | |
c4100eae | 2684 | gfc_error ("Parameter %qs at %L has not been declared or is " |
e1633d82 | 2685 | "a variable, which does not reduce to a constant " |
f9c5fe06 | 2686 | "expression", e->symtree->name, &e->where); |
e1633d82 | 2687 | |
6de9cd9a DN |
2688 | break; |
2689 | ||
2690 | case EXPR_CONSTANT: | |
2691 | case EXPR_NULL: | |
524af0d6 | 2692 | t = true; |
6de9cd9a DN |
2693 | break; |
2694 | ||
2695 | case EXPR_SUBSTRING: | |
31088369 SK |
2696 | if (e->ref) |
2697 | { | |
2698 | t = gfc_check_init_expr (e->ref->u.ss.start); | |
2699 | if (!t) | |
2700 | break; | |
6de9cd9a | 2701 | |
31088369 SK |
2702 | t = gfc_check_init_expr (e->ref->u.ss.end); |
2703 | if (t) | |
2704 | t = gfc_simplify_expr (e, 0); | |
2705 | } | |
2706 | else | |
2707 | t = false; | |
6de9cd9a DN |
2708 | break; |
2709 | ||
2710 | case EXPR_STRUCTURE: | |
524af0d6 JB |
2711 | t = e->ts.is_iso_c ? true : false; |
2712 | if (t) | |
604df116 DF |
2713 | break; |
2714 | ||
2715 | t = check_alloc_comp_init (e); | |
524af0d6 | 2716 | if (!t) |
604df116 DF |
2717 | break; |
2718 | ||
7ac6a832 | 2719 | t = gfc_check_constructor (e, gfc_check_init_expr); |
524af0d6 | 2720 | if (!t) |
604df116 DF |
2721 | break; |
2722 | ||
6de9cd9a DN |
2723 | break; |
2724 | ||
2725 | case EXPR_ARRAY: | |
7ac6a832 | 2726 | t = gfc_check_constructor (e, gfc_check_init_expr); |
524af0d6 | 2727 | if (!t) |
6de9cd9a DN |
2728 | break; |
2729 | ||
928f0490 | 2730 | t = gfc_expand_constructor (e, true); |
524af0d6 | 2731 | if (!t) |
6de9cd9a DN |
2732 | break; |
2733 | ||
2734 | t = gfc_check_constructor_type (e); | |
2735 | break; | |
2736 | ||
2737 | default: | |
2738 | gfc_internal_error ("check_init_expr(): Unknown expression type"); | |
2739 | } | |
2740 | ||
2741 | return t; | |
2742 | } | |
2743 | ||
d3d0b9e0 MM |
2744 | /* Reduces a general expression to an initialization expression (a constant). |
2745 | This used to be part of gfc_match_init_expr. | |
524af0d6 | 2746 | Note that this function doesn't free the given expression on false. */ |
6de9cd9a | 2747 | |
524af0d6 | 2748 | bool |
d3d0b9e0 | 2749 | gfc_reduce_init_expr (gfc_expr *expr) |
6de9cd9a | 2750 | { |
524af0d6 | 2751 | bool t; |
6de9cd9a | 2752 | |
f2cbd86c | 2753 | gfc_init_expr_flag = true; |
6de9cd9a | 2754 | t = gfc_resolve_expr (expr); |
524af0d6 | 2755 | if (t) |
7ac6a832 | 2756 | t = gfc_check_init_expr (expr); |
f2cbd86c | 2757 | gfc_init_expr_flag = false; |
6de9cd9a | 2758 | |
524af0d6 JB |
2759 | if (!t) |
2760 | return false; | |
6de9cd9a | 2761 | |
f2ff577a | 2762 | if (expr->expr_type == EXPR_ARRAY) |
e7f79e12 | 2763 | { |
524af0d6 JB |
2764 | if (!gfc_check_constructor_type (expr)) |
2765 | return false; | |
2766 | if (!gfc_expand_constructor (expr, true)) | |
2767 | return false; | |
d3d0b9e0 MM |
2768 | } |
2769 | ||
524af0d6 | 2770 | return true; |
d3d0b9e0 MM |
2771 | } |
2772 | ||
2773 | ||
2774 | /* Match an initialization expression. We work by first matching an | |
f2cbd86c | 2775 | expression, then reducing it to a constant. */ |
d3d0b9e0 MM |
2776 | |
2777 | match | |
2778 | gfc_match_init_expr (gfc_expr **result) | |
2779 | { | |
2780 | gfc_expr *expr; | |
2781 | match m; | |
524af0d6 | 2782 | bool t; |
d3d0b9e0 MM |
2783 | |
2784 | expr = NULL; | |
2785 | ||
f2cbd86c | 2786 | gfc_init_expr_flag = true; |
6bb62671 | 2787 | |
d3d0b9e0 MM |
2788 | m = gfc_match_expr (&expr); |
2789 | if (m != MATCH_YES) | |
6bb62671 | 2790 | { |
f2cbd86c | 2791 | gfc_init_expr_flag = false; |
6bb62671 SK |
2792 | return m; |
2793 | } | |
d3d0b9e0 | 2794 | |
5bab4c96 PT |
2795 | if (gfc_derived_parameter_expr (expr)) |
2796 | { | |
2797 | *result = expr; | |
2798 | gfc_init_expr_flag = false; | |
2799 | return m; | |
2800 | } | |
2801 | ||
d3d0b9e0 | 2802 | t = gfc_reduce_init_expr (expr); |
524af0d6 | 2803 | if (!t) |
d3d0b9e0 MM |
2804 | { |
2805 | gfc_free_expr (expr); | |
f2cbd86c | 2806 | gfc_init_expr_flag = false; |
e7f79e12 PT |
2807 | return MATCH_ERROR; |
2808 | } | |
6de9cd9a DN |
2809 | |
2810 | *result = expr; | |
f2cbd86c | 2811 | gfc_init_expr_flag = false; |
6de9cd9a DN |
2812 | |
2813 | return MATCH_YES; | |
2814 | } | |
2815 | ||
2816 | ||
6de9cd9a DN |
2817 | /* Given an actual argument list, test to see that each argument is a |
2818 | restricted expression and optionally if the expression type is | |
2819 | integer or character. */ | |
2820 | ||
524af0d6 | 2821 | static bool |
636dff67 | 2822 | restricted_args (gfc_actual_arglist *a) |
6de9cd9a | 2823 | { |
6de9cd9a DN |
2824 | for (; a; a = a->next) |
2825 | { | |
524af0d6 JB |
2826 | if (!check_restricted (a->expr)) |
2827 | return false; | |
6de9cd9a DN |
2828 | } |
2829 | ||
524af0d6 | 2830 | return true; |
6de9cd9a DN |
2831 | } |
2832 | ||
2833 | ||
2834 | /************* Restricted/specification expressions *************/ | |
2835 | ||
2836 | ||
068b961b JW |
2837 | /* Make sure a non-intrinsic function is a specification function, |
2838 | * see F08:7.1.11.5. */ | |
6de9cd9a | 2839 | |
524af0d6 | 2840 | static bool |
636dff67 | 2841 | external_spec_function (gfc_expr *e) |
6de9cd9a DN |
2842 | { |
2843 | gfc_symbol *f; | |
2844 | ||
2845 | f = e->value.function.esym; | |
2846 | ||
0e360db9 FXC |
2847 | /* IEEE functions allowed are "a reference to a transformational function |
2848 | from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and | |
2849 | "inquiry function from the intrinsic modules IEEE_ARITHMETIC and | |
2850 | IEEE_EXCEPTIONS". */ | |
2851 | if (f->from_intmod == INTMOD_IEEE_ARITHMETIC | |
2852 | || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) | |
2853 | { | |
2854 | if (!strcmp (f->name, "ieee_selected_real_kind") | |
2855 | || !strcmp (f->name, "ieee_support_rounding") | |
2856 | || !strcmp (f->name, "ieee_support_flag") | |
2857 | || !strcmp (f->name, "ieee_support_halting") | |
2858 | || !strcmp (f->name, "ieee_support_datatype") | |
2859 | || !strcmp (f->name, "ieee_support_denormal") | |
2860 | || !strcmp (f->name, "ieee_support_divide") | |
2861 | || !strcmp (f->name, "ieee_support_inf") | |
2862 | || !strcmp (f->name, "ieee_support_io") | |
2863 | || !strcmp (f->name, "ieee_support_nan") | |
2864 | || !strcmp (f->name, "ieee_support_sqrt") | |
2865 | || !strcmp (f->name, "ieee_support_standard") | |
2866 | || !strcmp (f->name, "ieee_support_underflow_control")) | |
2867 | goto function_allowed; | |
2868 | } | |
2869 | ||
6de9cd9a DN |
2870 | if (f->attr.proc == PROC_ST_FUNCTION) |
2871 | { | |
c4100eae | 2872 | gfc_error ("Specification function %qs at %L cannot be a statement " |
6de9cd9a | 2873 | "function", f->name, &e->where); |
524af0d6 | 2874 | return false; |
6de9cd9a DN |
2875 | } |
2876 | ||
2877 | if (f->attr.proc == PROC_INTERNAL) | |
2878 | { | |
c4100eae | 2879 | gfc_error ("Specification function %qs at %L cannot be an internal " |
6de9cd9a | 2880 | "function", f->name, &e->where); |
524af0d6 | 2881 | return false; |
6de9cd9a DN |
2882 | } |
2883 | ||
98cb5a54 | 2884 | if (!f->attr.pure && !f->attr.elemental) |
6de9cd9a | 2885 | { |
c4100eae | 2886 | gfc_error ("Specification function %qs at %L must be PURE", f->name, |
6de9cd9a | 2887 | &e->where); |
524af0d6 | 2888 | return false; |
6de9cd9a DN |
2889 | } |
2890 | ||
b349a81a JW |
2891 | /* F08:7.1.11.6. */ |
2892 | if (f->attr.recursive | |
2893 | && !gfc_notify_std (GFC_STD_F2003, | |
2f029c08 | 2894 | "Specification function %qs " |
b349a81a | 2895 | "at %L cannot be RECURSIVE", f->name, &e->where)) |
524af0d6 | 2896 | return false; |
6de9cd9a | 2897 | |
0e360db9 | 2898 | function_allowed: |
40e929f3 | 2899 | return restricted_args (e->value.function.actual); |
6de9cd9a DN |
2900 | } |
2901 | ||
2902 | ||
2903 | /* Check to see that a function reference to an intrinsic is a | |
40e929f3 | 2904 | restricted expression. */ |
6de9cd9a | 2905 | |
524af0d6 | 2906 | static bool |
636dff67 | 2907 | restricted_intrinsic (gfc_expr *e) |
6de9cd9a | 2908 | { |
40e929f3 | 2909 | /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ |
e1633d82 | 2910 | if (check_inquiry (e, 0) == MATCH_YES) |
524af0d6 | 2911 | return true; |
6de9cd9a | 2912 | |
40e929f3 | 2913 | return restricted_args (e->value.function.actual); |
6de9cd9a DN |
2914 | } |
2915 | ||
2916 | ||
a3d3c0f5 DK |
2917 | /* Check the expressions of an actual arglist. Used by check_restricted. */ |
2918 | ||
524af0d6 JB |
2919 | static bool |
2920 | check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) | |
a3d3c0f5 DK |
2921 | { |
2922 | for (; arg; arg = arg->next) | |
524af0d6 JB |
2923 | if (!checker (arg->expr)) |
2924 | return false; | |
a3d3c0f5 | 2925 | |
524af0d6 | 2926 | return true; |
a3d3c0f5 DK |
2927 | } |
2928 | ||
2929 | ||
2930 | /* Check the subscription expressions of a reference chain with a checking | |
2931 | function; used by check_restricted. */ | |
2932 | ||
524af0d6 JB |
2933 | static bool |
2934 | check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) | |
a3d3c0f5 DK |
2935 | { |
2936 | int dim; | |
2937 | ||
2938 | if (!ref) | |
524af0d6 | 2939 | return true; |
a3d3c0f5 DK |
2940 | |
2941 | switch (ref->type) | |
2942 | { | |
2943 | case REF_ARRAY: | |
2944 | for (dim = 0; dim != ref->u.ar.dimen; ++dim) | |
2945 | { | |
524af0d6 JB |
2946 | if (!checker (ref->u.ar.start[dim])) |
2947 | return false; | |
2948 | if (!checker (ref->u.ar.end[dim])) | |
2949 | return false; | |
2950 | if (!checker (ref->u.ar.stride[dim])) | |
2951 | return false; | |
a3d3c0f5 DK |
2952 | } |
2953 | break; | |
2954 | ||
2955 | case REF_COMPONENT: | |
2956 | /* Nothing needed, just proceed to next reference. */ | |
2957 | break; | |
2958 | ||
2959 | case REF_SUBSTRING: | |
524af0d6 JB |
2960 | if (!checker (ref->u.ss.start)) |
2961 | return false; | |
2962 | if (!checker (ref->u.ss.end)) | |
2963 | return false; | |
a3d3c0f5 DK |
2964 | break; |
2965 | ||
2966 | default: | |
2967 | gcc_unreachable (); | |
2968 | break; | |
2969 | } | |
2970 | ||
2971 | return check_references (ref->next, checker); | |
2972 | } | |
2973 | ||
1aae3f05 TK |
2974 | /* Return true if ns is a parent of the current ns. */ |
2975 | ||
2976 | static bool | |
2977 | is_parent_of_current_ns (gfc_namespace *ns) | |
2978 | { | |
2979 | gfc_namespace *p; | |
2980 | for (p = gfc_current_ns->parent; p; p = p->parent) | |
2981 | if (ns == p) | |
2982 | return true; | |
2983 | ||
2984 | return false; | |
2985 | } | |
a3d3c0f5 | 2986 | |
6de9cd9a DN |
2987 | /* Verify that an expression is a restricted expression. Like its |
2988 | cousin check_init_expr(), an error message is generated if we | |
524af0d6 | 2989 | return false. */ |
6de9cd9a | 2990 | |
524af0d6 | 2991 | static bool |
636dff67 | 2992 | check_restricted (gfc_expr *e) |
6de9cd9a | 2993 | { |
a3d3c0f5 | 2994 | gfc_symbol* sym; |
524af0d6 | 2995 | bool t; |
6de9cd9a DN |
2996 | |
2997 | if (e == NULL) | |
524af0d6 | 2998 | return true; |
6de9cd9a DN |
2999 | |
3000 | switch (e->expr_type) | |
3001 | { | |
3002 | case EXPR_OP: | |
3003 | t = check_intrinsic_op (e, check_restricted); | |
524af0d6 | 3004 | if (t) |
6de9cd9a DN |
3005 | t = gfc_simplify_expr (e, 0); |
3006 | ||
3007 | break; | |
3008 | ||
3009 | case EXPR_FUNCTION: | |
a3d3c0f5 DK |
3010 | if (e->value.function.esym) |
3011 | { | |
3012 | t = check_arglist (e->value.function.actual, &check_restricted); | |
524af0d6 | 3013 | if (t) |
a3d3c0f5 DK |
3014 | t = external_spec_function (e); |
3015 | } | |
3016 | else | |
3017 | { | |
3018 | if (e->value.function.isym && e->value.function.isym->inquiry) | |
524af0d6 | 3019 | t = true; |
a3d3c0f5 DK |
3020 | else |
3021 | t = check_arglist (e->value.function.actual, &check_restricted); | |
3022 | ||
524af0d6 | 3023 | if (t) |
a3d3c0f5 DK |
3024 | t = restricted_intrinsic (e); |
3025 | } | |
6de9cd9a DN |
3026 | break; |
3027 | ||
3028 | case EXPR_VARIABLE: | |
3029 | sym = e->symtree->n.sym; | |
524af0d6 | 3030 | t = false; |
6de9cd9a | 3031 | |
c4d4556f TS |
3032 | /* If a dummy argument appears in a context that is valid for a |
3033 | restricted expression in an elemental procedure, it will have | |
3034 | already been simplified away once we get here. Therefore we | |
3035 | don't need to jump through hoops to distinguish valid from | |
3036 | invalid cases. */ | |
3037 | if (sym->attr.dummy && sym->ns == gfc_current_ns | |
3038 | && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) | |
3039 | { | |
c4100eae | 3040 | gfc_error ("Dummy argument %qs not allowed in expression at %L", |
c4d4556f TS |
3041 | sym->name, &e->where); |
3042 | break; | |
3043 | } | |
3044 | ||
6de9cd9a DN |
3045 | if (sym->attr.optional) |
3046 | { | |
c4100eae | 3047 | gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", |
6de9cd9a DN |
3048 | sym->name, &e->where); |
3049 | break; | |
3050 | } | |
3051 | ||
3052 | if (sym->attr.intent == INTENT_OUT) | |
3053 | { | |
c4100eae | 3054 | gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", |
6de9cd9a DN |
3055 | sym->name, &e->where); |
3056 | break; | |
3057 | } | |
3058 | ||
a3d3c0f5 | 3059 | /* Check reference chain if any. */ |
524af0d6 | 3060 | if (!check_references (e->ref, &check_restricted)) |
a3d3c0f5 DK |
3061 | break; |
3062 | ||
636dff67 SK |
3063 | /* gfc_is_formal_arg broadcasts that a formal argument list is being |
3064 | processed in resolve.c(resolve_formal_arglist). This is done so | |
3065 | that host associated dummy array indices are accepted (PR23446). | |
3066 | This mechanism also does the same for the specification expressions | |
3067 | of array-valued functions. */ | |
ebb479cd PT |
3068 | if (e->error |
3069 | || sym->attr.in_common | |
3070 | || sym->attr.use_assoc | |
3071 | || sym->attr.dummy | |
3072 | || sym->attr.implied_index | |
a3d3c0f5 | 3073 | || sym->attr.flavor == FL_PARAMETER |
1aae3f05 | 3074 | || is_parent_of_current_ns (sym->ns) |
ebb479cd PT |
3075 | || (sym->ns->proc_name != NULL |
3076 | && sym->ns->proc_name->attr.flavor == FL_MODULE) | |
3077 | || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) | |
6de9cd9a | 3078 | { |
524af0d6 | 3079 | t = true; |
6de9cd9a DN |
3080 | break; |
3081 | } | |
3082 | ||
c4100eae | 3083 | gfc_error ("Variable %qs cannot appear in the expression at %L", |
6de9cd9a | 3084 | sym->name, &e->where); |
ebb479cd PT |
3085 | /* Prevent a repetition of the error. */ |
3086 | e->error = 1; | |
6de9cd9a DN |
3087 | break; |
3088 | ||
3089 | case EXPR_NULL: | |
3090 | case EXPR_CONSTANT: | |
524af0d6 | 3091 | t = true; |
6de9cd9a DN |
3092 | break; |
3093 | ||
3094 | case EXPR_SUBSTRING: | |
eac33acc | 3095 | t = gfc_specification_expr (e->ref->u.ss.start); |
524af0d6 | 3096 | if (!t) |
6de9cd9a DN |
3097 | break; |
3098 | ||
eac33acc | 3099 | t = gfc_specification_expr (e->ref->u.ss.end); |
524af0d6 | 3100 | if (t) |
6de9cd9a DN |
3101 | t = gfc_simplify_expr (e, 0); |
3102 | ||
3103 | break; | |
3104 | ||
3105 | case EXPR_STRUCTURE: | |
3106 | t = gfc_check_constructor (e, check_restricted); | |
3107 | break; | |
3108 | ||
3109 | case EXPR_ARRAY: | |
3110 | t = gfc_check_constructor (e, check_restricted); | |
3111 | break; | |
3112 | ||
3113 | default: | |
3114 | gfc_internal_error ("check_restricted(): Unknown expression type"); | |
3115 | } | |
3116 | ||
3117 | return t; | |
3118 | } | |
3119 | ||
3120 | ||
3121 | /* Check to see that an expression is a specification expression. If | |
524af0d6 | 3122 | we return false, an error has been generated. */ |
6de9cd9a | 3123 | |
524af0d6 | 3124 | bool |
636dff67 | 3125 | gfc_specification_expr (gfc_expr *e) |
6de9cd9a | 3126 | { |
687ea68f | 3127 | gfc_component *comp; |
66e4ab31 | 3128 | |
110eec24 | 3129 | if (e == NULL) |
524af0d6 | 3130 | return true; |
6de9cd9a DN |
3131 | |
3132 | if (e->ts.type != BT_INTEGER) | |
3133 | { | |
acb388a0 JD |
3134 | gfc_error ("Expression at %L must be of INTEGER type, found %s", |
3135 | &e->where, gfc_basic_typename (e->ts.type)); | |
524af0d6 | 3136 | return false; |
6de9cd9a DN |
3137 | } |
3138 | ||
2a573572 | 3139 | comp = gfc_get_proc_ptr_comp (e); |
98a36c7c | 3140 | if (e->expr_type == EXPR_FUNCTION |
2a573572 MM |
3141 | && !e->value.function.isym |
3142 | && !e->value.function.esym | |
3143 | && !gfc_pure (e->symtree->n.sym) | |
3144 | && (!comp || !comp->attr.pure)) | |
98a36c7c | 3145 | { |
c4100eae | 3146 | gfc_error ("Function %qs at %L must be PURE", |
98a36c7c PT |
3147 | e->symtree->n.sym->name, &e->where); |
3148 | /* Prevent repeat error messages. */ | |
3149 | e->symtree->n.sym->attr.pure = 1; | |
524af0d6 | 3150 | return false; |
98a36c7c PT |
3151 | } |
3152 | ||
6de9cd9a DN |
3153 | if (e->rank != 0) |
3154 | { | |
3155 | gfc_error ("Expression at %L must be scalar", &e->where); | |
524af0d6 | 3156 | return false; |
6de9cd9a DN |
3157 | } |
3158 | ||
524af0d6 JB |
3159 | if (!gfc_simplify_expr (e, 0)) |
3160 | return false; | |
6de9cd9a DN |
3161 | |
3162 | return check_restricted (e); | |
3163 | } | |
3164 | ||
3165 | ||
3166 | /************** Expression conformance checks. *************/ | |
3167 | ||
3168 | /* Given two expressions, make sure that the arrays are conformable. */ | |
3169 | ||
524af0d6 | 3170 | bool |
ca8a8795 | 3171 | gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) |
6de9cd9a DN |
3172 | { |
3173 | int op1_flag, op2_flag, d; | |
3174 | mpz_t op1_size, op2_size; | |
524af0d6 | 3175 | bool t; |
6de9cd9a | 3176 | |
ca8a8795 DF |
3177 | va_list argp; |
3178 | char buffer[240]; | |
3179 | ||
6de9cd9a | 3180 | if (op1->rank == 0 || op2->rank == 0) |
524af0d6 | 3181 | return true; |
6de9cd9a | 3182 | |
ca8a8795 DF |
3183 | va_start (argp, optype_msgid); |
3184 | vsnprintf (buffer, 240, optype_msgid, argp); | |
3185 | va_end (argp); | |
3186 | ||
6de9cd9a DN |
3187 | if (op1->rank != op2->rank) |
3188 | { | |
ca8a8795 | 3189 | gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), |
3c7b91d3 | 3190 | op1->rank, op2->rank, &op1->where); |
524af0d6 | 3191 | return false; |
6de9cd9a DN |
3192 | } |
3193 | ||
524af0d6 | 3194 | t = true; |
6de9cd9a DN |
3195 | |
3196 | for (d = 0; d < op1->rank; d++) | |
3197 | { | |
524af0d6 JB |
3198 | op1_flag = gfc_array_dimen_size(op1, d, &op1_size); |
3199 | op2_flag = gfc_array_dimen_size(op2, d, &op2_size); | |
6de9cd9a DN |
3200 | |
3201 | if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) | |
3202 | { | |
7e49f965 | 3203 | gfc_error ("Different shape for %s at %L on dimension %d " |
ca8a8795 | 3204 | "(%d and %d)", _(buffer), &op1->where, d + 1, |
31043f6c | 3205 | (int) mpz_get_si (op1_size), |
6de9cd9a DN |
3206 | (int) mpz_get_si (op2_size)); |
3207 | ||
524af0d6 | 3208 | t = false; |
6de9cd9a DN |
3209 | } |
3210 | ||
3211 | if (op1_flag) | |
3212 | mpz_clear (op1_size); | |
3213 | if (op2_flag) | |
3214 | mpz_clear (op2_size); | |
3215 | ||
524af0d6 JB |
3216 | if (!t) |
3217 | return false; | |
6de9cd9a DN |
3218 | } |
3219 | ||
524af0d6 | 3220 | return true; |
6de9cd9a DN |
3221 | } |
3222 | ||
3223 | ||
3224 | /* Given an assignable expression and an arbitrary expression, make | |
3c9f5092 AV |
3225 | sure that the assignment can take place. Only add a call to the intrinsic |
3226 | conversion routines, when allow_convert is set. When this assign is a | |
3227 | coarray call, then the convert is done by the coarray routine implictly and | |
3228 | adding the intrinsic conversion would do harm in most cases. */ | |
6de9cd9a | 3229 | |
524af0d6 | 3230 | bool |
3c9f5092 AV |
3231 | gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, |
3232 | bool allow_convert) | |
6de9cd9a DN |
3233 | { |
3234 | gfc_symbol *sym; | |
f17facac TB |
3235 | gfc_ref *ref; |
3236 | int has_pointer; | |
6de9cd9a DN |
3237 | |
3238 | sym = lvalue->symtree->n.sym; | |
3239 | ||
8c91ab34 | 3240 | /* See if this is the component or subcomponent of a pointer. */ |
f17facac | 3241 | has_pointer = sym->attr.pointer; |
f17facac | 3242 | for (ref = lvalue->ref; ref; ref = ref->next) |
d4b7d0f0 | 3243 | if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) |
f17facac TB |
3244 | { |
3245 | has_pointer = 1; | |
3246 | break; | |
3247 | } | |
3248 | ||
66e4ab31 SK |
3249 | /* 12.5.2.2, Note 12.26: The result variable is very similar to any other |
3250 | variable local to a function subprogram. Its existence begins when | |
3251 | execution of the function is initiated and ends when execution of the | |
3252 | function is terminated... | |
3253 | Therefore, the left hand side is no longer a variable, when it is: */ | |
636dff67 SK |
3254 | if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION |
3255 | && !sym->attr.external) | |
2990f854 | 3256 | { |
f5f701ad PT |
3257 | bool bad_proc; |
3258 | bad_proc = false; | |
3259 | ||
66e4ab31 | 3260 | /* (i) Use associated; */ |
f5f701ad PT |
3261 | if (sym->attr.use_assoc) |
3262 | bad_proc = true; | |
3263 | ||
e2ae1407 | 3264 | /* (ii) The assignment is in the main program; or */ |
bfeeb145 SK |
3265 | if (gfc_current_ns->proc_name |
3266 | && gfc_current_ns->proc_name->attr.is_main_program) | |
f5f701ad PT |
3267 | bad_proc = true; |
3268 | ||
66e4ab31 | 3269 | /* (iii) A module or internal procedure... */ |
bfeeb145 SK |
3270 | if (gfc_current_ns->proc_name |
3271 | && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL | |
3272 | || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) | |
f5f701ad PT |
3273 | && gfc_current_ns->parent |
3274 | && (!(gfc_current_ns->parent->proc_name->attr.function | |
636dff67 | 3275 | || gfc_current_ns->parent->proc_name->attr.subroutine) |
f5f701ad PT |
3276 | || gfc_current_ns->parent->proc_name->attr.is_main_program)) |
3277 | { | |
8b704316 | 3278 | /* ... that is not a function... */ |
bfeeb145 SK |
3279 | if (gfc_current_ns->proc_name |
3280 | && !gfc_current_ns->proc_name->attr.function) | |
f5f701ad PT |
3281 | bad_proc = true; |
3282 | ||
66e4ab31 | 3283 | /* ... or is not an entry and has a different name. */ |
f5f701ad PT |
3284 | if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) |
3285 | bad_proc = true; | |
3286 | } | |
2990f854 | 3287 | |
db39d0c2 PT |
3288 | /* (iv) Host associated and not the function symbol or the |
3289 | parent result. This picks up sibling references, which | |
3290 | cannot be entries. */ | |
3291 | if (!sym->attr.entry | |
3292 | && sym->ns == gfc_current_ns->parent | |
3293 | && sym != gfc_current_ns->proc_name | |
3294 | && sym != gfc_current_ns->parent->proc_name->result) | |
3295 | bad_proc = true; | |
3296 | ||
f5f701ad PT |
3297 | if (bad_proc) |
3298 | { | |
c4100eae | 3299 | gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); |
524af0d6 | 3300 | return false; |
f5f701ad PT |
3301 | } |
3302 | } | |
2990f854 | 3303 | |
6de9cd9a DN |
3304 | if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) |
3305 | { | |
7dea5a95 TS |
3306 | gfc_error ("Incompatible ranks %d and %d in assignment at %L", |
3307 | lvalue->rank, rvalue->rank, &lvalue->where); | |
524af0d6 | 3308 | return false; |
6de9cd9a DN |
3309 | } |
3310 | ||
3311 | if (lvalue->ts.type == BT_UNKNOWN) | |
3312 | { | |
3313 | gfc_error ("Variable type is UNKNOWN in assignment at %L", | |
3314 | &lvalue->where); | |
524af0d6 | 3315 | return false; |
6de9cd9a DN |
3316 | } |
3317 | ||
37775e79 | 3318 | if (rvalue->expr_type == EXPR_NULL) |
8b704316 | 3319 | { |
e49be8f7 | 3320 | if (has_pointer && (ref == NULL || ref->next == NULL) |
37775e79 | 3321 | && lvalue->symtree->n.sym->attr.data) |
524af0d6 | 3322 | return true; |
37775e79 JD |
3323 | else |
3324 | { | |
3325 | gfc_error ("NULL appears on right-hand side in assignment at %L", | |
3326 | &rvalue->where); | |
524af0d6 | 3327 | return false; |
37775e79 JD |
3328 | } |
3329 | } | |
7dea5a95 | 3330 | |
66e4ab31 | 3331 | /* This is possibly a typo: x = f() instead of x => f(). */ |
73e42eef | 3332 | if (warn_surprising |
8988cde6 | 3333 | && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) |
48749dbc MLI |
3334 | gfc_warning (OPT_Wsurprising, |
3335 | "POINTER-valued function appears on right-hand side of " | |
6d1c50cc TS |
3336 | "assignment at %L", &rvalue->where); |
3337 | ||
6de9cd9a DN |
3338 | /* Check size of array assignments. */ |
3339 | if (lvalue->rank != 0 && rvalue->rank != 0 | |
524af0d6 JB |
3340 | && !gfc_check_conformance (lvalue, rvalue, "array assignment")) |
3341 | return false; | |
6de9cd9a | 3342 | |
00a4618b TB |
3343 | if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER |
3344 | && lvalue->symtree->n.sym->attr.data | |
524af0d6 | 3345 | && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " |
bf9f15ee | 3346 | "initialize non-integer variable %qs", |
524af0d6 JB |
3347 | &rvalue->where, lvalue->symtree->n.sym->name)) |
3348 | return false; | |
00a4618b | 3349 | else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data |
524af0d6 JB |
3350 | && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " |
3351 | "a DATA statement and outside INT/REAL/DBLE/CMPLX", | |
3352 | &rvalue->where)) | |
3353 | return false; | |
00a4618b TB |
3354 | |
3355 | /* Handle the case of a BOZ literal on the RHS. */ | |
3356 | if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER) | |
3357 | { | |
4956b1f1 | 3358 | int rc; |
73e42eef | 3359 | if (warn_surprising) |
48749dbc MLI |
3360 | gfc_warning (OPT_Wsurprising, |
3361 | "BOZ literal at %L is bitwise transferred " | |
3362 | "non-integer symbol %qs", &rvalue->where, | |
3363 | lvalue->symtree->n.sym->name); | |
c7abc45c | 3364 | if (!gfc_convert_boz (rvalue, &lvalue->ts)) |
524af0d6 | 3365 | return false; |
4956b1f1 TB |
3366 | if ((rc = gfc_range_check (rvalue)) != ARITH_OK) |
3367 | { | |
3368 | if (rc == ARITH_UNDERFLOW) | |
3369 | gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L" | |
3370 | ". This check can be disabled with the option " | |
a4d9b221 | 3371 | "%<-fno-range-check%>", &rvalue->where); |
4956b1f1 TB |
3372 | else if (rc == ARITH_OVERFLOW) |
3373 | gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L" | |
3374 | ". This check can be disabled with the option " | |
a4d9b221 | 3375 | "%<-fno-range-check%>", &rvalue->where); |
4956b1f1 TB |
3376 | else if (rc == ARITH_NAN) |
3377 | gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L" | |
3378 | ". This check can be disabled with the option " | |
a4d9b221 | 3379 | "%<-fno-range-check%>", &rvalue->where); |
524af0d6 | 3380 | return false; |
4956b1f1 | 3381 | } |
00a4618b TB |
3382 | } |
3383 | ||
5bab4c96 PT |
3384 | if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) |
3385 | { | |
3386 | gfc_error ("The assignment to a KIND or LEN component of a " | |
3387 | "parameterized type at %L is not allowed", | |
3388 | &lvalue->where); | |
3389 | return false; | |
3390 | } | |
3391 | ||
6de9cd9a | 3392 | if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) |
524af0d6 | 3393 | return true; |
6de9cd9a | 3394 | |
c4e3543d | 3395 | /* Only DATA Statements come here. */ |
6de9cd9a DN |
3396 | if (!conform) |
3397 | { | |
d3642f89 FW |
3398 | /* Numeric can be converted to any other numeric. And Hollerith can be |
3399 | converted to any other type. */ | |
3400 | if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) | |
3401 | || rvalue->ts.type == BT_HOLLERITH) | |
524af0d6 | 3402 | return true; |
6de9cd9a | 3403 | |
f240b896 | 3404 | if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) |
524af0d6 | 3405 | return true; |
f240b896 | 3406 | |
c4e3543d PT |
3407 | gfc_error ("Incompatible types in DATA statement at %L; attempted " |
3408 | "conversion of %s to %s", &lvalue->where, | |
3409 | gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); | |
6de9cd9a | 3410 | |
524af0d6 | 3411 | return false; |
6de9cd9a DN |
3412 | } |
3413 | ||
d393bbd7 FXC |
3414 | /* Assignment is the only case where character variables of different |
3415 | kind values can be converted into one another. */ | |
3416 | if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) | |
3417 | { | |
3c9f5092 | 3418 | if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) |
6ed022af JW |
3419 | return gfc_convert_chartype (rvalue, &lvalue->ts); |
3420 | else | |
3421 | return true; | |
d393bbd7 FXC |
3422 | } |
3423 | ||
3c9f5092 AV |
3424 | if (!allow_convert) |
3425 | return true; | |
3426 | ||
6de9cd9a DN |
3427 | return gfc_convert_type (rvalue, &lvalue->ts, 1); |
3428 | } | |
3429 | ||
3430 | ||
3431 | /* Check that a pointer assignment is OK. We first check lvalue, and | |
3432 | we only check rvalue if it's not an assignment to NULL() or a | |
3433 | NULLIFY statement. */ | |
3434 | ||
524af0d6 | 3435 | bool |
636dff67 | 3436 | gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) |
6de9cd9a | 3437 | { |
e35e87dc | 3438 | symbol_attribute attr, lhs_attr; |
f17facac | 3439 | gfc_ref *ref; |
f1f39033 | 3440 | bool is_pure, is_implicit_pure, rank_remap; |
8c91ab34 | 3441 | int proc_pointer; |
6de9cd9a | 3442 | |
e35e87dc TB |
3443 | lhs_attr = gfc_expr_attr (lvalue); |
3444 | if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) | |
6de9cd9a DN |
3445 | { |
3446 | gfc_error ("Pointer assignment target is not a POINTER at %L", | |
3447 | &lvalue->where); | |
524af0d6 | 3448 | return false; |
6de9cd9a DN |
3449 | } |
3450 | ||
e35e87dc TB |
3451 | if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc |
3452 | && !lhs_attr.proc_pointer) | |
2990f854 | 3453 | { |
c4100eae | 3454 | gfc_error ("%qs in the pointer assignment at %L cannot be an " |
2990f854 PT |
3455 | "l-value since it is a procedure", |
3456 | lvalue->symtree->n.sym->name, &lvalue->where); | |
524af0d6 | 3457 | return false; |
2990f854 PT |
3458 | } |
3459 | ||
713485cc | 3460 | proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; |
f17facac | 3461 | |
99d821c0 | 3462 | rank_remap = false; |
f17facac TB |
3463 | for (ref = lvalue->ref; ref; ref = ref->next) |
3464 | { | |
6596e2fe | 3465 | if (ref->type == REF_COMPONENT) |
8c91ab34 | 3466 | proc_pointer = ref->u.c.component->attr.proc_pointer; |
54799fcd TB |
3467 | |
3468 | if (ref->type == REF_ARRAY && ref->next == NULL) | |
3469 | { | |
99d821c0 DK |
3470 | int dim; |
3471 | ||
54799fcd TB |
3472 | if (ref->u.ar.type == AR_FULL) |
3473 | break; | |
3474 | ||
3475 | if (ref->u.ar.type != AR_SECTION) | |
3476 | { | |
c4100eae | 3477 | gfc_error ("Expected bounds specification for %qs at %L", |
54799fcd | 3478 | lvalue->symtree->n.sym->name, &lvalue->where); |
524af0d6 | 3479 | return false; |
54799fcd TB |
3480 | } |
3481 | ||
524af0d6 | 3482 | if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " |
bf9f15ee | 3483 | "for %qs in pointer assignment at %L", |
524af0d6 JB |
3484 | lvalue->symtree->n.sym->name, &lvalue->where)) |
3485 | return false; | |
54799fcd | 3486 | |
99d821c0 DK |
3487 | /* When bounds are given, all lbounds are necessary and either all |
3488 | or none of the upper bounds; no strides are allowed. If the | |
3489 | upper bounds are present, we may do rank remapping. */ | |
3490 | for (dim = 0; dim < ref->u.ar.dimen; ++dim) | |
3491 | { | |
73cd74f8 TB |
3492 | if (!ref->u.ar.start[dim] |
3493 | || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) | |
99d821c0 DK |
3494 | { |
3495 | gfc_error ("Lower bound has to be present at %L", | |
3496 | &lvalue->where); | |
524af0d6 | 3497 | return false; |
99d821c0 DK |
3498 | } |
3499 | if (ref->u.ar.stride[dim]) | |
3500 | { | |
3501 | gfc_error ("Stride must not be present at %L", | |
3502 | &lvalue->where); | |
524af0d6 | 3503 | return false; |
99d821c0 DK |
3504 | } |
3505 | ||
3506 | if (dim == 0) | |
3507 | rank_remap = (ref->u.ar.end[dim] != NULL); | |
3508 | else | |
3509 | { | |
3510 | if ((rank_remap && !ref->u.ar.end[dim]) | |
3511 | || (!rank_remap && ref->u.ar.end[dim])) | |
3512 | { | |
3513 | gfc_error ("Either all or none of the upper bounds" | |
3514 | " must be specified at %L", &lvalue->where); | |
524af0d6 | 3515 | return false; |
99d821c0 DK |
3516 | } |
3517 | } | |
3518 | } | |
54799fcd | 3519 | } |
f17facac TB |
3520 | } |
3521 | ||
6de9cd9a | 3522 | is_pure = gfc_pure (NULL); |
f1f39033 | 3523 | is_implicit_pure = gfc_implicit_pure (NULL); |
6de9cd9a | 3524 | |
6de9cd9a DN |
3525 | /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, |
3526 | kind, etc for lvalue and rvalue must match, and rvalue must be a | |
3527 | pure variable if we're in a pure function. */ | |
def66134 | 3528 | if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) |
524af0d6 | 3529 | return true; |
7d76d73a | 3530 | |
d3a9eea2 TB |
3531 | /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ |
3532 | if (lvalue->expr_type == EXPR_VARIABLE | |
3533 | && gfc_is_coindexed (lvalue)) | |
3534 | { | |
3535 | gfc_ref *ref; | |
3536 | for (ref = lvalue->ref; ref; ref = ref->next) | |
3537 | if (ref->type == REF_ARRAY && ref->u.ar.codimen) | |
3538 | { | |
3539 | gfc_error ("Pointer object at %L shall not have a coindex", | |
3540 | &lvalue->where); | |
524af0d6 | 3541 | return false; |
d3a9eea2 TB |
3542 | } |
3543 | } | |
3544 | ||
726d8566 | 3545 | /* Checks on rvalue for procedure pointer assignments. */ |
713485cc | 3546 | if (proc_pointer) |
726d8566 | 3547 | { |
8ad15a0a | 3548 | char err[200]; |
889dc035 | 3549 | gfc_symbol *s1,*s2; |
eba5aec8 | 3550 | gfc_component *comp1, *comp2; |
889dc035 JW |
3551 | const char *name; |
3552 | ||
726d8566 JW |
3553 | attr = gfc_expr_attr (rvalue); |
3554 | if (!((rvalue->expr_type == EXPR_NULL) | |
3555 | || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) | |
713485cc | 3556 | || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) |
726d8566 JW |
3557 | || (rvalue->expr_type == EXPR_VARIABLE |
3558 | && attr.flavor == FL_PROCEDURE))) | |
3559 | { | |
3560 | gfc_error ("Invalid procedure pointer assignment at %L", | |
3561 | &rvalue->where); | |
524af0d6 | 3562 | return false; |
726d8566 | 3563 | } |
2dda89a8 JW |
3564 | if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) |
3565 | { | |
3566 | /* Check for intrinsics. */ | |
3567 | gfc_symbol *sym = rvalue->symtree->n.sym; | |
3568 | if (!sym->attr.intrinsic | |
2dda89a8 JW |
3569 | && (gfc_is_intrinsic (sym, 0, sym->declared_at) |
3570 | || gfc_is_intrinsic (sym, 1, sym->declared_at))) | |
3571 | { | |
3572 | sym->attr.intrinsic = 1; | |
3573 | gfc_resolve_intrinsic (sym, &rvalue->where); | |
3574 | attr = gfc_expr_attr (rvalue); | |
3575 | } | |
37bfd49f | 3576 | /* Check for result of embracing function. */ |
cadddfdd | 3577 | if (sym->attr.function && sym->result == sym) |
37bfd49f | 3578 | { |
cadddfdd TB |
3579 | gfc_namespace *ns; |
3580 | ||
3581 | for (ns = gfc_current_ns; ns; ns = ns->parent) | |
3582 | if (sym == ns->proc_name) | |
3583 | { | |
c4100eae | 3584 | gfc_error ("Function result %qs is invalid as proc-target " |
cadddfdd TB |
3585 | "in procedure pointer assignment at %L", |
3586 | sym->name, &rvalue->where); | |
524af0d6 | 3587 | return false; |
cadddfdd | 3588 | } |
37bfd49f | 3589 | } |
2dda89a8 | 3590 | } |
fb7ca5a7 JW |
3591 | if (attr.abstract) |
3592 | { | |
c4100eae | 3593 | gfc_error ("Abstract interface %qs is invalid " |
fb7ca5a7 JW |
3594 | "in procedure pointer assignment at %L", |
3595 | rvalue->symtree->name, &rvalue->where); | |
524af0d6 | 3596 | return false; |
fb7ca5a7 | 3597 | } |
58c1ae36 | 3598 | /* Check for F08:C729. */ |
210aee68 JW |
3599 | if (attr.flavor == FL_PROCEDURE) |
3600 | { | |
3601 | if (attr.proc == PROC_ST_FUNCTION) | |
3602 | { | |
c4100eae | 3603 | gfc_error ("Statement function %qs is invalid " |
210aee68 JW |
3604 | "in procedure pointer assignment at %L", |
3605 | rvalue->symtree->name, &rvalue->where); | |
524af0d6 | 3606 | return false; |
210aee68 JW |
3607 | } |
3608 | if (attr.proc == PROC_INTERNAL && | |
a4d9b221 | 3609 | !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs " |
524af0d6 JB |
3610 | "is invalid in procedure pointer assignment " |
3611 | "at %L", rvalue->symtree->name, &rvalue->where)) | |
3612 | return false; | |
2dda89a8 JW |
3613 | if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, |
3614 | attr.subroutine) == 0) | |
3615 | { | |
c4100eae | 3616 | gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " |
2dda89a8 | 3617 | "assignment", rvalue->symtree->name, &rvalue->where); |
524af0d6 | 3618 | return false; |
2dda89a8 | 3619 | } |
210aee68 | 3620 | } |
58c1ae36 JW |
3621 | /* Check for F08:C730. */ |
3622 | if (attr.elemental && !attr.intrinsic) | |
3623 | { | |
c4100eae | 3624 | gfc_error ("Nonintrinsic elemental procedure %qs is invalid " |
62732c30 | 3625 | "in procedure pointer assignment at %L", |
58c1ae36 | 3626 | rvalue->symtree->name, &rvalue->where); |
524af0d6 | 3627 | return false; |
58c1ae36 | 3628 | } |
08a6b8e0 TB |
3629 | |
3630 | /* Ensure that the calling convention is the same. As other attributes | |
3631 | such as DLLEXPORT may differ, one explicitly only tests for the | |
3632 | calling conventions. */ | |
3633 | if (rvalue->expr_type == EXPR_VARIABLE | |
3634 | && lvalue->symtree->n.sym->attr.ext_attr | |
3635 | != rvalue->symtree->n.sym->attr.ext_attr) | |
3636 | { | |
c0e18b82 | 3637 | symbol_attribute calls; |
08a6b8e0 | 3638 | |
c0e18b82 TB |
3639 | calls.ext_attr = 0; |
3640 | gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); | |
3641 | gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); | |
3642 | gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); | |
08a6b8e0 | 3643 | |
c0e18b82 TB |
3644 | if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) |
3645 | != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) | |
08a6b8e0 TB |
3646 | { |
3647 | gfc_error ("Mismatch in the procedure pointer assignment " | |
3648 | "at %L: mismatch in the calling convention", | |
3649 | &rvalue->where); | |
524af0d6 | 3650 | return false; |
08a6b8e0 TB |
3651 | } |
3652 | } | |
3653 | ||
eba5aec8 JW |
3654 | comp1 = gfc_get_proc_ptr_comp (lvalue); |
3655 | if (comp1) | |
3656 | s1 = comp1->ts.interface; | |
889dc035 | 3657 | else |
899d52c6 PT |
3658 | { |
3659 | s1 = lvalue->symtree->n.sym; | |
3660 | if (s1->ts.interface) | |
3661 | s1 = s1->ts.interface; | |
3662 | } | |
889dc035 | 3663 | |
eba5aec8 JW |
3664 | comp2 = gfc_get_proc_ptr_comp (rvalue); |
3665 | if (comp2) | |
889dc035 | 3666 | { |
a4a76e52 JW |
3667 | if (rvalue->expr_type == EXPR_FUNCTION) |
3668 | { | |
eba5aec8 | 3669 | s2 = comp2->ts.interface->result; |
899d52c6 | 3670 | name = s2->name; |
a4a76e52 JW |
3671 | } |
3672 | else | |
3673 | { | |
eba5aec8 JW |
3674 | s2 = comp2->ts.interface; |
3675 | name = comp2->name; | |
a4a76e52 | 3676 | } |
889dc035 JW |
3677 | } |
3678 | else if (rvalue->expr_type == EXPR_FUNCTION) | |
3679 | { | |
bafa0782 JW |
3680 | if (rvalue->value.function.esym) |
3681 | s2 = rvalue->value.function.esym->result; | |
3682 | else | |
3683 | s2 = rvalue->symtree->n.sym->result; | |
3684 | ||
899d52c6 | 3685 | name = s2->name; |
889dc035 JW |
3686 | } |
3687 | else | |
3688 | { | |
3689 | s2 = rvalue->symtree->n.sym; | |
899d52c6 PT |
3690 | name = s2->name; |
3691 | } | |
3692 | ||
feb6eab0 | 3693 | if (s2 && s2->attr.proc_pointer && s2->ts.interface) |
899d52c6 PT |
3694 | s2 = s2->ts.interface; |
3695 | ||
eba5aec8 JW |
3696 | /* Special check for the case of absent interface on the lvalue. |
3697 | * All other interface checks are done below. */ | |
3698 | if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) | |
3699 | { | |
3700 | gfc_error ("Interface mismatch in procedure pointer assignment " | |
2f029c08 | 3701 | "at %L: %qs is not a subroutine", &rvalue->where, name); |
eba5aec8 JW |
3702 | return false; |
3703 | } | |
3704 | ||
96486998 | 3705 | /* F08:7.2.2.4 (4) */ |
99827b5c | 3706 | if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) |
96486998 | 3707 | { |
99827b5c JW |
3708 | if (comp1 && !s1) |
3709 | { | |
3710 | gfc_error ("Explicit interface required for component %qs at %L: %s", | |
3711 | comp1->name, &lvalue->where, err); | |
3712 | return false; | |
3713 | } | |
3714 | else if (s1->attr.if_source == IFSRC_UNKNOWN) | |
3715 | { | |
3716 | gfc_error ("Explicit interface required for %qs at %L: %s", | |
3717 | s1->name, &lvalue->where, err); | |
3718 | return false; | |
3719 | } | |
96486998 | 3720 | } |
99827b5c | 3721 | if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) |
96486998 | 3722 | { |
99827b5c JW |
3723 | if (comp2 && !s2) |
3724 | { | |
3725 | gfc_error ("Explicit interface required for component %qs at %L: %s", | |
3726 | comp2->name, &rvalue->where, err); | |
3727 | return false; | |
3728 | } | |
3729 | else if (s2->attr.if_source == IFSRC_UNKNOWN) | |
3730 | { | |
3731 | gfc_error ("Explicit interface required for %qs at %L: %s", | |
3732 | s2->name, &rvalue->where, err); | |
3733 | return false; | |
3734 | } | |
96486998 JW |
3735 | } |
3736 | ||
99827b5c JW |
3737 | if (s1 == s2 || !s1 || !s2) |
3738 | return true; | |
3739 | ||
899d52c6 PT |
3740 | if (!gfc_compare_interfaces (s1, s2, name, 0, 1, |
3741 | err, sizeof(err), NULL, NULL)) | |
3742 | { | |
3743 | gfc_error ("Interface mismatch in procedure pointer assignment " | |
3744 | "at %L: %s", &rvalue->where, err); | |
524af0d6 | 3745 | return false; |
889dc035 JW |
3746 | } |
3747 | ||
ab1668f6 TB |
3748 | /* Check F2008Cor2, C729. */ |
3749 | if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN | |
3750 | && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) | |
3751 | { | |
c4100eae | 3752 | gfc_error ("Procedure pointer target %qs at %L must be either an " |
ab1668f6 TB |
3753 | "intrinsic, host or use associated, referenced or have " |
3754 | "the EXTERNAL attribute", s2->name, &rvalue->where); | |
3755 | return false; | |
3756 | } | |
3757 | ||
524af0d6 | 3758 | return true; |
726d8566 | 3759 | } |
8fb74da4 | 3760 | |
93d76687 | 3761 | if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) |
6de9cd9a | 3762 | { |
8b704316 PT |
3763 | /* Check for F03:C717. */ |
3764 | if (UNLIMITED_POLY (rvalue) | |
3765 | && !(UNLIMITED_POLY (lvalue) | |
3766 | || (lvalue->ts.type == BT_DERIVED | |
3767 | && (lvalue->ts.u.derived->attr.is_bind_c | |
3768 | || lvalue->ts.u.derived->attr.sequence)))) | |
83be3fe5 DH |
3769 | gfc_error ("Data-pointer-object at %L must be unlimited " |
3770 | "polymorphic, or of a type with the BIND or SEQUENCE " | |
3771 | "attribute, to be compatible with an unlimited " | |
3772 | "polymorphic target", &lvalue->where); | |
8b704316 PT |
3773 | else |
3774 | gfc_error ("Different types in pointer assignment at %L; " | |
3775 | "attempted assignment of %s to %s", &lvalue->where, | |
3776 | gfc_typename (&rvalue->ts), | |
3777 | gfc_typename (&lvalue->ts)); | |
524af0d6 | 3778 | return false; |
7d76d73a | 3779 | } |
6de9cd9a | 3780 | |
cf2b3c22 | 3781 | if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) |
7d76d73a | 3782 | { |
31043f6c | 3783 | gfc_error ("Different kind type parameters in pointer " |
7d76d73a | 3784 | "assignment at %L", &lvalue->where); |
524af0d6 | 3785 | return false; |
7d76d73a | 3786 | } |
6de9cd9a | 3787 | |
99d821c0 | 3788 | if (lvalue->rank != rvalue->rank && !rank_remap) |
def66134 | 3789 | { |
99d821c0 | 3790 | gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); |
524af0d6 | 3791 | return false; |
def66134 SK |
3792 | } |
3793 | ||
7289d1c9 JW |
3794 | /* Make sure the vtab is present. */ |
3795 | if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)) | |
3796 | gfc_find_vtab (&rvalue->ts); | |
611c64f0 | 3797 | |
99d821c0 DK |
3798 | /* Check rank remapping. */ |
3799 | if (rank_remap) | |
3800 | { | |
3801 | mpz_t lsize, rsize; | |
3802 | ||
3803 | /* If this can be determined, check that the target must be at least as | |
3804 | large as the pointer assigned to it is. */ | |
524af0d6 JB |
3805 | if (gfc_array_size (lvalue, &lsize) |
3806 | && gfc_array_size (rvalue, &rsize) | |
99d821c0 DK |
3807 | && mpz_cmp (rsize, lsize) < 0) |
3808 | { | |
3809 | gfc_error ("Rank remapping target is smaller than size of the" | |
3810 | " pointer (%ld < %ld) at %L", | |
3811 | mpz_get_si (rsize), mpz_get_si (lsize), | |
3812 | &lvalue->where); | |
524af0d6 | 3813 | return false; |
99d821c0 DK |
3814 | } |
3815 | ||
3816 | /* The target must be either rank one or it must be simply contiguous | |
3817 | and F2008 must be allowed. */ | |
3818 | if (rvalue->rank != 1) | |
3819 | { | |
460263d0 | 3820 | if (!gfc_is_simply_contiguous (rvalue, true, false)) |
99d821c0 DK |
3821 | { |
3822 | gfc_error ("Rank remapping target must be rank 1 or" | |
3823 | " simply contiguous at %L", &rvalue->where); | |
524af0d6 | 3824 | return false; |
99d821c0 | 3825 | } |
524af0d6 JB |
3826 | if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " |
3827 | "rank 1 at %L", &rvalue->where)) | |
3828 | return false; | |
99d821c0 DK |
3829 | } |
3830 | } | |
3831 | ||
def66134 SK |
3832 | /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ |
3833 | if (rvalue->expr_type == EXPR_NULL) | |
524af0d6 | 3834 | return true; |
def66134 | 3835 | |
fb5bc08b | 3836 | if (lvalue->ts.type == BT_CHARACTER) |
2990f854 | 3837 | { |
524af0d6 JB |
3838 | bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); |
3839 | if (!t) | |
3840 | return false; | |
2990f854 PT |
3841 | } |
3842 | ||
1d6b7f39 PT |
3843 | if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) |
3844 | lvalue->symtree->n.sym->attr.subref_array_pointer = 1; | |
3845 | ||
7d76d73a | 3846 | attr = gfc_expr_attr (rvalue); |
7f1f7ffb TB |
3847 | |
3848 | if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) | |
3849 | { | |
de91486c AV |
3850 | /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call |
3851 | to caf_get. Map this to the same error message as below when it is | |
3852 | still a variable expression. */ | |
3853 | if (rvalue->value.function.isym | |
3854 | && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) | |
3855 | /* The test above might need to be extend when F08, Note 5.4 has to be | |
3856 | interpreted in the way that target and pointer with the same coindex | |
3857 | are allowed. */ | |
3858 | gfc_error ("Data target at %L shall not have a coindex", | |
3859 | &rvalue->where); | |
3860 | else | |
3861 | gfc_error ("Target expression in pointer assignment " | |
3862 | "at %L must deliver a pointer result", | |
3863 | &rvalue->where); | |
524af0d6 | 3864 | return false; |
7f1f7ffb TB |
3865 | } |
3866 | ||
7d76d73a TS |
3867 | if (!attr.target && !attr.pointer) |
3868 | { | |
31043f6c | 3869 | gfc_error ("Pointer assignment target is neither TARGET " |
7d76d73a | 3870 | "nor POINTER at %L", &rvalue->where); |
524af0d6 | 3871 | return false; |
7d76d73a | 3872 | } |
6de9cd9a | 3873 | |
7d76d73a TS |
3874 | if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) |
3875 | { | |
31043f6c | 3876 | gfc_error ("Bad target in pointer assignment in PURE " |
7d76d73a TS |
3877 | "procedure at %L", &rvalue->where); |
3878 | } | |
6de9cd9a | 3879 | |
f1f39033 | 3880 | if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) |
ccd7751b | 3881 | gfc_unset_implicit_pure (gfc_current_ns->proc_name); |
f1f39033 | 3882 | |
4075a94e PT |
3883 | if (gfc_has_vector_index (rvalue)) |
3884 | { | |
3885 | gfc_error ("Pointer assignment with vector subscript " | |
3886 | "on rhs at %L", &rvalue->where); | |
524af0d6 | 3887 | return false; |
4075a94e PT |
3888 | } |
3889 | ||
3dcc3ef2 TB |
3890 | if (attr.is_protected && attr.use_assoc |
3891 | && !(attr.pointer || attr.proc_pointer)) | |
ee7e677f | 3892 | { |
df2fba9e | 3893 | gfc_error ("Pointer assignment target has PROTECTED " |
636dff67 | 3894 | "attribute at %L", &rvalue->where); |
524af0d6 | 3895 | return false; |
ee7e677f TB |
3896 | } |
3897 | ||
d3a9eea2 TB |
3898 | /* F2008, C725. For PURE also C1283. */ |
3899 | if (rvalue->expr_type == EXPR_VARIABLE | |
3900 | && gfc_is_coindexed (rvalue)) | |
3901 | { | |
3902 | gfc_ref *ref; | |
3903 | for (ref = rvalue->ref; ref; ref = ref->next) | |
3904 | if (ref->type == REF_ARRAY && ref->u.ar.codimen) | |
3905 | { | |
3906 | gfc_error ("Data target at %L shall not have a coindex", | |
3907 | &rvalue->where); | |
524af0d6 | 3908 | return false; |
d3a9eea2 TB |
3909 | } |
3910 | } | |
3911 | ||
5abde510 TK |
3912 | /* Error for assignments of contiguous pointers to targets which is not |
3913 | contiguous. Be lenient in the definition of what counts as | |
a4f759de | 3914 | contiguous. */ |
5abde510 TK |
3915 | |
3916 | if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true)) | |
3917 | gfc_error ("Assignment to contiguous pointer from non-contiguous " | |
3918 | "target at %L", &rvalue->where); | |
3919 | ||
f657024b | 3920 | /* Warn if it is the LHS pointer may lives longer than the RHS target. */ |
73e42eef | 3921 | if (warn_target_lifetime |
f657024b TB |
3922 | && rvalue->expr_type == EXPR_VARIABLE |
3923 | && !rvalue->symtree->n.sym->attr.save | |
c11384aa JW |
3924 | && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer |
3925 | && !rvalue->symtree->n.sym->attr.host_assoc | |
f657024b TB |
3926 | && !rvalue->symtree->n.sym->attr.in_common |
3927 | && !rvalue->symtree->n.sym->attr.use_assoc | |
3928 | && !rvalue->symtree->n.sym->attr.dummy) | |
3929 | { | |
3930 | bool warn; | |
3931 | gfc_namespace *ns; | |
3932 | ||
3933 | warn = lvalue->symtree->n.sym->attr.dummy | |
3934 | || lvalue->symtree->n.sym->attr.result | |
ed0ba472 | 3935 | || lvalue->symtree->n.sym->attr.function |
916bad55 TB |
3936 | || (lvalue->symtree->n.sym->attr.host_assoc |
3937 | && lvalue->symtree->n.sym->ns | |
3938 | != rvalue->symtree->n.sym->ns) | |
f657024b TB |
3939 | || lvalue->symtree->n.sym->attr.use_assoc |
3940 | || lvalue->symtree->n.sym->attr.in_common; | |
3941 | ||
3942 | if (rvalue->symtree->n.sym->ns->proc_name | |
3943 | && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE | |
3944 | && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) | |
3945 | for (ns = rvalue->symtree->n.sym->ns; | |
1216b4d2 | 3946 | ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; |
f657024b TB |
3947 | ns = ns->parent) |
3948 | if (ns->parent == lvalue->symtree->n.sym->ns) | |
502af491 PCC |
3949 | { |
3950 | warn = true; | |
3951 | break; | |
3952 | } | |
f657024b TB |
3953 | |
3954 | if (warn) | |
48749dbc MLI |
3955 | gfc_warning (OPT_Wtarget_lifetime, |
3956 | "Pointer at %L in pointer assignment might outlive the " | |
f657024b TB |
3957 | "pointer target", &lvalue->where); |
3958 | } | |
3959 | ||
524af0d6 | 3960 | return true; |
6de9cd9a DN |
3961 | } |
3962 | ||
3963 | ||
3964 | /* Relative of gfc_check_assign() except that the lvalue is a single | |
597073ac | 3965 | symbol. Used for initialization assignments. */ |
6de9cd9a | 3966 | |
524af0d6 | 3967 | bool |
e35e87dc | 3968 | gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) |
6de9cd9a DN |
3969 | { |
3970 | gfc_expr lvalue; | |
524af0d6 | 3971 | bool r; |
e35e87dc | 3972 | bool pointer, proc_pointer; |
6de9cd9a DN |
3973 | |
3974 | memset (&lvalue, '\0', sizeof (gfc_expr)); | |
3975 | ||
3976 | lvalue.expr_type = EXPR_VARIABLE; | |
3977 | lvalue.ts = sym->ts; | |
3978 | if (sym->as) | |
3979 | lvalue.rank = sym->as->rank; | |
93acb62c | 3980 | lvalue.symtree = XCNEW (gfc_symtree); |
6de9cd9a DN |
3981 | lvalue.symtree->n.sym = sym; |
3982 | lvalue.where = sym->declared_at; | |
3983 | ||
e35e87dc TB |
3984 | if (comp) |
3985 | { | |
3986 | lvalue.ref = gfc_get_ref (); | |
3987 | lvalue.ref->type = REF_COMPONENT; | |
3988 | lvalue.ref->u.c.component = comp; | |
3989 | lvalue.ref->u.c.sym = sym; | |
3990 | lvalue.ts = comp->ts; | |
3991 | lvalue.rank = comp->as ? comp->as->rank : 0; | |
3992 | lvalue.where = comp->loc; | |
3993 | pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) | |
3994 | ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; | |
3995 | proc_pointer = comp->attr.proc_pointer; | |
3996 | } | |
3997 | else | |
3998 | { | |
3999 | pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) | |
4000 | ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; | |
4001 | proc_pointer = sym->attr.proc_pointer; | |
4002 | } | |
4003 | ||
4004 | if (pointer || proc_pointer) | |
597073ac PB |
4005 | r = gfc_check_pointer_assign (&lvalue, rvalue); |
4006 | else | |
3e6ab828 SK |
4007 | { |
4008 | /* If a conversion function, e.g., __convert_i8_i4, was inserted | |
4009 | into an array constructor, we should check if it can be reduced | |
4010 | as an initialization expression. */ | |
4011 | if (rvalue->expr_type == EXPR_FUNCTION | |
4012 | && rvalue->value.function.isym | |
4013 | && (rvalue->value.function.isym->conversion == 1)) | |
4014 | gfc_check_init_expr (rvalue); | |
4015 | ||
4016 | r = gfc_check_assign (&lvalue, rvalue, 1); | |
4017 | } | |
6de9cd9a | 4018 | |
cede9502 | 4019 | free (lvalue.symtree); |
e3816ac9 | 4020 | free (lvalue.ref); |
6de9cd9a | 4021 | |
524af0d6 | 4022 | if (!r) |
80f95228 | 4023 | return r; |
8b704316 | 4024 | |
e35e87dc | 4025 | if (pointer && rvalue->expr_type != EXPR_NULL) |
80f95228 JW |
4026 | { |
4027 | /* F08:C461. Additional checks for pointer initialization. */ | |
4028 | symbol_attribute attr; | |
4029 | attr = gfc_expr_attr (rvalue); | |
4030 | if (attr.allocatable) | |
4031 | { | |
e35e87dc TB |
4032 | gfc_error ("Pointer initialization target at %L " |
4033 | "must not be ALLOCATABLE", &rvalue->where); | |
524af0d6 | 4034 | return false; |
80f95228 | 4035 | } |
7522a064 | 4036 | if (!attr.target || attr.pointer) |
80f95228 | 4037 | { |
e35e87dc TB |
4038 | gfc_error ("Pointer initialization target at %L " |
4039 | "must have the TARGET attribute", &rvalue->where); | |
524af0d6 | 4040 | return false; |
80f95228 | 4041 | } |
e35e87dc TB |
4042 | |
4043 | if (!attr.save && rvalue->expr_type == EXPR_VARIABLE | |
4044 | && rvalue->symtree->n.sym->ns->proc_name | |
4045 | && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) | |
4046 | { | |
4047 | rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; | |
4048 | attr.save = SAVE_IMPLICIT; | |
4049 | } | |
4050 | ||
80f95228 JW |
4051 | if (!attr.save) |
4052 | { | |
e35e87dc TB |
4053 | gfc_error ("Pointer initialization target at %L " |
4054 | "must have the SAVE attribute", &rvalue->where); | |
524af0d6 | 4055 | return false; |
80f95228 JW |
4056 | } |
4057 | } | |
8b704316 | 4058 | |
e35e87dc | 4059 | if (proc_pointer && rvalue->expr_type != EXPR_NULL) |
7522a064 JW |
4060 | { |
4061 | /* F08:C1220. Additional checks for procedure pointer initialization. */ | |
4062 | symbol_attribute attr = gfc_expr_attr (rvalue); | |
4063 | if (attr.proc_pointer) | |
4064 | { | |
4065 | gfc_error ("Procedure pointer initialization target at %L " | |
4066 | "may not be a procedure pointer", &rvalue->where); | |
524af0d6 | 4067 | return false; |
7522a064 JW |
4068 | } |
4069 | } | |
80f95228 | 4070 | |
524af0d6 | 4071 | return true; |
6de9cd9a | 4072 | } |
54b4ba60 | 4073 | |
13051352 FR |
4074 | /* Invoke gfc_build_init_expr to create an initializer expression, but do not |
4075 | * require that an expression be built. */ | |
4076 | ||
4077 | gfc_expr * | |
4078 | gfc_build_default_init_expr (gfc_typespec *ts, locus *where) | |
4079 | { | |
4080 | return gfc_build_init_expr (ts, where, false); | |
4081 | } | |
54b4ba60 | 4082 | |
7fc61626 FR |
4083 | /* Build an initializer for a local integer, real, complex, logical, or |
4084 | character variable, based on the command line flags finit-local-zero, | |
13051352 FR |
4085 | finit-integer=, finit-real=, finit-logical=, and finit-character=. |
4086 | With force, an initializer is ALWAYS generated. */ | |
7fc61626 FR |
4087 | |
4088 | gfc_expr * | |
13051352 | 4089 | gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) |
7fc61626 | 4090 | { |
7fc61626 | 4091 | gfc_expr *init_expr; |
7fc61626 FR |
4092 | |
4093 | /* Try to build an initializer expression. */ | |
4094 | init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); | |
4095 | ||
13051352 FR |
4096 | /* If we want to force generation, make sure we default to zero. */ |
4097 | gfc_init_local_real init_real = flag_init_real; | |
4098 | int init_logical = gfc_option.flag_init_logical; | |
4099 | if (force) | |
4100 | { | |
4101 | if (init_real == GFC_INIT_REAL_OFF) | |
4102 | init_real = GFC_INIT_REAL_ZERO; | |
4103 | if (init_logical == GFC_INIT_LOGICAL_OFF) | |
4104 | init_logical = GFC_INIT_LOGICAL_FALSE; | |
4105 | } | |
4106 | ||
7fc61626 FR |
4107 | /* We will only initialize integers, reals, complex, logicals, and |
4108 | characters, and only if the corresponding command-line flags | |
4109 | were set. Otherwise, we free init_expr and return null. */ | |
4110 | switch (ts->type) | |
4111 | { | |
4112 | case BT_INTEGER: | |
13051352 | 4113 | if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) |
7fc61626 FR |
4114 | mpz_set_si (init_expr->value.integer, |
4115 | gfc_option.flag_init_integer_value); | |
4116 | else | |
4117 | { | |
4118 | gfc_free_expr (init_expr); | |
4119 | init_expr = NULL; | |
4120 | } | |
4121 | break; | |
4122 | ||
4123 | case BT_REAL: | |
13051352 | 4124 | switch (init_real) |
7fc61626 FR |
4125 | { |
4126 | case GFC_INIT_REAL_SNAN: | |
4127 | init_expr->is_snan = 1; | |
4128 | /* Fall through. */ | |
4129 | case GFC_INIT_REAL_NAN: | |
4130 | mpfr_set_nan (init_expr->value.real); | |
4131 | break; | |
4132 | ||
4133 | case GFC_INIT_REAL_INF: | |
4134 | mpfr_set_inf (init_expr->value.real, 1); | |
4135 | break; | |
4136 | ||
4137 | case GFC_INIT_REAL_NEG_INF: | |
4138 | mpfr_set_inf (init_expr->value.real, -1); | |
4139 | break; | |
4140 | ||
4141 | case GFC_INIT_REAL_ZERO: | |
4142 | mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE); | |
4143 | break; | |
4144 | ||
4145 | default: | |
4146 | gfc_free_expr (init_expr); | |
4147 | init_expr = NULL; | |
4148 | break; | |
4149 | } | |
4150 | break; | |
4151 | ||
4152 | case BT_COMPLEX: | |
13051352 | 4153 | switch (init_real) |
7fc61626 FR |
4154 | { |
4155 | case GFC_INIT_REAL_SNAN: | |
4156 | init_expr->is_snan = 1; | |
4157 | /* Fall through. */ | |
4158 | case GFC_INIT_REAL_NAN: | |
4159 | mpfr_set_nan (mpc_realref (init_expr->value.complex)); | |
4160 | mpfr_set_nan (mpc_imagref (init_expr->value.complex)); | |
4161 | break; | |
4162 | ||
4163 | case GFC_INIT_REAL_INF: | |
4164 | mpfr_set_inf (mpc_realref (init_expr->value.complex), 1); | |
4165 | mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1); | |
4166 | break; | |
4167 | ||
4168 | case GFC_INIT_REAL_NEG_INF: | |
4169 | mpfr_set_inf (mpc_realref (init_expr->value.complex), -1); | |
4170 | mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1); | |
4171 | break; | |
4172 | ||
4173 | case GFC_INIT_REAL_ZERO: | |
4174 | mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); | |
4175 | break; | |
4176 | ||
4177 | default: | |
4178 | gfc_free_expr (init_expr); | |
4179 | init_expr = NULL; | |
4180 | break; | |
4181 | } | |
4182 | break; | |
4183 | ||
4184 | case BT_LOGICAL: | |
13051352 | 4185 | if (init_logical == GFC_INIT_LOGICAL_FALSE) |
7fc61626 | 4186 | init_expr->value.logical = 0; |
13051352 | 4187 | else if (init_logical == GFC_INIT_LOGICAL_TRUE) |
7fc61626 FR |
4188 | init_expr->value.logical = 1; |
4189 | else | |
4190 | { | |
4191 | gfc_free_expr (init_expr); | |
4192 | init_expr = NULL; | |
4193 | } | |
4194 | break; | |
4195 | ||
4196 | case BT_CHARACTER: | |
4197 | /* For characters, the length must be constant in order to | |
4198 | create a default initializer. */ | |
13051352 | 4199 | if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) |
7fc61626 FR |
4200 | && ts->u.cl->length |
4201 | && ts->u.cl->length->expr_type == EXPR_CONSTANT) | |
4202 | { | |
6b271a2e | 4203 | HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); |
7fc61626 FR |
4204 | init_expr->value.character.length = char_len; |
4205 | init_expr->value.character.string = gfc_get_wide_string (char_len+1); | |
6b271a2e | 4206 | for (size_t i = 0; i < (size_t) char_len; i++) |
7fc61626 FR |
4207 | init_expr->value.character.string[i] |
4208 | = (unsigned char) gfc_option.flag_init_character_value; | |
4209 | } | |
4210 | else | |
4211 | { | |
4212 | gfc_free_expr (init_expr); | |
4213 | init_expr = NULL; | |
4214 | } | |
13051352 FR |
4215 | if (!init_expr |
4216 | && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) | |
7fc61626 FR |
4217 | && ts->u.cl->length && flag_max_stack_var_size != 0) |
4218 | { | |
4219 | gfc_actual_arglist *arg; | |
4220 | init_expr = gfc_get_expr (); | |
4221 | init_expr->where = *where; | |
4222 | init_expr->ts = *ts; | |
4223 | init_expr->expr_type = EXPR_FUNCTION; | |
4224 | init_expr->value.function.isym = | |
4225 | gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); | |
4226 | init_expr->value.function.name = "repeat"; | |
4227 | arg = gfc_get_actual_arglist (); | |
4228 | arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1); | |
4229 | arg->expr->value.character.string[0] = | |
4230 | gfc_option.flag_init_character_value; | |
4231 | arg->next = gfc_get_actual_arglist (); | |
4232 | arg->next->expr = gfc_copy_expr (ts->u.cl->length); | |
4233 | init_expr->value.function.actual = arg; | |
4234 | } | |
4235 | break; | |
4236 | ||
4237 | default: | |
4238 | gfc_free_expr (init_expr); | |
4239 | init_expr = NULL; | |
4240 | } | |
4241 | ||
4242 | return init_expr; | |
4243 | } | |
4244 | ||
4245 | /* Apply an initialization expression to a typespec. Can be used for symbols or | |
4246 | components. Similar to add_init_expr_to_sym in decl.c; could probably be | |
4247 | combined with some effort. */ | |
4248 | ||
4249 | void | |
4250 | gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) | |
4251 | { | |
4252 | if (ts->type == BT_CHARACTER && !attr->pointer && init | |
4253 | && ts->u.cl | |
4254 | && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT) | |
4255 | { | |
7fc61626 FR |
4256 | gcc_assert (ts->u.cl && ts->u.cl->length); |
4257 | gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT); | |
4258 | gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER); | |
4259 | ||
6b271a2e | 4260 | HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); |
7fc61626 FR |
4261 | |
4262 | if (init->expr_type == EXPR_CONSTANT) | |
4263 | gfc_set_constant_character_len (len, init, -1); | |
4264 | else if (init | |
aefd636b | 4265 | && init->ts.type == BT_CHARACTER |
fcf79237 | 4266 | && init->ts.u.cl && init->ts.u.cl->length |
7fc61626 FR |
4267 | && mpz_cmp (ts->u.cl->length->value.integer, |
4268 | init->ts.u.cl->length->value.integer)) | |
4269 | { | |
4270 | gfc_constructor *ctor; | |
4271 | ctor = gfc_constructor_first (init->value.constructor); | |
4272 | ||
4273 | if (ctor) | |
4274 | { | |
7fc61626 FR |
4275 | bool has_ts = (init->ts.u.cl |
4276 | && init->ts.u.cl->length_from_typespec); | |
4277 | ||
4278 | /* Remember the length of the first element for checking | |
4279 | that all elements *in the constructor* have the same | |
4280 | length. This need not be the length of the LHS! */ | |
4281 | gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); | |
4282 | gcc_assert (ctor->expr->ts.type == BT_CHARACTER); | |
6b271a2e | 4283 | gfc_charlen_t first_len = ctor->expr->value.character.length; |
7fc61626 FR |
4284 | |
4285 | for ( ; ctor; ctor = gfc_constructor_next (ctor)) | |
4286 | if (ctor->expr->expr_type == EXPR_CONSTANT) | |
4287 | { | |
4288 | gfc_set_constant_character_len (len, ctor->expr, | |
4289 | has_ts ? -1 : first_len); | |
7e98cccb SK |
4290 | if (!ctor->expr->ts.u.cl) |
4291 | ctor->expr->ts.u.cl | |
4292 | = gfc_new_charlen (gfc_current_ns, ts->u.cl); | |
4293 | else | |
4294 | ctor->expr->ts.u.cl->length | |
4295 | = gfc_copy_expr (ts->u.cl->length); | |
7fc61626 FR |
4296 | } |
4297 | } | |
4298 | } | |
4299 | } | |
4300 | } | |
4301 | ||
4302 | ||
cc03bf7a AV |
4303 | /* Check whether an expression is a structure constructor and whether it has |
4304 | other values than NULL. */ | |
4305 | ||
4306 | bool | |
4307 | is_non_empty_structure_constructor (gfc_expr * e) | |
4308 | { | |
4309 | if (e->expr_type != EXPR_STRUCTURE) | |
4310 | return false; | |
4311 | ||
4312 | gfc_constructor *cons = gfc_constructor_first (e->value.constructor); | |
4313 | while (cons) | |
4314 | { | |
4315 | if (!cons->expr || cons->expr->expr_type != EXPR_NULL) | |
4316 | return true; | |
4317 | cons = gfc_constructor_next (cons); | |
4318 | } | |
4319 | return false; | |
4320 | } | |
4321 | ||
4322 | ||
16e520b6 DF |
4323 | /* Check for default initializer; sym->value is not enough |
4324 | as it is also set for EXPR_NULL of allocatables. */ | |
4325 | ||
4326 | bool | |
4327 | gfc_has_default_initializer (gfc_symbol *der) | |
4328 | { | |
4329 | gfc_component *c; | |
4330 | ||
f6288c24 | 4331 | gcc_assert (gfc_fl_struct (der->attr.flavor)); |
16e520b6 | 4332 | for (c = der->components; c; c = c->next) |
f6288c24 | 4333 | if (gfc_bt_struct (c->ts.type)) |
16e520b6 | 4334 | { |
33247762 | 4335 | if (!c->attr.pointer && !c->attr.proc_pointer |
bf9f15ee | 4336 | && !(c->attr.allocatable && der == c->ts.u.derived) |
cc03bf7a AV |
4337 | && ((c->initializer |
4338 | && is_non_empty_structure_constructor (c->initializer)) | |
4339 | || gfc_has_default_initializer (c->ts.u.derived))) | |
16e520b6 | 4340 | return true; |
0173c67b TB |
4341 | if (c->attr.pointer && c->initializer) |
4342 | return true; | |
16e520b6 DF |
4343 | } |
4344 | else | |
4345 | { | |
4346 | if (c->initializer) | |
4347 | return true; | |
4348 | } | |
4349 | ||
4350 | return false; | |
4351 | } | |
4352 | ||
0173c67b | 4353 | |
f8da53e0 FR |
4354 | /* |
4355 | Generate an initializer expression which initializes the entirety of a union. | |
4356 | A normal structure constructor is insufficient without undue effort, because | |
4357 | components of maps may be oddly aligned/overlapped. (For example if a | |
4358 | character is initialized from one map overtop a real from the other, only one | |
4359 | byte of the real is actually initialized.) Unfortunately we don't know the | |
4360 | size of the union right now, so we can't generate a proper initializer, but | |
4361 | we use a NULL expr as a placeholder and do the right thing later in | |
4362 | gfc_trans_subcomponent_assign. | |
4363 | */ | |
4364 | static gfc_expr * | |
4365 | generate_union_initializer (gfc_component *un) | |
4366 | { | |
4367 | if (un == NULL || un->ts.type != BT_UNION) | |
4368 | return NULL; | |
4369 | ||
4370 | gfc_expr *placeholder = gfc_get_null_expr (&un->loc); | |
4371 | placeholder->ts = un->ts; | |
4372 | return placeholder; | |
4373 | } | |
4374 | ||
4375 | ||
4376 | /* Get the user-specified initializer for a union, if any. This means the user | |
4377 | has said to initialize component(s) of a map. For simplicity's sake we | |
4378 | only allow the user to initialize the first map. We don't have to worry | |
4379 | about overlapping initializers as they are released early in resolution (see | |
4380 | resolve_fl_struct). */ | |
4381 | ||
4382 | static gfc_expr * | |
4383 | get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) | |
4384 | { | |
4385 | gfc_component *map; | |
4386 | gfc_expr *init=NULL; | |
4387 | ||
4388 | if (!union_type || union_type->attr.flavor != FL_UNION) | |
4389 | return NULL; | |
4390 | ||
4391 | for (map = union_type->components; map; map = map->next) | |
4392 | { | |
4393 | if (gfc_has_default_initializer (map->ts.u.derived)) | |
4394 | { | |
4395 | init = gfc_default_initializer (&map->ts); | |
4396 | if (map_p) | |
4397 | *map_p = map; | |
4398 | break; | |
4399 | } | |
4400 | } | |
4401 | ||
4402 | if (map_p && !init) | |
4403 | *map_p = NULL; | |
4404 | ||
4405 | return init; | |
4406 | } | |
4407 | ||
7fc61626 FR |
4408 | /* Fetch or generate an initializer for the given component. |
4409 | Only generate an initializer if generate is true. */ | |
4410 | ||
4411 | static gfc_expr * | |
4412 | component_initializer (gfc_typespec *ts, gfc_component *c, bool generate) | |
4413 | { | |
4414 | gfc_expr *init = NULL; | |
4415 | ||
e5b1f5a1 FR |
4416 | /* See if we can find the initializer immediately. |
4417 | Some components should never get initializers. */ | |
7fc61626 | 4418 | if (c->initializer || !generate |
e5b1f5a1 FR |
4419 | || (ts->type == BT_CLASS && !c->attr.allocatable) |
4420 | || c->attr.pointer | |
4421 | || c->attr.class_pointer | |
4422 | || c->attr.proc_pointer) | |
7fc61626 FR |
4423 | return c->initializer; |
4424 | ||
4425 | /* Recursively handle derived type components. */ | |
4426 | if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) | |
4427 | init = gfc_generate_initializer (&c->ts, true); | |
4428 | ||
f8da53e0 FR |
4429 | else if (c->ts.type == BT_UNION && c->ts.u.derived->components) |
4430 | { | |
4431 | gfc_component *map = NULL; | |
4432 | gfc_constructor *ctor; | |
4433 | gfc_expr *user_init; | |
4434 | ||
4435 | /* If we don't have a user initializer and we aren't generating one, this | |
4436 | union has no initializer. */ | |
4437 | user_init = get_union_initializer (c->ts.u.derived, &map); | |
4438 | if (!user_init && !generate) | |
4439 | return NULL; | |
4440 | ||
4441 | /* Otherwise use a structure constructor. */ | |
4442 | init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, | |
4443 | &c->loc); | |
4444 | init->ts = c->ts; | |
4445 | ||
4446 | /* If we are to generate an initializer for the union, add a constructor | |
4447 | which initializes the whole union first. */ | |
4448 | if (generate) | |
4449 | { | |
4450 | ctor = gfc_constructor_get (); | |
4451 | ctor->expr = generate_union_initializer (c); | |
4452 | gfc_constructor_append (&init->value.constructor, ctor); | |
4453 | } | |
4454 | ||
4455 | /* If we found an initializer in one of our maps, apply it. Note this | |
4456 | is applied _after_ the entire-union initializer above if any. */ | |
4457 | if (user_init) | |
4458 | { | |
4459 | ctor = gfc_constructor_get (); | |
4460 | ctor->expr = user_init; | |
4461 | ctor->n.component = map; | |
4462 | gfc_constructor_append (&init->value.constructor, ctor); | |
4463 | } | |
4464 | } | |
4465 | ||
7fc61626 FR |
4466 | /* Treat simple components like locals. */ |
4467 | else | |
4468 | { | |
13051352 FR |
4469 | /* We MUST give an initializer, so force generation. */ |
4470 | init = gfc_build_init_expr (&c->ts, &c->loc, true); | |
7fc61626 FR |
4471 | gfc_apply_init (&c->ts, &c->attr, init); |
4472 | } | |
4473 | ||
4474 | return init; | |
4475 | } | |
4476 | ||
4477 | ||
4478 | /* Get an expression for a default initializer of a derived type. */ | |
54b4ba60 PB |
4479 | |
4480 | gfc_expr * | |
4481 | gfc_default_initializer (gfc_typespec *ts) | |
4482 | { | |
7fc61626 FR |
4483 | return gfc_generate_initializer (ts, false); |
4484 | } | |
4485 | ||
4486 | ||
bf9f15ee | 4487 | /* Get or generate an expression for a default initializer of a derived type. |
7fc61626 FR |
4488 | If -finit-derived is specified, generate default initialization expressions |
4489 | for components that lack them when generate is set. */ | |
4490 | ||
4491 | gfc_expr * | |
4492 | gfc_generate_initializer (gfc_typespec *ts, bool generate) | |
4493 | { | |
4494 | gfc_expr *init, *tmp; | |
b7e75771 | 4495 | gfc_component *comp; |
7fc61626 | 4496 | generate = flag_init_derived && generate; |
54b4ba60 | 4497 | |
16e520b6 | 4498 | /* See if we have a default initializer in this, but not in nested |
7fc61626 FR |
4499 | types (otherwise we could use gfc_has_default_initializer()). |
4500 | We don't need to check if we are going to generate them. */ | |
4501 | comp = ts->u.derived->components; | |
4502 | if (!generate) | |
4503 | { | |
4504 | for (; comp; comp = comp->next) | |
4505 | if (comp->initializer || comp->attr.allocatable | |
4506 | || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) | |
4507 | && CLASS_DATA (comp)->attr.allocatable)) | |
4508 | break; | |
4509 | } | |
54b4ba60 | 4510 | |
b7e75771 | 4511 | if (!comp) |
54b4ba60 PB |
4512 | return NULL; |
4513 | ||
b7e75771 JD |
4514 | init = gfc_get_structure_constructor_expr (ts->type, ts->kind, |
4515 | &ts->u.derived->declared_at); | |
54b4ba60 | 4516 | init->ts = *ts; |
7e49f965 | 4517 | |
b7e75771 | 4518 | for (comp = ts->u.derived->components; comp; comp = comp->next) |
54b4ba60 | 4519 | { |
b7e75771 | 4520 | gfc_constructor *ctor = gfc_constructor_get(); |
54b4ba60 | 4521 | |
7fc61626 FR |
4522 | /* Fetch or generate an initializer for the component. */ |
4523 | tmp = component_initializer (ts, comp, generate); | |
4524 | if (tmp) | |
0b673c09 | 4525 | { |
e75eb64f FR |
4526 | /* Save the component ref for STRUCTUREs and UNIONs. */ |
4527 | if (ts->u.derived->attr.flavor == FL_STRUCT | |
4528 | || ts->u.derived->attr.flavor == FL_UNION) | |
4529 | ctor->n.component = comp; | |
7fc61626 FR |
4530 | |
4531 | /* If the initializer was not generated, we need a copy. */ | |
4532 | ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; | |
4533 | if ((comp->ts.type != tmp->ts.type | |
4534 | || comp->ts.kind != tmp->ts.kind) | |
0b673c09 | 4535 | && !comp->attr.pointer && !comp->attr.proc_pointer) |
0735a1c8 SK |
4536 | { |
4537 | bool val; | |
4538 | val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); | |
4539 | if (val == false) | |
4540 | return NULL; | |
4541 | } | |
0b673c09 | 4542 | } |
5046aff5 | 4543 | |
fbd30c38 JW |
4544 | if (comp->attr.allocatable |
4545 | || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) | |
5046aff5 | 4546 | { |
b7e75771 JD |
4547 | ctor->expr = gfc_get_expr (); |
4548 | ctor->expr->expr_type = EXPR_NULL; | |
39b4b34d | 4549 | ctor->expr->where = init->where; |
b7e75771 | 4550 | ctor->expr->ts = comp->ts; |
5046aff5 | 4551 | } |
b7e75771 JD |
4552 | |
4553 | gfc_constructor_append (&init->value.constructor, ctor); | |
54b4ba60 | 4554 | } |
b7e75771 | 4555 | |
54b4ba60 PB |
4556 | return init; |
4557 | } | |
294fbfc8 TS |
4558 | |
4559 | ||
4560 | /* Given a symbol, create an expression node with that symbol as a | |
4561 | variable. If the symbol is array valued, setup a reference of the | |
4562 | whole array. */ | |
4563 | ||
4564 | gfc_expr * | |
636dff67 | 4565 | gfc_get_variable_expr (gfc_symtree *var) |
294fbfc8 TS |
4566 | { |
4567 | gfc_expr *e; | |
4568 | ||
4569 | e = gfc_get_expr (); | |
4570 | e->expr_type = EXPR_VARIABLE; | |
4571 | e->symtree = var; | |
4572 | e->ts = var->n.sym->ts; | |
4573 | ||
1251a8be JW |
4574 | if (var->n.sym->attr.flavor != FL_PROCEDURE |
4575 | && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) | |
4576 | || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym) | |
4577 | && CLASS_DATA (var->n.sym)->as))) | |
294fbfc8 | 4578 | { |
102344e2 TB |
4579 | e->rank = var->n.sym->ts.type == BT_CLASS |
4580 | ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; | |
294fbfc8 TS |
4581 | e->ref = gfc_get_ref (); |
4582 | e->ref->type = REF_ARRAY; | |
4583 | e->ref->u.ar.type = AR_FULL; | |
8f75db9f PT |
4584 | e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS |
4585 | ? CLASS_DATA (var->n.sym)->as | |
4586 | : var->n.sym->as); | |
294fbfc8 TS |
4587 | } |
4588 | ||
4589 | return e; | |
4590 | } | |
4591 | ||
47992a4a | 4592 | |
4d382327 AF |
4593 | /* Adds a full array reference to an expression, as needed. */ |
4594 | ||
4595 | void | |
4596 | gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) | |
4597 | { | |
4598 | gfc_ref *ref; | |
4599 | for (ref = e->ref; ref; ref = ref->next) | |
4600 | if (!ref->next) | |
4601 | break; | |
4602 | if (ref) | |
4603 | { | |
4604 | ref->next = gfc_get_ref (); | |
4605 | ref = ref->next; | |
4606 | } | |
4607 | else | |
4608 | { | |
4609 | e->ref = gfc_get_ref (); | |
4610 | ref = e->ref; | |
4611 | } | |
4612 | ref->type = REF_ARRAY; | |
4613 | ref->u.ar.type = AR_FULL; | |
4614 | ref->u.ar.dimen = e->rank; | |
4615 | ref->u.ar.where = e->where; | |
4616 | ref->u.ar.as = as; | |
4617 | } | |
4618 | ||
4619 | ||
0d87fa8c JW |
4620 | gfc_expr * |
4621 | gfc_lval_expr_from_sym (gfc_symbol *sym) | |
4622 | { | |
4623 | gfc_expr *lval; | |
f3b0bb7a | 4624 | gfc_array_spec *as; |
0d87fa8c JW |
4625 | lval = gfc_get_expr (); |
4626 | lval->expr_type = EXPR_VARIABLE; | |
4627 | lval->where = sym->declared_at; | |
4628 | lval->ts = sym->ts; | |
4629 | lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); | |
4630 | ||
4631 | /* It will always be a full array. */ | |
f3b0bb7a AV |
4632 | as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; |
4633 | lval->rank = as ? as->rank : 0; | |
0d87fa8c | 4634 | if (lval->rank) |
f3b0bb7a | 4635 | gfc_add_full_array_ref (lval, as); |
0d87fa8c JW |
4636 | return lval; |
4637 | } | |
4638 | ||
4639 | ||
b7d1d8b4 PT |
4640 | /* Returns the array_spec of a full array expression. A NULL is |
4641 | returned otherwise. */ | |
4642 | gfc_array_spec * | |
4643 | gfc_get_full_arrayspec_from_expr (gfc_expr *expr) | |
4644 | { | |
4645 | gfc_array_spec *as; | |
4646 | gfc_ref *ref; | |
4647 | ||
4648 | if (expr->rank == 0) | |
4649 | return NULL; | |
4650 | ||
4651 | /* Follow any component references. */ | |
4652 | if (expr->expr_type == EXPR_VARIABLE | |
4653 | || expr->expr_type == EXPR_CONSTANT) | |
4654 | { | |
650f7d09 TK |
4655 | if (expr->symtree) |
4656 | as = expr->symtree->n.sym->as; | |
4657 | else | |
4658 | as = NULL; | |
4659 | ||
b7d1d8b4 PT |
4660 | for (ref = expr->ref; ref; ref = ref->next) |
4661 | { | |
4662 | switch (ref->type) | |
4663 | { | |
4664 | case REF_COMPONENT: | |
4665 | as = ref->u.c.component->as; | |
4666 | continue; | |
4667 | ||
4668 | case REF_SUBSTRING: | |
4669 | continue; | |
4670 | ||
4671 | case REF_ARRAY: | |
4672 | { | |
4673 | switch (ref->u.ar.type) | |
4674 | { | |
4675 | case AR_ELEMENT: | |
4676 | case AR_SECTION: | |
4677 | case AR_UNKNOWN: | |
4678 | as = NULL; | |
4679 | continue; | |
4680 | ||
4681 | case AR_FULL: | |
4682 | break; | |
4683 | } | |
4684 | break; | |
4685 | } | |
4686 | } | |
4687 | } | |
4688 | } | |
4689 | else | |
4690 | as = NULL; | |
4691 | ||
4692 | return as; | |
4693 | } | |
4694 | ||
4695 | ||
640670c7 | 4696 | /* General expression traversal function. */ |
47992a4a | 4697 | |
640670c7 PT |
4698 | bool |
4699 | gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, | |
4700 | bool (*func)(gfc_expr *, gfc_symbol *, int*), | |
4701 | int f) | |
47992a4a | 4702 | { |
640670c7 | 4703 | gfc_array_ref ar; |
47992a4a | 4704 | gfc_ref *ref; |
640670c7 PT |
4705 | gfc_actual_arglist *args; |
4706 | gfc_constructor *c; | |
47992a4a EE |
4707 | int i; |
4708 | ||
640670c7 PT |
4709 | if (!expr) |
4710 | return false; | |
47992a4a | 4711 | |
908a2235 PT |
4712 | if ((*func) (expr, sym, &f)) |
4713 | return true; | |
47992a4a | 4714 | |
908a2235 | 4715 | if (expr->ts.type == BT_CHARACTER |
bc21d315 JW |
4716 | && expr->ts.u.cl |
4717 | && expr->ts.u.cl->length | |
4718 | && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT | |
4719 | && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) | |
908a2235 | 4720 | return true; |
47992a4a | 4721 | |
908a2235 PT |
4722 | switch (expr->expr_type) |
4723 | { | |
687ea68f TB |
4724 | case EXPR_PPC: |
4725 | case EXPR_COMPCALL: | |
640670c7 PT |
4726 | case EXPR_FUNCTION: |
4727 | for (args = expr->value.function.actual; args; args = args->next) | |
4728 | { | |
4729 | if (gfc_traverse_expr (args->expr, sym, func, f)) | |
4730 | return true; | |
4731 | } | |
47992a4a EE |
4732 | break; |
4733 | ||
908a2235 | 4734 | case EXPR_VARIABLE: |
47992a4a EE |
4735 | case EXPR_CONSTANT: |
4736 | case EXPR_NULL: | |
4737 | case EXPR_SUBSTRING: | |
4738 | break; | |
4739 | ||
4740 | case EXPR_STRUCTURE: | |
4741 | case EXPR_ARRAY: | |
b7e75771 JD |
4742 | for (c = gfc_constructor_first (expr->value.constructor); |
4743 | c; c = gfc_constructor_next (c)) | |
908a2235 PT |
4744 | { |
4745 | if (gfc_traverse_expr (c->expr, sym, func, f)) | |
4746 | return true; | |
4747 | if (c->iterator) | |
4748 | { | |
4749 | if (gfc_traverse_expr (c->iterator->var, sym, func, f)) | |
4750 | return true; | |
4751 | if (gfc_traverse_expr (c->iterator->start, sym, func, f)) | |
4752 | return true; | |
4753 | if (gfc_traverse_expr (c->iterator->end, sym, func, f)) | |
4754 | return true; | |
4755 | if (gfc_traverse_expr (c->iterator->step, sym, func, f)) | |
4756 | return true; | |
4757 | } | |
4758 | } | |
47992a4a EE |
4759 | break; |
4760 | ||
640670c7 PT |
4761 | case EXPR_OP: |
4762 | if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) | |
4763 | return true; | |
4764 | if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) | |
4765 | return true; | |
4766 | break; | |
4767 | ||
47992a4a EE |
4768 | default: |
4769 | gcc_unreachable (); | |
4770 | break; | |
4771 | } | |
4772 | ||
640670c7 PT |
4773 | ref = expr->ref; |
4774 | while (ref != NULL) | |
4775 | { | |
47992a4a | 4776 | switch (ref->type) |
636dff67 | 4777 | { |
640670c7 PT |
4778 | case REF_ARRAY: |
4779 | ar = ref->u.ar; | |
4780 | for (i = 0; i < GFC_MAX_DIMENSIONS; i++) | |
636dff67 | 4781 | { |
640670c7 PT |
4782 | if (gfc_traverse_expr (ar.start[i], sym, func, f)) |
4783 | return true; | |
4784 | if (gfc_traverse_expr (ar.end[i], sym, func, f)) | |
4785 | return true; | |
4786 | if (gfc_traverse_expr (ar.stride[i], sym, func, f)) | |
4787 | return true; | |
636dff67 SK |
4788 | } |
4789 | break; | |
640670c7 | 4790 | |
636dff67 | 4791 | case REF_SUBSTRING: |
640670c7 PT |
4792 | if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) |
4793 | return true; | |
4794 | if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) | |
4795 | return true; | |
636dff67 | 4796 | break; |
640670c7 | 4797 | |
908a2235 PT |
4798 | case REF_COMPONENT: |
4799 | if (ref->u.c.component->ts.type == BT_CHARACTER | |
bc21d315 JW |
4800 | && ref->u.c.component->ts.u.cl |
4801 | && ref->u.c.component->ts.u.cl->length | |
4802 | && ref->u.c.component->ts.u.cl->length->expr_type | |
908a2235 | 4803 | != EXPR_CONSTANT |
bc21d315 | 4804 | && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, |
908a2235 PT |
4805 | sym, func, f)) |
4806 | return true; | |
4807 | ||
4808 | if (ref->u.c.component->as) | |
d3a9eea2 TB |
4809 | for (i = 0; i < ref->u.c.component->as->rank |
4810 | + ref->u.c.component->as->corank; i++) | |
908a2235 PT |
4811 | { |
4812 | if (gfc_traverse_expr (ref->u.c.component->as->lower[i], | |
4813 | sym, func, f)) | |
4814 | return true; | |
4815 | if (gfc_traverse_expr (ref->u.c.component->as->upper[i], | |
4816 | sym, func, f)) | |
4817 | return true; | |
4818 | } | |
4819 | break; | |
640670c7 | 4820 | |
636dff67 SK |
4821 | default: |
4822 | gcc_unreachable (); | |
636dff67 | 4823 | } |
640670c7 PT |
4824 | ref = ref->next; |
4825 | } | |
4826 | return false; | |
4827 | } | |
4828 | ||
4829 | /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ | |
4830 | ||
4831 | static bool | |
4832 | expr_set_symbols_referenced (gfc_expr *expr, | |
4833 | gfc_symbol *sym ATTRIBUTE_UNUSED, | |
4834 | int *f ATTRIBUTE_UNUSED) | |
4835 | { | |
908a2235 PT |
4836 | if (expr->expr_type != EXPR_VARIABLE) |
4837 | return false; | |
640670c7 PT |
4838 | gfc_set_sym_referenced (expr->symtree->n.sym); |
4839 | return false; | |
4840 | } | |
4841 | ||
4842 | void | |
4843 | gfc_expr_set_symbols_referenced (gfc_expr *expr) | |
4844 | { | |
4845 | gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); | |
47992a4a | 4846 | } |
f37e928c DK |
4847 | |
4848 | ||
2a573572 MM |
4849 | /* Determine if an expression is a procedure pointer component and return |
4850 | the component in that case. Otherwise return NULL. */ | |
713485cc | 4851 | |
2a573572 MM |
4852 | gfc_component * |
4853 | gfc_get_proc_ptr_comp (gfc_expr *expr) | |
713485cc JW |
4854 | { |
4855 | gfc_ref *ref; | |
713485cc JW |
4856 | |
4857 | if (!expr || !expr->ref) | |
2a573572 | 4858 | return NULL; |
713485cc JW |
4859 | |
4860 | ref = expr->ref; | |
4861 | while (ref->next) | |
4862 | ref = ref->next; | |
4863 | ||
2a573572 MM |
4864 | if (ref->type == REF_COMPONENT |
4865 | && ref->u.c.component->attr.proc_pointer) | |
4866 | return ref->u.c.component; | |
4867 | ||
4868 | return NULL; | |
4869 | } | |
4870 | ||
713485cc | 4871 | |
2a573572 MM |
4872 | /* Determine if an expression is a procedure pointer component. */ |
4873 | ||
4874 | bool | |
4875 | gfc_is_proc_ptr_comp (gfc_expr *expr) | |
4876 | { | |
4877 | return (gfc_get_proc_ptr_comp (expr) != NULL); | |
713485cc JW |
4878 | } |
4879 | ||
4880 | ||
43a68a9d PT |
4881 | /* Determine if an expression is a function with an allocatable class scalar |
4882 | result. */ | |
4883 | bool | |
4884 | gfc_is_alloc_class_scalar_function (gfc_expr *expr) | |
4885 | { | |
4886 | if (expr->expr_type == EXPR_FUNCTION | |
4887 | && expr->value.function.esym | |
4888 | && expr->value.function.esym->result | |
4889 | && expr->value.function.esym->result->ts.type == BT_CLASS | |
4890 | && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension | |
4891 | && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) | |
4892 | return true; | |
4893 | ||
4894 | return false; | |
4895 | } | |
4896 | ||
4897 | ||
4898 | /* Determine if an expression is a function with an allocatable class array | |
4899 | result. */ | |
4900 | bool | |
a6b22eea | 4901 | gfc_is_class_array_function (gfc_expr *expr) |
43a68a9d PT |
4902 | { |
4903 | if (expr->expr_type == EXPR_FUNCTION | |
4904 | && expr->value.function.esym | |
4905 | && expr->value.function.esym->result | |
4906 | && expr->value.function.esym->result->ts.type == BT_CLASS | |
4907 | && CLASS_DATA (expr->value.function.esym->result)->attr.dimension | |
a6b22eea PT |
4908 | && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable |
4909 | || CLASS_DATA (expr->value.function.esym->result)->attr.pointer)) | |
43a68a9d PT |
4910 | return true; |
4911 | ||
4912 | return false; | |
4913 | } | |
4914 | ||
4915 | ||
f37e928c DK |
4916 | /* Walk an expression tree and check each variable encountered for being typed. |
4917 | If strict is not set, a top-level variable is tolerated untyped in -std=gnu | |
ed42adef DK |
4918 | mode as is a basic arithmetic expression using those; this is for things in |
4919 | legacy-code like: | |
f37e928c DK |
4920 | |
4921 | INTEGER :: arr(n), n | |
ed42adef | 4922 | INTEGER :: arr(n + 1), n |
f37e928c DK |
4923 | |
4924 | The namespace is needed for IMPLICIT typing. */ | |
4925 | ||
3df684e2 DK |
4926 | static gfc_namespace* check_typed_ns; |
4927 | ||
4928 | static bool | |
4929 | expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, | |
4930 | int* f ATTRIBUTE_UNUSED) | |
f37e928c | 4931 | { |
524af0d6 | 4932 | bool t; |
f37e928c | 4933 | |
3df684e2 DK |
4934 | if (e->expr_type != EXPR_VARIABLE) |
4935 | return false; | |
f37e928c | 4936 | |
3df684e2 DK |
4937 | gcc_assert (e->symtree); |
4938 | t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, | |
4939 | true, e->where); | |
f37e928c | 4940 | |
524af0d6 | 4941 | return (!t); |
3df684e2 | 4942 | } |
f37e928c | 4943 | |
524af0d6 | 4944 | bool |
3df684e2 DK |
4945 | gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) |
4946 | { | |
4947 | bool error_found; | |
f37e928c | 4948 | |
ed42adef DK |
4949 | /* If this is a top-level variable or EXPR_OP, do the check with strict given |
4950 | to us. */ | |
4951 | if (!strict) | |
4952 | { | |
4953 | if (e->expr_type == EXPR_VARIABLE && !e->ref) | |
4954 | return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); | |
4955 | ||
4956 | if (e->expr_type == EXPR_OP) | |
4957 | { | |
524af0d6 | 4958 | bool t = true; |
ed42adef DK |
4959 | |
4960 | gcc_assert (e->value.op.op1); | |
4961 | t = gfc_expr_check_typed (e->value.op.op1, ns, strict); | |
4962 | ||
524af0d6 | 4963 | if (t && e->value.op.op2) |
ed42adef DK |
4964 | t = gfc_expr_check_typed (e->value.op.op2, ns, strict); |
4965 | ||
4966 | return t; | |
4967 | } | |
4968 | } | |
f37e928c | 4969 | |
3df684e2 DK |
4970 | /* Otherwise, walk the expression and do it strictly. */ |
4971 | check_typed_ns = ns; | |
4972 | error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); | |
f37e928c | 4973 | |
524af0d6 | 4974 | return error_found ? false : true; |
f37e928c | 4975 | } |
c6acea9d | 4976 | |
4e5d3db2 | 4977 | |
5bab4c96 PT |
4978 | /* This function returns true if it contains any references to PDT KIND |
4979 | or LEN parameters. */ | |
4980 | ||
4981 | static bool | |
4982 | derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, | |
4983 | int* f ATTRIBUTE_UNUSED) | |
4984 | { | |
4985 | if (e->expr_type != EXPR_VARIABLE) | |
4986 | return false; | |
4987 | ||
4988 | gcc_assert (e->symtree); | |
4989 | if (e->symtree->n.sym->attr.pdt_kind | |
4990 | || e->symtree->n.sym->attr.pdt_len) | |
4991 | return true; | |
4992 | ||
4993 | return false; | |
4994 | } | |
4995 | ||
4996 | ||
4997 | bool | |
4998 | gfc_derived_parameter_expr (gfc_expr *e) | |
4999 | { | |
5000 | return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0); | |
5001 | } | |
5002 | ||
5003 | ||
5004 | /* This function returns the overall type of a type parameter spec list. | |
5005 | If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the | |
5006 | parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned | |
5007 | unless derived is not NULL. In this latter case, all the LEN parameters | |
5008 | must be either assumed or deferred for the return argument to be set to | |
5009 | anything other than SPEC_EXPLICIT. */ | |
5010 | ||
5011 | gfc_param_spec_type | |
5012 | gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) | |
5013 | { | |
5014 | gfc_param_spec_type res = SPEC_EXPLICIT; | |
5015 | gfc_component *c; | |
5016 | bool seen_assumed = false; | |
5017 | bool seen_deferred = false; | |
5018 | ||
5019 | if (derived == NULL) | |
5020 | { | |
5021 | for (; param_list; param_list = param_list->next) | |
5022 | if (param_list->spec_type == SPEC_ASSUMED | |
5023 | || param_list->spec_type == SPEC_DEFERRED) | |
5024 | return param_list->spec_type; | |
5025 | } | |
5026 | else | |
5027 | { | |
5028 | for (; param_list; param_list = param_list->next) | |
5029 | { | |
5030 | c = gfc_find_component (derived, param_list->name, | |
5031 | true, true, NULL); | |
5032 | gcc_assert (c != NULL); | |
5033 | if (c->attr.pdt_kind) | |
5034 | continue; | |
5035 | else if (param_list->spec_type == SPEC_EXPLICIT) | |
5036 | return SPEC_EXPLICIT; | |
5037 | seen_assumed = param_list->spec_type == SPEC_ASSUMED; | |
5038 | seen_deferred = param_list->spec_type == SPEC_DEFERRED; | |
5039 | if (seen_assumed && seen_deferred) | |
5040 | return SPEC_EXPLICIT; | |
5041 | } | |
5042 | res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; | |
5043 | } | |
5044 | return res; | |
5045 | } | |
5046 | ||
5047 | ||
badd9e69 TB |
5048 | bool |
5049 | gfc_ref_this_image (gfc_ref *ref) | |
5050 | { | |
5051 | int n; | |
5052 | ||
5053 | gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); | |
5054 | ||
5055 | for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) | |
5056 | if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) | |
5057 | return false; | |
5058 | ||
5059 | return true; | |
5060 | } | |
5061 | ||
20d0bfce AF |
5062 | gfc_expr * |
5063 | gfc_find_stat_co(gfc_expr *e) | |
5064 | { | |
5065 | gfc_ref *ref; | |
5066 | ||
5067 | for (ref = e->ref; ref; ref = ref->next) | |
5068 | if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) | |
5069 | return ref->u.ar.stat; | |
5070 | ||
4971dd80 AV |
5071 | if (e->value.function.actual->expr) |
5072 | for (ref = e->value.function.actual->expr->ref; ref; | |
5073 | ref = ref->next) | |
20d0bfce AF |
5074 | if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) |
5075 | return ref->u.ar.stat; | |
5076 | ||
5077 | return NULL; | |
5078 | } | |
badd9e69 | 5079 | |
d3a9eea2 TB |
5080 | bool |
5081 | gfc_is_coindexed (gfc_expr *e) | |
5082 | { | |
5083 | gfc_ref *ref; | |
5084 | ||
5085 | for (ref = e->ref; ref; ref = ref->next) | |
5086 | if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) | |
badd9e69 | 5087 | return !gfc_ref_this_image (ref); |
d3a9eea2 TB |
5088 | |
5089 | return false; | |
5090 | } | |
5091 | ||
5092 | ||
394d3a2e TB |
5093 | /* Coarrays are variables with a corank but not being coindexed. However, also |
5094 | the following is a coarray: A subobject of a coarray is a coarray if it does | |
5095 | not have any cosubscripts, vector subscripts, allocatable component | |
5096 | selection, or pointer component selection. (F2008, 2.4.7) */ | |
5097 | ||
5098 | bool | |
5099 | gfc_is_coarray (gfc_expr *e) | |
5100 | { | |
5101 | gfc_ref *ref; | |
5102 | gfc_symbol *sym; | |
5103 | gfc_component *comp; | |
5104 | bool coindexed; | |
5105 | bool coarray; | |
5106 | int i; | |
5107 | ||
5108 | if (e->expr_type != EXPR_VARIABLE) | |
5109 | return false; | |
5110 | ||
5111 | coindexed = false; | |
5112 | sym = e->symtree->n.sym; | |
5113 | ||
5114 | if (sym->ts.type == BT_CLASS && sym->attr.class_ok) | |
5115 | coarray = CLASS_DATA (sym)->attr.codimension; | |
5116 | else | |
5117 | coarray = sym->attr.codimension; | |
5118 | ||
5119 | for (ref = e->ref; ref; ref = ref->next) | |
5120 | switch (ref->type) | |
5121 | { | |
5122 | case REF_COMPONENT: | |
5123 | comp = ref->u.c.component; | |
5d81ddd0 TB |
5124 | if (comp->ts.type == BT_CLASS && comp->attr.class_ok |
5125 | && (CLASS_DATA (comp)->attr.class_pointer | |
5126 | || CLASS_DATA (comp)->attr.allocatable)) | |
394d3a2e TB |
5127 | { |
5128 | coindexed = false; | |
5d81ddd0 TB |
5129 | coarray = CLASS_DATA (comp)->attr.codimension; |
5130 | } | |
5131 | else if (comp->attr.pointer || comp->attr.allocatable) | |
5132 | { | |
5133 | coindexed = false; | |
5134 | coarray = comp->attr.codimension; | |
394d3a2e TB |
5135 | } |
5136 | break; | |
5137 | ||
5138 | case REF_ARRAY: | |
5139 | if (!coarray) | |
5140 | break; | |
5141 | ||
5142 | if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) | |
5143 | { | |
5144 | coindexed = true; | |
5145 | break; | |
5146 | } | |
5147 | ||
5148 | for (i = 0; i < ref->u.ar.dimen; i++) | |
5149 | if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) | |
5150 | { | |
5151 | coarray = false; | |
5152 | break; | |
5153 | } | |
5154 | break; | |
5155 | ||
5156 | case REF_SUBSTRING: | |
5157 | break; | |
5158 | } | |
5159 | ||
5160 | return coarray && !coindexed; | |
5161 | } | |
5162 | ||
5163 | ||
4dc694b2 | 5164 | int |
7aa0849a TB |
5165 | gfc_get_corank (gfc_expr *e) |
5166 | { | |
5167 | int corank; | |
5168 | gfc_ref *ref; | |
89010691 MM |
5169 | |
5170 | if (!gfc_is_coarray (e)) | |
5171 | return 0; | |
5172 | ||
c49ea23d PT |
5173 | if (e->ts.type == BT_CLASS && e->ts.u.derived->components) |
5174 | corank = e->ts.u.derived->components->as | |
5175 | ? e->ts.u.derived->components->as->corank : 0; | |
8b704316 | 5176 | else |
c49ea23d | 5177 | corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; |
89010691 | 5178 | |
7aa0849a TB |
5179 | for (ref = e->ref; ref; ref = ref->next) |
5180 | { | |
5181 | if (ref->type == REF_ARRAY) | |
5182 | corank = ref->u.ar.as->corank; | |
5183 | gcc_assert (ref->type != REF_SUBSTRING); | |
5184 | } | |
89010691 | 5185 | |
7aa0849a TB |
5186 | return corank; |
5187 | } | |
5188 | ||
5189 | ||
d3a9eea2 TB |
5190 | /* Check whether the expression has an ultimate allocatable component. |
5191 | Being itself allocatable does not count. */ | |
5192 | bool | |
5193 | gfc_has_ultimate_allocatable (gfc_expr *e) | |
5194 | { | |
5195 | gfc_ref *ref, *last = NULL; | |
5196 | ||
5197 | if (e->expr_type != EXPR_VARIABLE) | |
5198 | return false; | |
5199 | ||
5200 | for (ref = e->ref; ref; ref = ref->next) | |
5201 | if (ref->type == REF_COMPONENT) | |
5202 | last = ref; | |
5203 | ||
5204 | if (last && last->u.c.component->ts.type == BT_CLASS) | |
7a08eda1 | 5205 | return CLASS_DATA (last->u.c.component)->attr.alloc_comp; |
d3a9eea2 TB |
5206 | else if (last && last->u.c.component->ts.type == BT_DERIVED) |
5207 | return last->u.c.component->ts.u.derived->attr.alloc_comp; | |
5208 | else if (last) | |
5209 | return false; | |
5210 | ||
5211 | if (e->ts.type == BT_CLASS) | |
7a08eda1 | 5212 | return CLASS_DATA (e)->attr.alloc_comp; |
d3a9eea2 TB |
5213 | else if (e->ts.type == BT_DERIVED) |
5214 | return e->ts.u.derived->attr.alloc_comp; | |
5215 | else | |
5216 | return false; | |
5217 | } | |
5218 | ||
5219 | ||
5220 | /* Check whether the expression has an pointer component. | |
5221 | Being itself a pointer does not count. */ | |
5222 | bool | |
5223 | gfc_has_ultimate_pointer (gfc_expr *e) | |
5224 | { | |
5225 | gfc_ref *ref, *last = NULL; | |
5226 | ||
5227 | if (e->expr_type != EXPR_VARIABLE) | |
5228 | return false; | |
5229 | ||
5230 | for (ref = e->ref; ref; ref = ref->next) | |
5231 | if (ref->type == REF_COMPONENT) | |
5232 | last = ref; | |
8b704316 | 5233 | |
d3a9eea2 | 5234 | if (last && last->u.c.component->ts.type == BT_CLASS) |
7a08eda1 | 5235 | return CLASS_DATA (last->u.c.component)->attr.pointer_comp; |
d3a9eea2 TB |
5236 | else if (last && last->u.c.component->ts.type == BT_DERIVED) |
5237 | return last->u.c.component->ts.u.derived->attr.pointer_comp; | |
5238 | else if (last) | |
5239 | return false; | |
5240 | ||
5241 | if (e->ts.type == BT_CLASS) | |
7a08eda1 | 5242 | return CLASS_DATA (e)->attr.pointer_comp; |
d3a9eea2 TB |
5243 | else if (e->ts.type == BT_DERIVED) |
5244 | return e->ts.u.derived->attr.pointer_comp; | |
5245 | else | |
5246 | return false; | |
5247 | } | |
fe4e525c TB |
5248 | |
5249 | ||
5250 | /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. | |
5251 | Note: A scalar is not regarded as "simply contiguous" by the standard. | |
eea58adb | 5252 | if bool is not strict, some further checks are done - for instance, |
fe4e525c TB |
5253 | a "(::1)" is accepted. */ |
5254 | ||
5255 | bool | |
460263d0 | 5256 | gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) |
fe4e525c TB |
5257 | { |
5258 | bool colon; | |
5259 | int i; | |
5260 | gfc_array_ref *ar = NULL; | |
5261 | gfc_ref *ref, *part_ref = NULL; | |
c49ea23d | 5262 | gfc_symbol *sym; |
fe4e525c TB |
5263 | |
5264 | if (expr->expr_type == EXPR_FUNCTION) | |
a814e35b TK |
5265 | { |
5266 | if (expr->value.function.esym) | |
5267 | return expr->value.function.esym->result->attr.contiguous; | |
5268 | else | |
5269 | { | |
5270 | /* We have to jump through some hoops if this is a vtab entry. */ | |
5271 | gfc_symbol *s; | |
5272 | gfc_ref *r, *rc; | |
5273 | ||
5274 | s = expr->symtree->n.sym; | |
5275 | if (s->ts.type != BT_CLASS) | |
5276 | return false; | |
5277 | ||
5278 | rc = NULL; | |
5279 | for (r = expr->ref; r; r = r->next) | |
5280 | if (r->type == REF_COMPONENT) | |
5281 | rc = r; | |
5282 | ||
5283 | if (rc == NULL || rc->u.c.component == NULL | |
5284 | || rc->u.c.component->ts.interface == NULL) | |
5285 | return false; | |
5286 | ||
5287 | return rc->u.c.component->ts.interface->attr.contiguous; | |
5288 | } | |
5289 | } | |
fe4e525c TB |
5290 | else if (expr->expr_type != EXPR_VARIABLE) |
5291 | return false; | |
5292 | ||
460263d0 | 5293 | if (!permit_element && expr->rank == 0) |
fe4e525c TB |
5294 | return false; |
5295 | ||
5296 | for (ref = expr->ref; ref; ref = ref->next) | |
5297 | { | |
5298 | if (ar) | |
1cc0e193 | 5299 | return false; /* Array shall be last part-ref. */ |
fe4e525c TB |
5300 | |
5301 | if (ref->type == REF_COMPONENT) | |
5302 | part_ref = ref; | |
5303 | else if (ref->type == REF_SUBSTRING) | |
5304 | return false; | |
5305 | else if (ref->u.ar.type != AR_ELEMENT) | |
5306 | ar = &ref->u.ar; | |
5307 | } | |
5308 | ||
c49ea23d PT |
5309 | sym = expr->symtree->n.sym; |
5310 | if (expr->ts.type != BT_CLASS | |
d4319ef8 SK |
5311 | && ((part_ref |
5312 | && !part_ref->u.c.component->attr.contiguous | |
5313 | && part_ref->u.c.component->attr.pointer) | |
5314 | || (!part_ref | |
5315 | && !sym->attr.contiguous | |
5316 | && (sym->attr.pointer | |
5317 | || (sym->as && sym->as->type == AS_ASSUMED_RANK) | |
5318 | || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))) | |
fe4e525c TB |
5319 | return false; |
5320 | ||
5321 | if (!ar || ar->type == AR_FULL) | |
5322 | return true; | |
5323 | ||
5324 | gcc_assert (ar->type == AR_SECTION); | |
5325 | ||
5326 | /* Check for simply contiguous array */ | |
5327 | colon = true; | |
5328 | for (i = 0; i < ar->dimen; i++) | |
5329 | { | |
5330 | if (ar->dimen_type[i] == DIMEN_VECTOR) | |
5331 | return false; | |
5332 | ||
5333 | if (ar->dimen_type[i] == DIMEN_ELEMENT) | |
5334 | { | |
5335 | colon = false; | |
5336 | continue; | |
5337 | } | |
5338 | ||
5339 | gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); | |
5340 | ||
5341 | ||
5342 | /* If the previous section was not contiguous, that's an error, | |
5343 | unless we have effective only one element and checking is not | |
5344 | strict. */ | |
5345 | if (!colon && (strict || !ar->start[i] || !ar->end[i] | |
5346 | || ar->start[i]->expr_type != EXPR_CONSTANT | |
5347 | || ar->end[i]->expr_type != EXPR_CONSTANT | |
5348 | || mpz_cmp (ar->start[i]->value.integer, | |
5349 | ar->end[i]->value.integer) != 0)) | |
5350 | return false; | |
5351 | ||
5352 | /* Following the standard, "(::1)" or - if known at compile time - | |
eea58adb | 5353 | "(lbound:ubound)" are not simply contiguous; if strict |
fe4e525c TB |
5354 | is false, they are regarded as simply contiguous. */ |
5355 | if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT | |
5356 | || ar->stride[i]->ts.type != BT_INTEGER | |
5357 | || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) | |
5358 | return false; | |
5359 | ||
5360 | if (ar->start[i] | |
5361 | && (strict || ar->start[i]->expr_type != EXPR_CONSTANT | |
5362 | || !ar->as->lower[i] | |
5363 | || ar->as->lower[i]->expr_type != EXPR_CONSTANT | |
5364 | || mpz_cmp (ar->start[i]->value.integer, | |
5365 | ar->as->lower[i]->value.integer) != 0)) | |
5366 | colon = false; | |
5367 | ||
5368 | if (ar->end[i] | |
5369 | && (strict || ar->end[i]->expr_type != EXPR_CONSTANT | |
5370 | || !ar->as->upper[i] | |
5371 | || ar->as->upper[i]->expr_type != EXPR_CONSTANT | |
5372 | || mpz_cmp (ar->end[i]->value.integer, | |
5373 | ar->as->upper[i]->value.integer) != 0)) | |
5374 | colon = false; | |
5375 | } | |
8b704316 | 5376 | |
fe4e525c TB |
5377 | return true; |
5378 | } | |
69dcd06a DK |
5379 | |
5380 | ||
5381 | /* Build call to an intrinsic procedure. The number of arguments has to be | |
5382 | passed (rather than ending the list with a NULL value) because we may | |
5383 | want to add arguments but with a NULL-expression. */ | |
5384 | ||
5385 | gfc_expr* | |
6838c137 TB |
5386 | gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, |
5387 | locus where, unsigned numarg, ...) | |
69dcd06a DK |
5388 | { |
5389 | gfc_expr* result; | |
5390 | gfc_actual_arglist* atail; | |
5391 | gfc_intrinsic_sym* isym; | |
5392 | va_list ap; | |
5393 | unsigned i; | |
6838c137 | 5394 | const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); |
69dcd06a | 5395 | |
6838c137 | 5396 | isym = gfc_intrinsic_function_by_id (id); |
69dcd06a | 5397 | gcc_assert (isym); |
8b704316 | 5398 | |
69dcd06a DK |
5399 | result = gfc_get_expr (); |
5400 | result->expr_type = EXPR_FUNCTION; | |
5401 | result->ts = isym->ts; | |
5402 | result->where = where; | |
6838c137 | 5403 | result->value.function.name = mangled_name; |
69dcd06a DK |
5404 | result->value.function.isym = isym; |
5405 | ||
6838c137 TB |
5406 | gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); |
5407 | gfc_commit_symbol (result->symtree->n.sym); | |
8e19c582 TB |
5408 | gcc_assert (result->symtree |
5409 | && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE | |
5410 | || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); | |
6838c137 TB |
5411 | result->symtree->n.sym->intmod_sym_id = id; |
5412 | result->symtree->n.sym->attr.flavor = FL_PROCEDURE; | |
5413 | result->symtree->n.sym->attr.intrinsic = 1; | |
9606f3c9 | 5414 | result->symtree->n.sym->attr.artificial = 1; |
8e19c582 | 5415 | |
69dcd06a DK |
5416 | va_start (ap, numarg); |
5417 | atail = NULL; | |
5418 | for (i = 0; i < numarg; ++i) | |
5419 | { | |
5420 | if (atail) | |
5421 | { | |
5422 | atail->next = gfc_get_actual_arglist (); | |
5423 | atail = atail->next; | |
5424 | } | |
5425 | else | |
5426 | atail = result->value.function.actual = gfc_get_actual_arglist (); | |
5427 | ||
5428 | atail->expr = va_arg (ap, gfc_expr*); | |
5429 | } | |
5430 | va_end (ap); | |
5431 | ||
5432 | return result; | |
5433 | } | |
8c91ab34 DK |
5434 | |
5435 | ||
5436 | /* Check if an expression may appear in a variable definition context | |
5437 | (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). | |
5438 | This is called from the various places when resolving | |
5439 | the pieces that make up such a context. | |
57bf28ea TB |
5440 | If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do |
5441 | variables), some checks are not performed. | |
8c91ab34 DK |
5442 | |
5443 | Optionally, a possible error message can be suppressed if context is NULL | |
524af0d6 | 5444 | and just the return status (true / false) be requested. */ |
8c91ab34 | 5445 | |
524af0d6 | 5446 | bool |
fea54935 | 5447 | gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, |
57bf28ea | 5448 | bool own_scope, const char* context) |
8c91ab34 | 5449 | { |
a300121e | 5450 | gfc_symbol* sym = NULL; |
8c91ab34 DK |
5451 | bool is_pointer; |
5452 | bool check_intentin; | |
5453 | bool ptr_component; | |
5454 | symbol_attribute attr; | |
5455 | gfc_ref* ref; | |
e2679323 | 5456 | int i; |
8c91ab34 | 5457 | |
a300121e TB |
5458 | if (e->expr_type == EXPR_VARIABLE) |
5459 | { | |
5460 | gcc_assert (e->symtree); | |
5461 | sym = e->symtree->n.sym; | |
5462 | } | |
5463 | else if (e->expr_type == EXPR_FUNCTION) | |
5464 | { | |
5465 | gcc_assert (e->symtree); | |
5466 | sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; | |
5467 | } | |
5468 | ||
49860194 JW |
5469 | attr = gfc_expr_attr (e); |
5470 | if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) | |
9b565d65 TB |
5471 | { |
5472 | if (!(gfc_option.allow_std & GFC_STD_F2008)) | |
5473 | { | |
5474 | if (context) | |
5475 | gfc_error ("Fortran 2008: Pointer functions in variable definition" | |
5476 | " context (%s) at %L", context, &e->where); | |
524af0d6 | 5477 | return false; |
9b565d65 TB |
5478 | } |
5479 | } | |
5480 | else if (e->expr_type != EXPR_VARIABLE) | |
8c91ab34 DK |
5481 | { |
5482 | if (context) | |
5483 | gfc_error ("Non-variable expression in variable definition context (%s)" | |
5484 | " at %L", context, &e->where); | |
524af0d6 | 5485 | return false; |
8c91ab34 DK |
5486 | } |
5487 | ||
8c91ab34 DK |
5488 | if (!pointer && sym->attr.flavor == FL_PARAMETER) |
5489 | { | |
5490 | if (context) | |
c4100eae | 5491 | gfc_error ("Named constant %qs in variable definition context (%s)" |
8c91ab34 | 5492 | " at %L", sym->name, context, &e->where); |
524af0d6 | 5493 | return false; |
8c91ab34 DK |
5494 | } |
5495 | if (!pointer && sym->attr.flavor != FL_VARIABLE | |
5496 | && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) | |
5497 | && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) | |
5498 | { | |
5499 | if (context) | |
c4100eae | 5500 | gfc_error ("%qs in variable definition context (%s) at %L is not" |
8c91ab34 | 5501 | " a variable", sym->name, context, &e->where); |
524af0d6 | 5502 | return false; |
8c91ab34 DK |
5503 | } |
5504 | ||
5505 | /* Find out whether the expr is a pointer; this also means following | |
5506 | component references to the last one. */ | |
8c91ab34 | 5507 | is_pointer = (attr.pointer || attr.proc_pointer); |
f637ebc1 | 5508 | if (pointer && !is_pointer) |
8c91ab34 DK |
5509 | { |
5510 | if (context) | |
5511 | gfc_error ("Non-POINTER in pointer association context (%s)" | |
5512 | " at %L", context, &e->where); | |
524af0d6 | 5513 | return false; |
8c91ab34 DK |
5514 | } |
5515 | ||
79124116 PT |
5516 | if (e->ts.type == BT_DERIVED |
5517 | && e->ts.u.derived == NULL) | |
5518 | { | |
5519 | if (context) | |
5520 | gfc_error ("Type inaccessible in variable definition context (%s) " | |
5521 | "at %L", context, &e->where); | |
5522 | return false; | |
5523 | } | |
5524 | ||
fea54935 TB |
5525 | /* F2008, C1303. */ |
5526 | if (!alloc_obj | |
5527 | && (attr.lock_comp | |
5528 | || (e->ts.type == BT_DERIVED | |
5529 | && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV | |
5530 | && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) | |
5531 | { | |
5532 | if (context) | |
5533 | gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", | |
5534 | context, &e->where); | |
524af0d6 | 5535 | return false; |
fea54935 TB |
5536 | } |
5537 | ||
5df445a2 TB |
5538 | /* TS18508, C702/C203. */ |
5539 | if (!alloc_obj | |
5540 | && (attr.lock_comp | |
5541 | || (e->ts.type == BT_DERIVED | |
5542 | && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV | |
5543 | && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) | |
5544 | { | |
5545 | if (context) | |
5546 | gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", | |
5547 | context, &e->where); | |
5548 | return false; | |
5549 | } | |
5550 | ||
4a101681 TB |
5551 | /* INTENT(IN) dummy argument. Check this, unless the object itself is the |
5552 | component of sub-component of a pointer; we need to distinguish | |
5553 | assignment to a pointer component from pointer-assignment to a pointer | |
5554 | component. Note that (normal) assignment to procedure pointers is not | |
5555 | possible. */ | |
57bf28ea | 5556 | check_intentin = !own_scope; |
fba5a793 SK |
5557 | ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived |
5558 | && CLASS_DATA (sym)) | |
f18075ff | 5559 | ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; |
8c91ab34 DK |
5560 | for (ref = e->ref; ref && check_intentin; ref = ref->next) |
5561 | { | |
5562 | if (ptr_component && ref->type == REF_COMPONENT) | |
5563 | check_intentin = false; | |
5564 | if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) | |
4a101681 TB |
5565 | { |
5566 | ptr_component = true; | |
5567 | if (!pointer) | |
5568 | check_intentin = false; | |
5569 | } | |
8c91ab34 DK |
5570 | } |
5571 | if (check_intentin && sym->attr.intent == INTENT_IN) | |
5572 | { | |
5573 | if (pointer && is_pointer) | |
5574 | { | |
5575 | if (context) | |
c4100eae | 5576 | gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" |
8c91ab34 DK |
5577 | " association context (%s) at %L", |
5578 | sym->name, context, &e->where); | |
524af0d6 | 5579 | return false; |
8c91ab34 | 5580 | } |
6fd7dd57 | 5581 | if (!pointer && !is_pointer && !sym->attr.pointer) |
8c91ab34 DK |
5582 | { |
5583 | if (context) | |
c4100eae | 5584 | gfc_error ("Dummy argument %qs with INTENT(IN) in variable" |
8c91ab34 DK |
5585 | " definition context (%s) at %L", |
5586 | sym->name, context, &e->where); | |
524af0d6 | 5587 | return false; |
8c91ab34 DK |
5588 | } |
5589 | } | |
5590 | ||
5591 | /* PROTECTED and use-associated. */ | |
57bf28ea | 5592 | if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) |
8c91ab34 DK |
5593 | { |
5594 | if (pointer && is_pointer) | |
5595 | { | |
5596 | if (context) | |
c4100eae | 5597 | gfc_error ("Variable %qs is PROTECTED and can not appear in a" |
8c91ab34 DK |
5598 | " pointer association context (%s) at %L", |
5599 | sym->name, context, &e->where); | |
524af0d6 | 5600 | return false; |
8c91ab34 DK |
5601 | } |
5602 | if (!pointer && !is_pointer) | |
5603 | { | |
5604 | if (context) | |
c4100eae | 5605 | gfc_error ("Variable %qs is PROTECTED and can not appear in a" |
8c91ab34 DK |
5606 | " variable definition context (%s) at %L", |
5607 | sym->name, context, &e->where); | |
524af0d6 | 5608 | return false; |
8c91ab34 DK |
5609 | } |
5610 | } | |
5611 | ||
5612 | /* Variable not assignable from a PURE procedure but appears in | |
5613 | variable definition context. */ | |
57bf28ea | 5614 | if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) |
8c91ab34 DK |
5615 | { |
5616 | if (context) | |
c4100eae | 5617 | gfc_error ("Variable %qs can not appear in a variable definition" |
8c91ab34 DK |
5618 | " context (%s) at %L in PURE procedure", |
5619 | sym->name, context, &e->where); | |
524af0d6 | 5620 | return false; |
8c91ab34 DK |
5621 | } |
5622 | ||
f29041dd TK |
5623 | if (!pointer && context && gfc_implicit_pure (NULL) |
5624 | && gfc_impure_variable (sym)) | |
5625 | { | |
5626 | gfc_namespace *ns; | |
5627 | gfc_symbol *sym; | |
f1f39033 | 5628 | |
f29041dd TK |
5629 | for (ns = gfc_current_ns; ns; ns = ns->parent) |
5630 | { | |
5631 | sym = ns->proc_name; | |
5632 | if (sym == NULL) | |
5633 | break; | |
5634 | if (sym->attr.flavor == FL_PROCEDURE) | |
5635 | { | |
5636 | sym->attr.implicit_pure = 0; | |
5637 | break; | |
5638 | } | |
5639 | } | |
5640 | } | |
8c91ab34 DK |
5641 | /* Check variable definition context for associate-names. */ |
5642 | if (!pointer && sym->assoc) | |
5643 | { | |
5644 | const char* name; | |
5645 | gfc_association_list* assoc; | |
5646 | ||
5647 | gcc_assert (sym->assoc->target); | |
5648 | ||
5649 | /* If this is a SELECT TYPE temporary (the association is used internally | |
5650 | for SELECT TYPE), silently go over to the target. */ | |
5651 | if (sym->attr.select_type_temporary) | |
5652 | { | |
5653 | gfc_expr* t = sym->assoc->target; | |
5654 | ||
5655 | gcc_assert (t->expr_type == EXPR_VARIABLE); | |
5656 | name = t->symtree->name; | |
5657 | ||
5658 | if (t->symtree->n.sym->assoc) | |
5659 | assoc = t->symtree->n.sym->assoc; | |
5660 | else | |
5661 | assoc = sym->assoc; | |
5662 | } | |
5663 | else | |
5664 | { | |
5665 | name = sym->name; | |
5666 | assoc = sym->assoc; | |
5667 | } | |
5668 | gcc_assert (name && assoc); | |
5669 | ||
5670 | /* Is association to a valid variable? */ | |
5671 | if (!assoc->variable) | |
5672 | { | |
5673 | if (context) | |
5674 | { | |
5675 | if (assoc->target->expr_type == EXPR_VARIABLE) | |
c4100eae | 5676 | gfc_error ("%qs at %L associated to vector-indexed target can" |
8c91ab34 DK |
5677 | " not be used in a variable definition context (%s)", |
5678 | name, &e->where, context); | |
5679 | else | |
c4100eae | 5680 | gfc_error ("%qs at %L associated to expression can" |
8c91ab34 DK |
5681 | " not be used in a variable definition context (%s)", |
5682 | name, &e->where, context); | |
5683 | } | |
524af0d6 | 5684 | return false; |
8c91ab34 DK |
5685 | } |
5686 | ||
5687 | /* Target must be allowed to appear in a variable definition context. */ | |
524af0d6 | 5688 | if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) |
8c91ab34 DK |
5689 | { |
5690 | if (context) | |
fea70c99 | 5691 | gfc_error ("Associate-name %qs can not appear in a variable" |
8c91ab34 DK |
5692 | " definition context (%s) at %L because its target" |
5693 | " at %L can not, either", | |
5694 | name, context, &e->where, | |
5695 | &assoc->target->where); | |
524af0d6 | 5696 | return false; |
8c91ab34 DK |
5697 | } |
5698 | } | |
5699 | ||
e2679323 TK |
5700 | /* Check for same value in vector expression subscript. */ |
5701 | ||
5702 | if (e->rank > 0) | |
5703 | for (ref = e->ref; ref != NULL; ref = ref->next) | |
5704 | if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) | |
5705 | for (i = 0; i < GFC_MAX_DIMENSIONS | |
5706 | && ref->u.ar.dimen_type[i] != 0; i++) | |
5707 | if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) | |
5708 | { | |
5709 | gfc_expr *arr = ref->u.ar.start[i]; | |
5710 | if (arr->expr_type == EXPR_ARRAY) | |
5711 | { | |
5712 | gfc_constructor *c, *n; | |
5713 | gfc_expr *ec, *en; | |
bf9f15ee | 5714 | |
e2679323 TK |
5715 | for (c = gfc_constructor_first (arr->value.constructor); |
5716 | c != NULL; c = gfc_constructor_next (c)) | |
5717 | { | |
5718 | if (c == NULL || c->iterator != NULL) | |
5719 | continue; | |
bf9f15ee | 5720 | |
e2679323 TK |
5721 | ec = c->expr; |
5722 | ||
5723 | for (n = gfc_constructor_next (c); n != NULL; | |
5724 | n = gfc_constructor_next (n)) | |
5725 | { | |
5726 | if (n->iterator != NULL) | |
5727 | continue; | |
bf9f15ee | 5728 | |
e2679323 TK |
5729 | en = n->expr; |
5730 | if (gfc_dep_compare_expr (ec, en) == 0) | |
5731 | { | |
aa9ca5ca | 5732 | if (context) |
fea70c99 MLI |
5733 | gfc_error_now ("Elements with the same value " |
5734 | "at %L and %L in vector " | |
5735 | "subscript in a variable " | |
5736 | "definition context (%s)", | |
5737 | &(ec->where), &(en->where), | |
5738 | context); | |
e2679323 TK |
5739 | return false; |
5740 | } | |
5741 | } | |
5742 | } | |
5743 | } | |
5744 | } | |
bf9f15ee | 5745 | |
524af0d6 | 5746 | return true; |
8c91ab34 | 5747 | } |