]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Routines for manipulation of expression nodes. |
636dff67 SK |
2 | Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 |
3 | Free Software Foundation, Inc. | |
6de9cd9a DN |
4 | Contributed by Andy Vaught |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
d234d788 | 10 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 11 | version. |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
21 | |
22 | #include "config.h" | |
d22e4895 | 23 | #include "system.h" |
6de9cd9a DN |
24 | #include "gfortran.h" |
25 | #include "arith.h" | |
26 | #include "match.h" | |
27 | ||
28 | /* Get a new expr node. */ | |
29 | ||
30 | gfc_expr * | |
31 | gfc_get_expr (void) | |
32 | { | |
33 | gfc_expr *e; | |
34 | ||
35 | e = gfc_getmem (sizeof (gfc_expr)); | |
6de9cd9a | 36 | gfc_clear_ts (&e->ts); |
6de9cd9a DN |
37 | e->shape = NULL; |
38 | e->ref = NULL; | |
39 | e->symtree = NULL; | |
5868cbf9 | 40 | e->con_by_offset = NULL; |
6de9cd9a DN |
41 | return e; |
42 | } | |
43 | ||
44 | ||
45 | /* Free an argument list and everything below it. */ | |
46 | ||
47 | void | |
636dff67 | 48 | gfc_free_actual_arglist (gfc_actual_arglist *a1) |
6de9cd9a DN |
49 | { |
50 | gfc_actual_arglist *a2; | |
51 | ||
52 | while (a1) | |
53 | { | |
54 | a2 = a1->next; | |
55 | gfc_free_expr (a1->expr); | |
56 | gfc_free (a1); | |
57 | a1 = a2; | |
58 | } | |
59 | } | |
60 | ||
61 | ||
62 | /* Copy an arglist structure and all of the arguments. */ | |
63 | ||
64 | gfc_actual_arglist * | |
636dff67 | 65 | gfc_copy_actual_arglist (gfc_actual_arglist *p) |
6de9cd9a DN |
66 | { |
67 | gfc_actual_arglist *head, *tail, *new; | |
68 | ||
69 | head = tail = NULL; | |
70 | ||
71 | for (; p; p = p->next) | |
72 | { | |
73 | new = gfc_get_actual_arglist (); | |
74 | *new = *p; | |
75 | ||
76 | new->expr = gfc_copy_expr (p->expr); | |
77 | new->next = NULL; | |
78 | ||
79 | if (head == NULL) | |
80 | head = new; | |
81 | else | |
82 | tail->next = new; | |
83 | ||
84 | tail = new; | |
85 | } | |
86 | ||
87 | return head; | |
88 | } | |
89 | ||
90 | ||
91 | /* Free a list of reference structures. */ | |
92 | ||
93 | void | |
636dff67 | 94 | gfc_free_ref_list (gfc_ref *p) |
6de9cd9a DN |
95 | { |
96 | gfc_ref *q; | |
97 | int i; | |
98 | ||
99 | for (; p; p = q) | |
100 | { | |
101 | q = p->next; | |
102 | ||
103 | switch (p->type) | |
104 | { | |
105 | case REF_ARRAY: | |
106 | for (i = 0; i < GFC_MAX_DIMENSIONS; i++) | |
107 | { | |
108 | gfc_free_expr (p->u.ar.start[i]); | |
109 | gfc_free_expr (p->u.ar.end[i]); | |
110 | gfc_free_expr (p->u.ar.stride[i]); | |
111 | } | |
112 | ||
113 | break; | |
114 | ||
115 | case REF_SUBSTRING: | |
116 | gfc_free_expr (p->u.ss.start); | |
117 | gfc_free_expr (p->u.ss.end); | |
118 | break; | |
119 | ||
120 | case REF_COMPONENT: | |
121 | break; | |
122 | } | |
123 | ||
124 | gfc_free (p); | |
125 | } | |
126 | } | |
127 | ||
128 | ||
129 | /* Workhorse function for gfc_free_expr() that frees everything | |
130 | beneath an expression node, but not the node itself. This is | |
131 | useful when we want to simplify a node and replace it with | |
132 | something else or the expression node belongs to another structure. */ | |
133 | ||
134 | static void | |
636dff67 | 135 | free_expr0 (gfc_expr *e) |
6de9cd9a DN |
136 | { |
137 | int n; | |
138 | ||
139 | switch (e->expr_type) | |
140 | { | |
141 | case EXPR_CONSTANT: | |
20585ad6 | 142 | /* Free any parts of the value that need freeing. */ |
6de9cd9a DN |
143 | switch (e->ts.type) |
144 | { | |
145 | case BT_INTEGER: | |
146 | mpz_clear (e->value.integer); | |
147 | break; | |
148 | ||
149 | case BT_REAL: | |
f8e566e5 | 150 | mpfr_clear (e->value.real); |
6de9cd9a DN |
151 | break; |
152 | ||
153 | case BT_CHARACTER: | |
154 | gfc_free (e->value.character.string); | |
155 | break; | |
156 | ||
157 | case BT_COMPLEX: | |
f8e566e5 SK |
158 | mpfr_clear (e->value.complex.r); |
159 | mpfr_clear (e->value.complex.i); | |
6de9cd9a DN |
160 | break; |
161 | ||
162 | default: | |
163 | break; | |
164 | } | |
165 | ||
20585ad6 BM |
166 | /* Free the representation, except in character constants where it |
167 | is the same as value.character.string and thus already freed. */ | |
168 | if (e->representation.string && e->ts.type != BT_CHARACTER) | |
169 | gfc_free (e->representation.string); | |
170 | ||
6de9cd9a DN |
171 | break; |
172 | ||
173 | case EXPR_OP: | |
58b03ab2 TS |
174 | if (e->value.op.op1 != NULL) |
175 | gfc_free_expr (e->value.op.op1); | |
176 | if (e->value.op.op2 != NULL) | |
177 | gfc_free_expr (e->value.op.op2); | |
6de9cd9a DN |
178 | break; |
179 | ||
180 | case EXPR_FUNCTION: | |
181 | gfc_free_actual_arglist (e->value.function.actual); | |
182 | break; | |
183 | ||
184 | case EXPR_VARIABLE: | |
185 | break; | |
186 | ||
187 | case EXPR_ARRAY: | |
188 | case EXPR_STRUCTURE: | |
189 | gfc_free_constructor (e->value.constructor); | |
190 | break; | |
191 | ||
192 | case EXPR_SUBSTRING: | |
193 | gfc_free (e->value.character.string); | |
194 | break; | |
195 | ||
196 | case EXPR_NULL: | |
197 | break; | |
198 | ||
199 | default: | |
200 | gfc_internal_error ("free_expr0(): Bad expr type"); | |
201 | } | |
202 | ||
203 | /* Free a shape array. */ | |
204 | if (e->shape != NULL) | |
205 | { | |
206 | for (n = 0; n < e->rank; n++) | |
207 | mpz_clear (e->shape[n]); | |
208 | ||
209 | gfc_free (e->shape); | |
210 | } | |
211 | ||
212 | gfc_free_ref_list (e->ref); | |
213 | ||
214 | memset (e, '\0', sizeof (gfc_expr)); | |
215 | } | |
216 | ||
217 | ||
218 | /* Free an expression node and everything beneath it. */ | |
219 | ||
220 | void | |
636dff67 | 221 | gfc_free_expr (gfc_expr *e) |
6de9cd9a | 222 | { |
6de9cd9a DN |
223 | if (e == NULL) |
224 | return; | |
5868cbf9 BD |
225 | if (e->con_by_offset) |
226 | splay_tree_delete (e->con_by_offset); | |
6de9cd9a DN |
227 | free_expr0 (e); |
228 | gfc_free (e); | |
229 | } | |
230 | ||
231 | ||
232 | /* Graft the *src expression onto the *dest subexpression. */ | |
233 | ||
234 | void | |
636dff67 | 235 | gfc_replace_expr (gfc_expr *dest, gfc_expr *src) |
6de9cd9a | 236 | { |
6de9cd9a DN |
237 | free_expr0 (dest); |
238 | *dest = *src; | |
6de9cd9a DN |
239 | gfc_free (src); |
240 | } | |
241 | ||
242 | ||
243 | /* Try to extract an integer constant from the passed expression node. | |
244 | Returns an error message or NULL if the result is set. It is | |
245 | tempting to generate an error and return SUCCESS or FAILURE, but | |
246 | failure is OK for some callers. */ | |
247 | ||
248 | const char * | |
636dff67 | 249 | gfc_extract_int (gfc_expr *expr, int *result) |
6de9cd9a | 250 | { |
6de9cd9a | 251 | if (expr->expr_type != EXPR_CONSTANT) |
31043f6c | 252 | return _("Constant expression required at %C"); |
6de9cd9a DN |
253 | |
254 | if (expr->ts.type != BT_INTEGER) | |
31043f6c | 255 | return _("Integer expression required at %C"); |
6de9cd9a DN |
256 | |
257 | if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) | |
258 | || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) | |
259 | { | |
31043f6c | 260 | return _("Integer value too large in expression at %C"); |
6de9cd9a DN |
261 | } |
262 | ||
263 | *result = (int) mpz_get_si (expr->value.integer); | |
264 | ||
265 | return NULL; | |
266 | } | |
267 | ||
268 | ||
269 | /* Recursively copy a list of reference structures. */ | |
270 | ||
271 | static gfc_ref * | |
636dff67 | 272 | copy_ref (gfc_ref *src) |
6de9cd9a DN |
273 | { |
274 | gfc_array_ref *ar; | |
275 | gfc_ref *dest; | |
276 | ||
277 | if (src == NULL) | |
278 | return NULL; | |
279 | ||
280 | dest = gfc_get_ref (); | |
281 | dest->type = src->type; | |
282 | ||
283 | switch (src->type) | |
284 | { | |
285 | case REF_ARRAY: | |
286 | ar = gfc_copy_array_ref (&src->u.ar); | |
287 | dest->u.ar = *ar; | |
288 | gfc_free (ar); | |
289 | break; | |
290 | ||
291 | case REF_COMPONENT: | |
292 | dest->u.c = src->u.c; | |
293 | break; | |
294 | ||
295 | case REF_SUBSTRING: | |
296 | dest->u.ss = src->u.ss; | |
297 | dest->u.ss.start = gfc_copy_expr (src->u.ss.start); | |
298 | dest->u.ss.end = gfc_copy_expr (src->u.ss.end); | |
299 | break; | |
300 | } | |
301 | ||
302 | dest->next = copy_ref (src->next); | |
303 | ||
304 | return dest; | |
305 | } | |
306 | ||
307 | ||
636dff67 | 308 | /* Detect whether an expression has any vector index array references. */ |
4075a94e PT |
309 | |
310 | int | |
311 | gfc_has_vector_index (gfc_expr *e) | |
312 | { | |
636dff67 | 313 | gfc_ref *ref; |
4075a94e PT |
314 | int i; |
315 | for (ref = e->ref; ref; ref = ref->next) | |
316 | if (ref->type == REF_ARRAY) | |
317 | for (i = 0; i < ref->u.ar.dimen; i++) | |
318 | if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) | |
319 | return 1; | |
320 | return 0; | |
321 | } | |
322 | ||
323 | ||
6de9cd9a DN |
324 | /* Copy a shape array. */ |
325 | ||
326 | mpz_t * | |
636dff67 | 327 | gfc_copy_shape (mpz_t *shape, int rank) |
6de9cd9a DN |
328 | { |
329 | mpz_t *new_shape; | |
330 | int n; | |
331 | ||
332 | if (shape == NULL) | |
333 | return NULL; | |
334 | ||
335 | new_shape = gfc_get_shape (rank); | |
336 | ||
337 | for (n = 0; n < rank; n++) | |
338 | mpz_init_set (new_shape[n], shape[n]); | |
339 | ||
340 | return new_shape; | |
341 | } | |
342 | ||
343 | ||
94538bd1 VL |
344 | /* Copy a shape array excluding dimension N, where N is an integer |
345 | constant expression. Dimensions are numbered in fortran style -- | |
346 | starting with ONE. | |
347 | ||
348 | So, if the original shape array contains R elements | |
349 | { s1 ... sN-1 sN sN+1 ... sR-1 sR} | |
350 | the result contains R-1 elements: | |
351 | { s1 ... sN-1 sN+1 ... sR-1} | |
352 | ||
353 | If anything goes wrong -- N is not a constant, its value is out | |
66e4ab31 | 354 | of range -- or anything else, just returns NULL. */ |
94538bd1 VL |
355 | |
356 | mpz_t * | |
636dff67 | 357 | gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) |
94538bd1 VL |
358 | { |
359 | mpz_t *new_shape, *s; | |
360 | int i, n; | |
361 | ||
362 | if (shape == NULL | |
363 | || rank <= 1 | |
364 | || dim == NULL | |
365 | || dim->expr_type != EXPR_CONSTANT | |
366 | || dim->ts.type != BT_INTEGER) | |
367 | return NULL; | |
368 | ||
369 | n = mpz_get_si (dim->value.integer); | |
66e4ab31 | 370 | n--; /* Convert to zero based index. */ |
37e860a2 | 371 | if (n < 0 || n >= rank) |
94538bd1 VL |
372 | return NULL; |
373 | ||
636dff67 | 374 | s = new_shape = gfc_get_shape (rank - 1); |
94538bd1 VL |
375 | |
376 | for (i = 0; i < rank; i++) | |
377 | { | |
378 | if (i == n) | |
636dff67 | 379 | continue; |
94538bd1 VL |
380 | mpz_init_set (*s, shape[i]); |
381 | s++; | |
382 | } | |
383 | ||
384 | return new_shape; | |
385 | } | |
386 | ||
636dff67 | 387 | |
6de9cd9a DN |
388 | /* Given an expression pointer, return a copy of the expression. This |
389 | subroutine is recursive. */ | |
390 | ||
391 | gfc_expr * | |
636dff67 | 392 | gfc_copy_expr (gfc_expr *p) |
6de9cd9a DN |
393 | { |
394 | gfc_expr *q; | |
395 | char *s; | |
396 | ||
397 | if (p == NULL) | |
398 | return NULL; | |
399 | ||
400 | q = gfc_get_expr (); | |
401 | *q = *p; | |
402 | ||
403 | switch (q->expr_type) | |
404 | { | |
405 | case EXPR_SUBSTRING: | |
406 | s = gfc_getmem (p->value.character.length + 1); | |
407 | q->value.character.string = s; | |
408 | ||
409 | memcpy (s, p->value.character.string, p->value.character.length + 1); | |
6de9cd9a DN |
410 | break; |
411 | ||
412 | case EXPR_CONSTANT: | |
20585ad6 BM |
413 | /* Copy target representation, if it exists. */ |
414 | if (p->representation.string) | |
d3642f89 | 415 | { |
20585ad6 BM |
416 | s = gfc_getmem (p->representation.length + 1); |
417 | q->representation.string = s; | |
d3642f89 | 418 | |
20585ad6 | 419 | memcpy (s, p->representation.string, p->representation.length + 1); |
d3642f89 | 420 | } |
20585ad6 BM |
421 | |
422 | /* Copy the values of any pointer components of p->value. */ | |
6de9cd9a DN |
423 | switch (q->ts.type) |
424 | { | |
425 | case BT_INTEGER: | |
426 | mpz_init_set (q->value.integer, p->value.integer); | |
427 | break; | |
428 | ||
429 | case BT_REAL: | |
636dff67 SK |
430 | gfc_set_model_kind (q->ts.kind); |
431 | mpfr_init (q->value.real); | |
f8e566e5 | 432 | mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); |
6de9cd9a DN |
433 | break; |
434 | ||
435 | case BT_COMPLEX: | |
636dff67 SK |
436 | gfc_set_model_kind (q->ts.kind); |
437 | mpfr_init (q->value.complex.r); | |
438 | mpfr_init (q->value.complex.i); | |
f8e566e5 SK |
439 | mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE); |
440 | mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE); | |
6de9cd9a DN |
441 | break; |
442 | ||
443 | case BT_CHARACTER: | |
20585ad6 BM |
444 | if (p->representation.string) |
445 | q->value.character.string = q->representation.string; | |
446 | else | |
447 | { | |
448 | s = gfc_getmem (p->value.character.length + 1); | |
449 | q->value.character.string = s; | |
6de9cd9a | 450 | |
a8b3b0b6 CR |
451 | /* This is the case for the C_NULL_CHAR named constant. */ |
452 | if (p->value.character.length == 0 | |
453 | && (p->ts.is_c_interop || p->ts.is_iso_c)) | |
454 | { | |
455 | *s = '\0'; | |
456 | /* Need to set the length to 1 to make sure the NUL | |
457 | terminator is copied. */ | |
458 | q->value.character.length = 1; | |
459 | } | |
460 | else | |
461 | memcpy (s, p->value.character.string, | |
462 | p->value.character.length + 1); | |
20585ad6 | 463 | } |
6de9cd9a DN |
464 | break; |
465 | ||
20585ad6 | 466 | case BT_HOLLERITH: |
6de9cd9a DN |
467 | case BT_LOGICAL: |
468 | case BT_DERIVED: | |
a8b3b0b6 | 469 | break; /* Already done. */ |
6de9cd9a DN |
470 | |
471 | case BT_PROCEDURE: | |
a8b3b0b6 CR |
472 | case BT_VOID: |
473 | /* Should never be reached. */ | |
6de9cd9a DN |
474 | case BT_UNKNOWN: |
475 | gfc_internal_error ("gfc_copy_expr(): Bad expr node"); | |
a8b3b0b6 | 476 | /* Not reached. */ |
6de9cd9a DN |
477 | } |
478 | ||
479 | break; | |
480 | ||
481 | case EXPR_OP: | |
58b03ab2 | 482 | switch (q->value.op.operator) |
6de9cd9a DN |
483 | { |
484 | case INTRINSIC_NOT: | |
2f118814 | 485 | case INTRINSIC_PARENTHESES: |
6de9cd9a DN |
486 | case INTRINSIC_UPLUS: |
487 | case INTRINSIC_UMINUS: | |
58b03ab2 | 488 | q->value.op.op1 = gfc_copy_expr (p->value.op.op1); |
6de9cd9a DN |
489 | break; |
490 | ||
66e4ab31 | 491 | default: /* Binary operators. */ |
58b03ab2 TS |
492 | q->value.op.op1 = gfc_copy_expr (p->value.op.op1); |
493 | q->value.op.op2 = gfc_copy_expr (p->value.op.op2); | |
6de9cd9a DN |
494 | break; |
495 | } | |
496 | ||
497 | break; | |
498 | ||
499 | case EXPR_FUNCTION: | |
500 | q->value.function.actual = | |
501 | gfc_copy_actual_arglist (p->value.function.actual); | |
502 | break; | |
503 | ||
504 | case EXPR_STRUCTURE: | |
505 | case EXPR_ARRAY: | |
506 | q->value.constructor = gfc_copy_constructor (p->value.constructor); | |
507 | break; | |
508 | ||
509 | case EXPR_VARIABLE: | |
510 | case EXPR_NULL: | |
511 | break; | |
512 | } | |
513 | ||
514 | q->shape = gfc_copy_shape (p->shape, p->rank); | |
515 | ||
516 | q->ref = copy_ref (p->ref); | |
517 | ||
518 | return q; | |
519 | } | |
520 | ||
521 | ||
522 | /* Return the maximum kind of two expressions. In general, higher | |
523 | kind numbers mean more precision for numeric types. */ | |
524 | ||
525 | int | |
636dff67 | 526 | gfc_kind_max (gfc_expr *e1, gfc_expr *e2) |
6de9cd9a | 527 | { |
6de9cd9a DN |
528 | return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; |
529 | } | |
530 | ||
531 | ||
532 | /* Returns nonzero if the type is numeric, zero otherwise. */ | |
533 | ||
534 | static int | |
535 | numeric_type (bt type) | |
536 | { | |
6de9cd9a DN |
537 | return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; |
538 | } | |
539 | ||
540 | ||
541 | /* Returns nonzero if the typespec is a numeric type, zero otherwise. */ | |
542 | ||
543 | int | |
636dff67 | 544 | gfc_numeric_ts (gfc_typespec *ts) |
6de9cd9a | 545 | { |
6de9cd9a DN |
546 | return numeric_type (ts->type); |
547 | } | |
548 | ||
549 | ||
550 | /* Returns an expression node that is an integer constant. */ | |
551 | ||
552 | gfc_expr * | |
553 | gfc_int_expr (int i) | |
554 | { | |
555 | gfc_expr *p; | |
556 | ||
557 | p = gfc_get_expr (); | |
558 | ||
559 | p->expr_type = EXPR_CONSTANT; | |
560 | p->ts.type = BT_INTEGER; | |
9d64df18 | 561 | p->ts.kind = gfc_default_integer_kind; |
6de9cd9a | 562 | |
63645982 | 563 | p->where = gfc_current_locus; |
6de9cd9a DN |
564 | mpz_init_set_si (p->value.integer, i); |
565 | ||
566 | return p; | |
567 | } | |
568 | ||
569 | ||
570 | /* Returns an expression node that is a logical constant. */ | |
571 | ||
572 | gfc_expr * | |
636dff67 | 573 | gfc_logical_expr (int i, locus *where) |
6de9cd9a DN |
574 | { |
575 | gfc_expr *p; | |
576 | ||
577 | p = gfc_get_expr (); | |
578 | ||
579 | p->expr_type = EXPR_CONSTANT; | |
580 | p->ts.type = BT_LOGICAL; | |
9d64df18 | 581 | p->ts.kind = gfc_default_logical_kind; |
6de9cd9a DN |
582 | |
583 | if (where == NULL) | |
63645982 | 584 | where = &gfc_current_locus; |
6de9cd9a DN |
585 | p->where = *where; |
586 | p->value.logical = i; | |
587 | ||
588 | return p; | |
589 | } | |
590 | ||
591 | ||
592 | /* Return an expression node with an optional argument list attached. | |
593 | A variable number of gfc_expr pointers are strung together in an | |
594 | argument list with a NULL pointer terminating the list. */ | |
595 | ||
596 | gfc_expr * | |
636dff67 | 597 | gfc_build_conversion (gfc_expr *e) |
6de9cd9a DN |
598 | { |
599 | gfc_expr *p; | |
600 | ||
601 | p = gfc_get_expr (); | |
602 | p->expr_type = EXPR_FUNCTION; | |
603 | p->symtree = NULL; | |
604 | p->value.function.actual = NULL; | |
605 | ||
606 | p->value.function.actual = gfc_get_actual_arglist (); | |
607 | p->value.function.actual->expr = e; | |
608 | ||
609 | return p; | |
610 | } | |
611 | ||
612 | ||
613 | /* Given an expression node with some sort of numeric binary | |
614 | expression, insert type conversions required to make the operands | |
615 | have the same type. | |
616 | ||
617 | The exception is that the operands of an exponential don't have to | |
618 | have the same type. If possible, the base is promoted to the type | |
619 | of the exponent. For example, 1**2.3 becomes 1.0**2.3, but | |
f7b529fa | 620 | 1.0**2 stays as it is. */ |
6de9cd9a DN |
621 | |
622 | void | |
636dff67 | 623 | gfc_type_convert_binary (gfc_expr *e) |
6de9cd9a DN |
624 | { |
625 | gfc_expr *op1, *op2; | |
626 | ||
58b03ab2 TS |
627 | op1 = e->value.op.op1; |
628 | op2 = e->value.op.op2; | |
6de9cd9a DN |
629 | |
630 | if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) | |
631 | { | |
632 | gfc_clear_ts (&e->ts); | |
633 | return; | |
634 | } | |
635 | ||
636 | /* Kind conversions of same type. */ | |
637 | if (op1->ts.type == op2->ts.type) | |
638 | { | |
6de9cd9a DN |
639 | if (op1->ts.kind == op2->ts.kind) |
640 | { | |
636dff67 | 641 | /* No type conversions. */ |
6de9cd9a DN |
642 | e->ts = op1->ts; |
643 | goto done; | |
644 | } | |
645 | ||
646 | if (op1->ts.kind > op2->ts.kind) | |
647 | gfc_convert_type (op2, &op1->ts, 2); | |
648 | else | |
649 | gfc_convert_type (op1, &op2->ts, 2); | |
650 | ||
651 | e->ts = op1->ts; | |
652 | goto done; | |
653 | } | |
654 | ||
655 | /* Integer combined with real or complex. */ | |
656 | if (op2->ts.type == BT_INTEGER) | |
657 | { | |
658 | e->ts = op1->ts; | |
659 | ||
687fcae7 | 660 | /* Special case for ** operator. */ |
58b03ab2 | 661 | if (e->value.op.operator == INTRINSIC_POWER) |
6de9cd9a DN |
662 | goto done; |
663 | ||
58b03ab2 | 664 | gfc_convert_type (e->value.op.op2, &e->ts, 2); |
6de9cd9a DN |
665 | goto done; |
666 | } | |
667 | ||
668 | if (op1->ts.type == BT_INTEGER) | |
669 | { | |
670 | e->ts = op2->ts; | |
58b03ab2 | 671 | gfc_convert_type (e->value.op.op1, &e->ts, 2); |
6de9cd9a DN |
672 | goto done; |
673 | } | |
674 | ||
675 | /* Real combined with complex. */ | |
676 | e->ts.type = BT_COMPLEX; | |
677 | if (op1->ts.kind > op2->ts.kind) | |
678 | e->ts.kind = op1->ts.kind; | |
679 | else | |
680 | e->ts.kind = op2->ts.kind; | |
681 | if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) | |
58b03ab2 | 682 | gfc_convert_type (e->value.op.op1, &e->ts, 2); |
6de9cd9a | 683 | if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) |
58b03ab2 | 684 | gfc_convert_type (e->value.op.op2, &e->ts, 2); |
6de9cd9a DN |
685 | |
686 | done: | |
687 | return; | |
688 | } | |
689 | ||
690 | ||
e1633d82 DF |
691 | static match |
692 | check_specification_function (gfc_expr *e) | |
693 | { | |
694 | gfc_symbol *sym; | |
d05360a6 DF |
695 | |
696 | if (!e->symtree) | |
697 | return MATCH_NO; | |
698 | ||
e1633d82 DF |
699 | sym = e->symtree->n.sym; |
700 | ||
701 | /* F95, 7.1.6.2; F2003, 7.1.7 */ | |
702 | if (sym | |
703 | && sym->attr.function | |
704 | && sym->attr.pure | |
705 | && !sym->attr.intrinsic | |
706 | && !sym->attr.recursive | |
707 | && sym->attr.proc != PROC_INTERNAL | |
708 | && sym->attr.proc != PROC_ST_FUNCTION | |
709 | && sym->attr.proc != PROC_UNKNOWN | |
710 | && sym->formal == NULL) | |
711 | return MATCH_YES; | |
712 | ||
713 | return MATCH_NO; | |
714 | } | |
715 | ||
6de9cd9a DN |
716 | /* Function to determine if an expression is constant or not. This |
717 | function expects that the expression has already been simplified. */ | |
718 | ||
719 | int | |
636dff67 | 720 | gfc_is_constant_expr (gfc_expr *e) |
6de9cd9a DN |
721 | { |
722 | gfc_constructor *c; | |
723 | gfc_actual_arglist *arg; | |
724 | int rv; | |
725 | ||
726 | if (e == NULL) | |
727 | return 1; | |
728 | ||
729 | switch (e->expr_type) | |
730 | { | |
731 | case EXPR_OP: | |
58b03ab2 TS |
732 | rv = (gfc_is_constant_expr (e->value.op.op1) |
733 | && (e->value.op.op2 == NULL | |
734 | || gfc_is_constant_expr (e->value.op.op2))); | |
6de9cd9a DN |
735 | break; |
736 | ||
737 | case EXPR_VARIABLE: | |
738 | rv = 0; | |
739 | break; | |
740 | ||
741 | case EXPR_FUNCTION: | |
e1633d82 DF |
742 | /* Specification functions are constant. */ |
743 | if (check_specification_function (e) == MATCH_YES) | |
744 | { | |
745 | rv = 1; | |
746 | break; | |
747 | } | |
748 | ||
6de9cd9a DN |
749 | /* Call to intrinsic with at least one argument. */ |
750 | rv = 0; | |
751 | if (e->value.function.isym && e->value.function.actual) | |
752 | { | |
753 | for (arg = e->value.function.actual; arg; arg = arg->next) | |
754 | { | |
755 | if (!gfc_is_constant_expr (arg->expr)) | |
756 | break; | |
757 | } | |
758 | if (arg == NULL) | |
759 | rv = 1; | |
760 | } | |
761 | break; | |
762 | ||
763 | case EXPR_CONSTANT: | |
764 | case EXPR_NULL: | |
765 | rv = 1; | |
766 | break; | |
767 | ||
768 | case EXPR_SUBSTRING: | |
eac33acc TS |
769 | rv = (gfc_is_constant_expr (e->ref->u.ss.start) |
770 | && gfc_is_constant_expr (e->ref->u.ss.end)); | |
6de9cd9a DN |
771 | break; |
772 | ||
773 | case EXPR_STRUCTURE: | |
774 | rv = 0; | |
775 | for (c = e->value.constructor; c; c = c->next) | |
776 | if (!gfc_is_constant_expr (c->expr)) | |
777 | break; | |
778 | ||
779 | if (c == NULL) | |
780 | rv = 1; | |
781 | break; | |
782 | ||
783 | case EXPR_ARRAY: | |
784 | rv = gfc_constant_ac (e); | |
785 | break; | |
786 | ||
787 | default: | |
788 | gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); | |
789 | } | |
790 | ||
791 | return rv; | |
792 | } | |
793 | ||
794 | ||
795 | /* Try to collapse intrinsic expressions. */ | |
796 | ||
797 | static try | |
636dff67 | 798 | simplify_intrinsic_op (gfc_expr *p, int type) |
6de9cd9a | 799 | { |
3bed9dd0 | 800 | gfc_intrinsic_op op; |
6de9cd9a DN |
801 | gfc_expr *op1, *op2, *result; |
802 | ||
58b03ab2 | 803 | if (p->value.op.operator == INTRINSIC_USER) |
6de9cd9a DN |
804 | return SUCCESS; |
805 | ||
58b03ab2 TS |
806 | op1 = p->value.op.op1; |
807 | op2 = p->value.op.op2; | |
3bed9dd0 | 808 | op = p->value.op.operator; |
6de9cd9a DN |
809 | |
810 | if (gfc_simplify_expr (op1, type) == FAILURE) | |
811 | return FAILURE; | |
812 | if (gfc_simplify_expr (op2, type) == FAILURE) | |
813 | return FAILURE; | |
814 | ||
815 | if (!gfc_is_constant_expr (op1) | |
816 | || (op2 != NULL && !gfc_is_constant_expr (op2))) | |
817 | return SUCCESS; | |
818 | ||
66e4ab31 | 819 | /* Rip p apart. */ |
58b03ab2 TS |
820 | p->value.op.op1 = NULL; |
821 | p->value.op.op2 = NULL; | |
6de9cd9a | 822 | |
3bed9dd0 | 823 | switch (op) |
6de9cd9a | 824 | { |
2414e1d6 | 825 | case INTRINSIC_PARENTHESES: |
2f118814 TS |
826 | result = gfc_parentheses (op1); |
827 | break; | |
828 | ||
829 | case INTRINSIC_UPLUS: | |
6de9cd9a DN |
830 | result = gfc_uplus (op1); |
831 | break; | |
832 | ||
833 | case INTRINSIC_UMINUS: | |
834 | result = gfc_uminus (op1); | |
835 | break; | |
836 | ||
837 | case INTRINSIC_PLUS: | |
838 | result = gfc_add (op1, op2); | |
839 | break; | |
840 | ||
841 | case INTRINSIC_MINUS: | |
842 | result = gfc_subtract (op1, op2); | |
843 | break; | |
844 | ||
845 | case INTRINSIC_TIMES: | |
846 | result = gfc_multiply (op1, op2); | |
847 | break; | |
848 | ||
849 | case INTRINSIC_DIVIDE: | |
850 | result = gfc_divide (op1, op2); | |
851 | break; | |
852 | ||
853 | case INTRINSIC_POWER: | |
854 | result = gfc_power (op1, op2); | |
855 | break; | |
856 | ||
857 | case INTRINSIC_CONCAT: | |
858 | result = gfc_concat (op1, op2); | |
859 | break; | |
860 | ||
861 | case INTRINSIC_EQ: | |
3bed9dd0 DF |
862 | case INTRINSIC_EQ_OS: |
863 | result = gfc_eq (op1, op2, op); | |
6de9cd9a DN |
864 | break; |
865 | ||
866 | case INTRINSIC_NE: | |
3bed9dd0 DF |
867 | case INTRINSIC_NE_OS: |
868 | result = gfc_ne (op1, op2, op); | |
6de9cd9a DN |
869 | break; |
870 | ||
871 | case INTRINSIC_GT: | |
3bed9dd0 DF |
872 | case INTRINSIC_GT_OS: |
873 | result = gfc_gt (op1, op2, op); | |
6de9cd9a DN |
874 | break; |
875 | ||
876 | case INTRINSIC_GE: | |
3bed9dd0 DF |
877 | case INTRINSIC_GE_OS: |
878 | result = gfc_ge (op1, op2, op); | |
6de9cd9a DN |
879 | break; |
880 | ||
881 | case INTRINSIC_LT: | |
3bed9dd0 DF |
882 | case INTRINSIC_LT_OS: |
883 | result = gfc_lt (op1, op2, op); | |
6de9cd9a DN |
884 | break; |
885 | ||
886 | case INTRINSIC_LE: | |
3bed9dd0 DF |
887 | case INTRINSIC_LE_OS: |
888 | result = gfc_le (op1, op2, op); | |
6de9cd9a DN |
889 | break; |
890 | ||
891 | case INTRINSIC_NOT: | |
892 | result = gfc_not (op1); | |
893 | break; | |
894 | ||
895 | case INTRINSIC_AND: | |
896 | result = gfc_and (op1, op2); | |
897 | break; | |
898 | ||
899 | case INTRINSIC_OR: | |
900 | result = gfc_or (op1, op2); | |
901 | break; | |
902 | ||
903 | case INTRINSIC_EQV: | |
904 | result = gfc_eqv (op1, op2); | |
905 | break; | |
906 | ||
907 | case INTRINSIC_NEQV: | |
908 | result = gfc_neqv (op1, op2); | |
909 | break; | |
910 | ||
911 | default: | |
912 | gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); | |
913 | } | |
914 | ||
915 | if (result == NULL) | |
916 | { | |
917 | gfc_free_expr (op1); | |
918 | gfc_free_expr (op2); | |
919 | return FAILURE; | |
920 | } | |
921 | ||
0e9a445b PT |
922 | result->rank = p->rank; |
923 | result->where = p->where; | |
6de9cd9a DN |
924 | gfc_replace_expr (p, result); |
925 | ||
926 | return SUCCESS; | |
927 | } | |
928 | ||
929 | ||
930 | /* Subroutine to simplify constructor expressions. Mutually recursive | |
931 | with gfc_simplify_expr(). */ | |
932 | ||
933 | static try | |
636dff67 | 934 | simplify_constructor (gfc_constructor *c, int type) |
6de9cd9a | 935 | { |
6de9cd9a DN |
936 | for (; c; c = c->next) |
937 | { | |
938 | if (c->iterator | |
939 | && (gfc_simplify_expr (c->iterator->start, type) == FAILURE | |
940 | || gfc_simplify_expr (c->iterator->end, type) == FAILURE | |
941 | || gfc_simplify_expr (c->iterator->step, type) == FAILURE)) | |
942 | return FAILURE; | |
943 | ||
944 | if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE) | |
945 | return FAILURE; | |
946 | } | |
947 | ||
948 | return SUCCESS; | |
949 | } | |
950 | ||
951 | ||
952 | /* Pull a single array element out of an array constructor. */ | |
953 | ||
a4a11197 | 954 | static try |
636dff67 SK |
955 | find_array_element (gfc_constructor *cons, gfc_array_ref *ar, |
956 | gfc_constructor **rval) | |
6de9cd9a DN |
957 | { |
958 | unsigned long nelemen; | |
959 | int i; | |
960 | mpz_t delta; | |
961 | mpz_t offset; | |
4c6b3ec7 PT |
962 | mpz_t span; |
963 | mpz_t tmp; | |
a4a11197 PT |
964 | gfc_expr *e; |
965 | try t; | |
966 | ||
967 | t = SUCCESS; | |
968 | e = NULL; | |
6de9cd9a DN |
969 | |
970 | mpz_init_set_ui (offset, 0); | |
971 | mpz_init (delta); | |
4c6b3ec7 PT |
972 | mpz_init (tmp); |
973 | mpz_init_set_ui (span, 1); | |
6de9cd9a DN |
974 | for (i = 0; i < ar->dimen; i++) |
975 | { | |
a4a11197 PT |
976 | e = gfc_copy_expr (ar->start[i]); |
977 | if (e->expr_type != EXPR_CONSTANT) | |
6de9cd9a DN |
978 | { |
979 | cons = NULL; | |
a4a11197 | 980 | goto depart; |
6de9cd9a | 981 | } |
a4a11197 PT |
982 | |
983 | /* Check the bounds. */ | |
984 | if (ar->as->upper[i] | |
636dff67 SK |
985 | && (mpz_cmp (e->value.integer, ar->as->upper[i]->value.integer) > 0 |
986 | || mpz_cmp (e->value.integer, | |
987 | ar->as->lower[i]->value.integer) < 0)) | |
a4a11197 PT |
988 | { |
989 | gfc_error ("index in dimension %d is out of bounds " | |
990 | "at %L", i + 1, &ar->c_where[i]); | |
991 | cons = NULL; | |
992 | t = FAILURE; | |
993 | goto depart; | |
994 | } | |
995 | ||
636dff67 | 996 | mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); |
4c6b3ec7 | 997 | mpz_mul (delta, delta, span); |
6de9cd9a | 998 | mpz_add (offset, offset, delta); |
4c6b3ec7 PT |
999 | |
1000 | mpz_set_ui (tmp, 1); | |
1001 | mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); | |
1002 | mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); | |
1003 | mpz_mul (span, span, tmp); | |
6de9cd9a DN |
1004 | } |
1005 | ||
1006 | if (cons) | |
1007 | { | |
a4a11197 | 1008 | for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) |
6de9cd9a | 1009 | { |
a4a11197 | 1010 | if (cons->iterator) |
6de9cd9a | 1011 | { |
a4a11197 PT |
1012 | cons = NULL; |
1013 | goto depart; | |
6de9cd9a | 1014 | } |
a4a11197 | 1015 | cons = cons->next; |
6de9cd9a | 1016 | } |
6de9cd9a DN |
1017 | } |
1018 | ||
a4a11197 | 1019 | depart: |
6de9cd9a DN |
1020 | mpz_clear (delta); |
1021 | mpz_clear (offset); | |
4c6b3ec7 PT |
1022 | mpz_clear (span); |
1023 | mpz_clear (tmp); | |
a4a11197 PT |
1024 | if (e) |
1025 | gfc_free_expr (e); | |
1026 | *rval = cons; | |
1027 | return t; | |
6de9cd9a DN |
1028 | } |
1029 | ||
1030 | ||
1031 | /* Find a component of a structure constructor. */ | |
1032 | ||
1033 | static gfc_constructor * | |
636dff67 | 1034 | find_component_ref (gfc_constructor *cons, gfc_ref *ref) |
6de9cd9a DN |
1035 | { |
1036 | gfc_component *comp; | |
1037 | gfc_component *pick; | |
1038 | ||
1039 | comp = ref->u.c.sym->components; | |
1040 | pick = ref->u.c.component; | |
1041 | while (comp != pick) | |
1042 | { | |
1043 | comp = comp->next; | |
1044 | cons = cons->next; | |
1045 | } | |
1046 | ||
1047 | return cons; | |
1048 | } | |
1049 | ||
1050 | ||
1051 | /* Replace an expression with the contents of a constructor, removing | |
1052 | the subobject reference in the process. */ | |
1053 | ||
1054 | static void | |
636dff67 | 1055 | remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) |
6de9cd9a DN |
1056 | { |
1057 | gfc_expr *e; | |
1058 | ||
1059 | e = cons->expr; | |
1060 | cons->expr = NULL; | |
1061 | e->ref = p->ref->next; | |
1062 | p->ref->next = NULL; | |
1063 | gfc_replace_expr (p, e); | |
1064 | } | |
1065 | ||
1066 | ||
a4a11197 PT |
1067 | /* Pull an array section out of an array constructor. */ |
1068 | ||
1069 | static try | |
1070 | find_array_section (gfc_expr *expr, gfc_ref *ref) | |
1071 | { | |
1072 | int idx; | |
1073 | int rank; | |
1074 | int d; | |
abe601c7 | 1075 | int shape_i; |
a4a11197 | 1076 | long unsigned one = 1; |
abe601c7 | 1077 | bool incr_ctr; |
3e978d30 | 1078 | mpz_t start[GFC_MAX_DIMENSIONS]; |
a4a11197 PT |
1079 | mpz_t end[GFC_MAX_DIMENSIONS]; |
1080 | mpz_t stride[GFC_MAX_DIMENSIONS]; | |
1081 | mpz_t delta[GFC_MAX_DIMENSIONS]; | |
1082 | mpz_t ctr[GFC_MAX_DIMENSIONS]; | |
1083 | mpz_t delta_mpz; | |
1084 | mpz_t tmp_mpz; | |
1085 | mpz_t nelts; | |
1086 | mpz_t ptr; | |
a4a11197 PT |
1087 | mpz_t index; |
1088 | gfc_constructor *cons; | |
1089 | gfc_constructor *base; | |
1090 | gfc_expr *begin; | |
1091 | gfc_expr *finish; | |
1092 | gfc_expr *step; | |
1093 | gfc_expr *upper; | |
1094 | gfc_expr *lower; | |
abe601c7 | 1095 | gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c; |
a4a11197 PT |
1096 | try t; |
1097 | ||
1098 | t = SUCCESS; | |
1099 | ||
1100 | base = expr->value.constructor; | |
1101 | expr->value.constructor = NULL; | |
1102 | ||
1103 | rank = ref->u.ar.as->rank; | |
1104 | ||
1105 | if (expr->shape == NULL) | |
1106 | expr->shape = gfc_get_shape (rank); | |
1107 | ||
1108 | mpz_init_set_ui (delta_mpz, one); | |
1109 | mpz_init_set_ui (nelts, one); | |
1110 | mpz_init (tmp_mpz); | |
1111 | ||
1112 | /* Do the initialization now, so that we can cleanup without | |
1113 | keeping track of where we were. */ | |
1114 | for (d = 0; d < rank; d++) | |
1115 | { | |
1116 | mpz_init (delta[d]); | |
3e978d30 | 1117 | mpz_init (start[d]); |
a4a11197 PT |
1118 | mpz_init (end[d]); |
1119 | mpz_init (ctr[d]); | |
1120 | mpz_init (stride[d]); | |
abe601c7 | 1121 | vecsub[d] = NULL; |
a4a11197 PT |
1122 | } |
1123 | ||
1124 | /* Build the counters to clock through the array reference. */ | |
abe601c7 | 1125 | shape_i = 0; |
a4a11197 PT |
1126 | for (d = 0; d < rank; d++) |
1127 | { | |
1128 | /* Make this stretch of code easier on the eye! */ | |
1129 | begin = ref->u.ar.start[d]; | |
1130 | finish = ref->u.ar.end[d]; | |
1131 | step = ref->u.ar.stride[d]; | |
1132 | lower = ref->u.ar.as->lower[d]; | |
1133 | upper = ref->u.ar.as->upper[d]; | |
1134 | ||
abe601c7 | 1135 | if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ |
636dff67 SK |
1136 | { |
1137 | gcc_assert (begin); | |
945a98a4 TB |
1138 | |
1139 | if (begin->expr_type != EXPR_ARRAY) | |
1140 | { | |
1141 | t = FAILURE; | |
1142 | goto cleanup; | |
1143 | } | |
1144 | ||
636dff67 SK |
1145 | gcc_assert (begin->rank == 1); |
1146 | gcc_assert (begin->shape); | |
a4a11197 | 1147 | |
abe601c7 EE |
1148 | vecsub[d] = begin->value.constructor; |
1149 | mpz_set (ctr[d], vecsub[d]->expr->value.integer); | |
1150 | mpz_mul (nelts, nelts, begin->shape[0]); | |
1151 | mpz_set (expr->shape[shape_i++], begin->shape[0]); | |
a4a11197 | 1152 | |
abe601c7 EE |
1153 | /* Check bounds. */ |
1154 | for (c = vecsub[d]; c; c = c->next) | |
1155 | { | |
1156 | if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0 | |
636dff67 SK |
1157 | || mpz_cmp (c->expr->value.integer, |
1158 | lower->value.integer) < 0) | |
abe601c7 EE |
1159 | { |
1160 | gfc_error ("index in dimension %d is out of bounds " | |
1161 | "at %L", d + 1, &ref->u.ar.c_where[d]); | |
1162 | t = FAILURE; | |
1163 | goto cleanup; | |
1164 | } | |
1165 | } | |
636dff67 | 1166 | } |
a4a11197 | 1167 | else |
636dff67 | 1168 | { |
abe601c7 | 1169 | if ((begin && begin->expr_type != EXPR_CONSTANT) |
636dff67 SK |
1170 | || (finish && finish->expr_type != EXPR_CONSTANT) |
1171 | || (step && step->expr_type != EXPR_CONSTANT)) | |
abe601c7 EE |
1172 | { |
1173 | t = FAILURE; | |
1174 | goto cleanup; | |
1175 | } | |
c71d6a56 | 1176 | |
abe601c7 EE |
1177 | /* Obtain the stride. */ |
1178 | if (step) | |
1179 | mpz_set (stride[d], step->value.integer); | |
1180 | else | |
1181 | mpz_set_ui (stride[d], one); | |
a4a11197 | 1182 | |
abe601c7 EE |
1183 | if (mpz_cmp_ui (stride[d], 0) == 0) |
1184 | mpz_set_ui (stride[d], one); | |
a4a11197 | 1185 | |
abe601c7 EE |
1186 | /* Obtain the start value for the index. */ |
1187 | if (begin) | |
1188 | mpz_set (start[d], begin->value.integer); | |
1189 | else | |
1190 | mpz_set (start[d], lower->value.integer); | |
a4a11197 | 1191 | |
abe601c7 | 1192 | mpz_set (ctr[d], start[d]); |
a4a11197 | 1193 | |
abe601c7 EE |
1194 | /* Obtain the end value for the index. */ |
1195 | if (finish) | |
1196 | mpz_set (end[d], finish->value.integer); | |
1197 | else | |
1198 | mpz_set (end[d], upper->value.integer); | |
1199 | ||
1200 | /* Separate 'if' because elements sometimes arrive with | |
1201 | non-null end. */ | |
1202 | if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) | |
1203 | mpz_set (end [d], begin->value.integer); | |
1204 | ||
1205 | /* Check the bounds. */ | |
1206 | if (mpz_cmp (ctr[d], upper->value.integer) > 0 | |
1207 | || mpz_cmp (end[d], upper->value.integer) > 0 | |
1208 | || mpz_cmp (ctr[d], lower->value.integer) < 0 | |
1209 | || mpz_cmp (end[d], lower->value.integer) < 0) | |
1210 | { | |
1211 | gfc_error ("index in dimension %d is out of bounds " | |
1212 | "at %L", d + 1, &ref->u.ar.c_where[d]); | |
1213 | t = FAILURE; | |
1214 | goto cleanup; | |
1215 | } | |
a4a11197 | 1216 | |
abe601c7 | 1217 | /* Calculate the number of elements and the shape. */ |
e1e24dc1 | 1218 | mpz_set (tmp_mpz, stride[d]); |
abe601c7 EE |
1219 | mpz_add (tmp_mpz, end[d], tmp_mpz); |
1220 | mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); | |
1221 | mpz_div (tmp_mpz, tmp_mpz, stride[d]); | |
1222 | mpz_mul (nelts, nelts, tmp_mpz); | |
1223 | ||
636dff67 SK |
1224 | /* An element reference reduces the rank of the expression; don't |
1225 | add anything to the shape array. */ | |
abe601c7 EE |
1226 | if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) |
1227 | mpz_set (expr->shape[shape_i++], tmp_mpz); | |
1228 | } | |
a4a11197 PT |
1229 | |
1230 | /* Calculate the 'stride' (=delta) for conversion of the | |
1231 | counter values into the index along the constructor. */ | |
1232 | mpz_set (delta[d], delta_mpz); | |
1233 | mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); | |
1234 | mpz_add_ui (tmp_mpz, tmp_mpz, one); | |
1235 | mpz_mul (delta_mpz, delta_mpz, tmp_mpz); | |
1236 | } | |
1237 | ||
1238 | mpz_init (index); | |
1239 | mpz_init (ptr); | |
a4a11197 PT |
1240 | cons = base; |
1241 | ||
1242 | /* Now clock through the array reference, calculating the index in | |
1243 | the source constructor and transferring the elements to the new | |
1244 | constructor. */ | |
636dff67 | 1245 | for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) |
a4a11197 PT |
1246 | { |
1247 | if (ref->u.ar.offset) | |
1248 | mpz_set (ptr, ref->u.ar.offset->value.integer); | |
1249 | else | |
1250 | mpz_init_set_ui (ptr, 0); | |
1251 | ||
abe601c7 | 1252 | incr_ctr = true; |
a4a11197 PT |
1253 | for (d = 0; d < rank; d++) |
1254 | { | |
1255 | mpz_set (tmp_mpz, ctr[d]); | |
636dff67 | 1256 | mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); |
a4a11197 PT |
1257 | mpz_mul (tmp_mpz, tmp_mpz, delta[d]); |
1258 | mpz_add (ptr, ptr, tmp_mpz); | |
1259 | ||
abe601c7 | 1260 | if (!incr_ctr) continue; |
a4a11197 | 1261 | |
636dff67 | 1262 | if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ |
abe601c7 EE |
1263 | { |
1264 | gcc_assert(vecsub[d]); | |
1265 | ||
1266 | if (!vecsub[d]->next) | |
1267 | vecsub[d] = ref->u.ar.start[d]->value.constructor; | |
1268 | else | |
1269 | { | |
1270 | vecsub[d] = vecsub[d]->next; | |
1271 | incr_ctr = false; | |
1272 | } | |
1273 | mpz_set (ctr[d], vecsub[d]->expr->value.integer); | |
1274 | } | |
a4a11197 | 1275 | else |
abe601c7 EE |
1276 | { |
1277 | mpz_add (ctr[d], ctr[d], stride[d]); | |
1278 | ||
636dff67 SK |
1279 | if (mpz_cmp_ui (stride[d], 0) > 0 |
1280 | ? mpz_cmp (ctr[d], end[d]) > 0 | |
1281 | : mpz_cmp (ctr[d], end[d]) < 0) | |
abe601c7 EE |
1282 | mpz_set (ctr[d], start[d]); |
1283 | else | |
1284 | incr_ctr = false; | |
1285 | } | |
a4a11197 PT |
1286 | } |
1287 | ||
1288 | /* There must be a better way of dealing with negative strides | |
1289 | than resetting the index and the constructor pointer! */ | |
1290 | if (mpz_cmp (ptr, index) < 0) | |
1291 | { | |
1292 | mpz_set_ui (index, 0); | |
1293 | cons = base; | |
1294 | } | |
1295 | ||
1296 | while (mpz_cmp (ptr, index) > 0) | |
1297 | { | |
1298 | mpz_add_ui (index, index, one); | |
1299 | cons = cons->next; | |
1300 | } | |
1301 | ||
1302 | gfc_append_constructor (expr, gfc_copy_expr (cons->expr)); | |
1303 | } | |
1304 | ||
1305 | mpz_clear (ptr); | |
1306 | mpz_clear (index); | |
a4a11197 PT |
1307 | |
1308 | cleanup: | |
1309 | ||
1310 | mpz_clear (delta_mpz); | |
1311 | mpz_clear (tmp_mpz); | |
1312 | mpz_clear (nelts); | |
1313 | for (d = 0; d < rank; d++) | |
1314 | { | |
1315 | mpz_clear (delta[d]); | |
3e978d30 | 1316 | mpz_clear (start[d]); |
a4a11197 PT |
1317 | mpz_clear (end[d]); |
1318 | mpz_clear (ctr[d]); | |
1319 | mpz_clear (stride[d]); | |
1320 | } | |
1321 | gfc_free_constructor (base); | |
1322 | return t; | |
1323 | } | |
1324 | ||
1325 | /* Pull a substring out of an expression. */ | |
1326 | ||
1327 | static try | |
1328 | find_substring_ref (gfc_expr *p, gfc_expr **newp) | |
1329 | { | |
1330 | int end; | |
1331 | int start; | |
1332 | char *chr; | |
1333 | ||
1334 | if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT | |
636dff67 | 1335 | || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) |
a4a11197 PT |
1336 | return FAILURE; |
1337 | ||
1338 | *newp = gfc_copy_expr (p); | |
1339 | chr = p->value.character.string; | |
636dff67 SK |
1340 | end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer); |
1341 | start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer); | |
a4a11197 PT |
1342 | |
1343 | (*newp)->value.character.length = end - start + 1; | |
1344 | strncpy ((*newp)->value.character.string, &chr[start - 1], | |
1345 | (*newp)->value.character.length); | |
1346 | return SUCCESS; | |
1347 | } | |
1348 | ||
1349 | ||
1350 | ||
6de9cd9a DN |
1351 | /* Simplify a subobject reference of a constructor. This occurs when |
1352 | parameter variable values are substituted. */ | |
1353 | ||
1354 | static try | |
636dff67 | 1355 | simplify_const_ref (gfc_expr *p) |
6de9cd9a DN |
1356 | { |
1357 | gfc_constructor *cons; | |
a4a11197 | 1358 | gfc_expr *newp; |
6de9cd9a DN |
1359 | |
1360 | while (p->ref) | |
1361 | { | |
1362 | switch (p->ref->type) | |
1363 | { | |
1364 | case REF_ARRAY: | |
1365 | switch (p->ref->u.ar.type) | |
1366 | { | |
1367 | case AR_ELEMENT: | |
636dff67 | 1368 | if (find_array_element (p->value.constructor, &p->ref->u.ar, |
a4a11197 PT |
1369 | &cons) == FAILURE) |
1370 | return FAILURE; | |
1371 | ||
6de9cd9a DN |
1372 | if (!cons) |
1373 | return SUCCESS; | |
a4a11197 | 1374 | |
6de9cd9a DN |
1375 | remove_subobject_ref (p, cons); |
1376 | break; | |
1377 | ||
a4a11197 PT |
1378 | case AR_SECTION: |
1379 | if (find_array_section (p, p->ref) == FAILURE) | |
1380 | return FAILURE; | |
1381 | p->ref->u.ar.type = AR_FULL; | |
1382 | ||
66e4ab31 | 1383 | /* Fall through. */ |
a4a11197 | 1384 | |
6de9cd9a | 1385 | case AR_FULL: |
a4a11197 | 1386 | if (p->ref->next != NULL |
636dff67 | 1387 | && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) |
6de9cd9a | 1388 | { |
a4a11197 PT |
1389 | cons = p->value.constructor; |
1390 | for (; cons; cons = cons->next) | |
1391 | { | |
1392 | cons->expr->ref = copy_ref (p->ref->next); | |
1393 | simplify_const_ref (cons->expr); | |
1394 | } | |
6de9cd9a | 1395 | } |
a4a11197 PT |
1396 | gfc_free_ref_list (p->ref); |
1397 | p->ref = NULL; | |
6de9cd9a DN |
1398 | break; |
1399 | ||
1400 | default: | |
6de9cd9a DN |
1401 | return SUCCESS; |
1402 | } | |
1403 | ||
1404 | break; | |
1405 | ||
1406 | case REF_COMPONENT: | |
1407 | cons = find_component_ref (p->value.constructor, p->ref); | |
1408 | remove_subobject_ref (p, cons); | |
1409 | break; | |
1410 | ||
1411 | case REF_SUBSTRING: | |
a4a11197 PT |
1412 | if (find_substring_ref (p, &newp) == FAILURE) |
1413 | return FAILURE; | |
1414 | ||
1415 | gfc_replace_expr (p, newp); | |
1416 | gfc_free_ref_list (p->ref); | |
1417 | p->ref = NULL; | |
1418 | break; | |
6de9cd9a DN |
1419 | } |
1420 | } | |
1421 | ||
1422 | return SUCCESS; | |
1423 | } | |
1424 | ||
1425 | ||
1426 | /* Simplify a chain of references. */ | |
1427 | ||
1428 | static try | |
636dff67 | 1429 | simplify_ref_chain (gfc_ref *ref, int type) |
6de9cd9a DN |
1430 | { |
1431 | int n; | |
1432 | ||
1433 | for (; ref; ref = ref->next) | |
1434 | { | |
1435 | switch (ref->type) | |
1436 | { | |
1437 | case REF_ARRAY: | |
1438 | for (n = 0; n < ref->u.ar.dimen; n++) | |
1439 | { | |
636dff67 | 1440 | if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE) |
6de9cd9a | 1441 | return FAILURE; |
636dff67 | 1442 | if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE) |
6de9cd9a | 1443 | return FAILURE; |
636dff67 | 1444 | if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE) |
6de9cd9a DN |
1445 | return FAILURE; |
1446 | } | |
1447 | break; | |
1448 | ||
1449 | case REF_SUBSTRING: | |
1450 | if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE) | |
1451 | return FAILURE; | |
1452 | if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE) | |
1453 | return FAILURE; | |
1454 | break; | |
1455 | ||
1456 | default: | |
1457 | break; | |
1458 | } | |
1459 | } | |
1460 | return SUCCESS; | |
1461 | } | |
1462 | ||
1463 | ||
1464 | /* Try to substitute the value of a parameter variable. */ | |
66e4ab31 | 1465 | |
6de9cd9a | 1466 | static try |
636dff67 | 1467 | simplify_parameter_variable (gfc_expr *p, int type) |
6de9cd9a DN |
1468 | { |
1469 | gfc_expr *e; | |
1470 | try t; | |
1471 | ||
1472 | e = gfc_copy_expr (p->symtree->n.sym->value); | |
a4a11197 PT |
1473 | if (e == NULL) |
1474 | return FAILURE; | |
1475 | ||
b9703d98 EE |
1476 | e->rank = p->rank; |
1477 | ||
c2fee3de DE |
1478 | /* Do not copy subobject refs for constant. */ |
1479 | if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) | |
6de9cd9a DN |
1480 | e->ref = copy_ref (p->ref); |
1481 | t = gfc_simplify_expr (e, type); | |
1482 | ||
66e4ab31 | 1483 | /* Only use the simplification if it eliminated all subobject references. */ |
636dff67 | 1484 | if (t == SUCCESS && !e->ref) |
6de9cd9a DN |
1485 | gfc_replace_expr (p, e); |
1486 | else | |
1487 | gfc_free_expr (e); | |
1488 | ||
1489 | return t; | |
1490 | } | |
1491 | ||
1492 | /* Given an expression, simplify it by collapsing constant | |
1493 | expressions. Most simplification takes place when the expression | |
1494 | tree is being constructed. If an intrinsic function is simplified | |
1495 | at some point, we get called again to collapse the result against | |
1496 | other constants. | |
1497 | ||
1498 | We work by recursively simplifying expression nodes, simplifying | |
1499 | intrinsic functions where possible, which can lead to further | |
1500 | constant collapsing. If an operator has constant operand(s), we | |
1501 | rip the expression apart, and rebuild it, hoping that it becomes | |
1502 | something simpler. | |
1503 | ||
1504 | The expression type is defined for: | |
1505 | 0 Basic expression parsing | |
1506 | 1 Simplifying array constructors -- will substitute | |
636dff67 | 1507 | iterator values. |
6de9cd9a DN |
1508 | Returns FAILURE on error, SUCCESS otherwise. |
1509 | NOTE: Will return SUCCESS even if the expression can not be simplified. */ | |
1510 | ||
1511 | try | |
636dff67 | 1512 | gfc_simplify_expr (gfc_expr *p, int type) |
6de9cd9a DN |
1513 | { |
1514 | gfc_actual_arglist *ap; | |
1515 | ||
1516 | if (p == NULL) | |
1517 | return SUCCESS; | |
1518 | ||
1519 | switch (p->expr_type) | |
1520 | { | |
1521 | case EXPR_CONSTANT: | |
1522 | case EXPR_NULL: | |
1523 | break; | |
1524 | ||
1525 | case EXPR_FUNCTION: | |
1526 | for (ap = p->value.function.actual; ap; ap = ap->next) | |
1527 | if (gfc_simplify_expr (ap->expr, type) == FAILURE) | |
1528 | return FAILURE; | |
1529 | ||
1530 | if (p->value.function.isym != NULL | |
1531 | && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) | |
1532 | return FAILURE; | |
1533 | ||
1534 | break; | |
1535 | ||
1536 | case EXPR_SUBSTRING: | |
eac33acc | 1537 | if (simplify_ref_chain (p->ref, type) == FAILURE) |
6de9cd9a DN |
1538 | return FAILURE; |
1539 | ||
c2fee3de DE |
1540 | if (gfc_is_constant_expr (p)) |
1541 | { | |
1542 | char *s; | |
1543 | int start, end; | |
1544 | ||
1545 | gfc_extract_int (p->ref->u.ss.start, &start); | |
1546 | start--; /* Convert from one-based to zero-based. */ | |
1547 | gfc_extract_int (p->ref->u.ss.end, &end); | |
d6910bb5 | 1548 | s = gfc_getmem (end - start + 2); |
c2fee3de | 1549 | memcpy (s, p->value.character.string + start, end - start); |
636dff67 | 1550 | s[end - start + 1] = '\0'; /* TODO: C-style string. */ |
c2fee3de DE |
1551 | gfc_free (p->value.character.string); |
1552 | p->value.character.string = s; | |
1553 | p->value.character.length = end - start; | |
1554 | p->ts.cl = gfc_get_charlen (); | |
1555 | p->ts.cl->next = gfc_current_ns->cl_list; | |
1556 | gfc_current_ns->cl_list = p->ts.cl; | |
1557 | p->ts.cl->length = gfc_int_expr (p->value.character.length); | |
1558 | gfc_free_ref_list (p->ref); | |
1559 | p->ref = NULL; | |
1560 | p->expr_type = EXPR_CONSTANT; | |
1561 | } | |
6de9cd9a DN |
1562 | break; |
1563 | ||
1564 | case EXPR_OP: | |
1565 | if (simplify_intrinsic_op (p, type) == FAILURE) | |
1566 | return FAILURE; | |
1567 | break; | |
1568 | ||
1569 | case EXPR_VARIABLE: | |
1570 | /* Only substitute array parameter variables if we are in an | |
636dff67 | 1571 | initialization expression, or we want a subsection. */ |
6de9cd9a DN |
1572 | if (p->symtree->n.sym->attr.flavor == FL_PARAMETER |
1573 | && (gfc_init_expr || p->ref | |
1574 | || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) | |
1575 | { | |
1576 | if (simplify_parameter_variable (p, type) == FAILURE) | |
1577 | return FAILURE; | |
1578 | break; | |
1579 | } | |
1580 | ||
1581 | if (type == 1) | |
1582 | { | |
1583 | gfc_simplify_iterator_var (p); | |
1584 | } | |
1585 | ||
1586 | /* Simplify subcomponent references. */ | |
1587 | if (simplify_ref_chain (p->ref, type) == FAILURE) | |
1588 | return FAILURE; | |
1589 | ||
1590 | break; | |
1591 | ||
1592 | case EXPR_STRUCTURE: | |
1593 | case EXPR_ARRAY: | |
1594 | if (simplify_ref_chain (p->ref, type) == FAILURE) | |
1595 | return FAILURE; | |
1596 | ||
1597 | if (simplify_constructor (p->value.constructor, type) == FAILURE) | |
1598 | return FAILURE; | |
1599 | ||
636dff67 SK |
1600 | if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY |
1601 | && p->ref->u.ar.type == AR_FULL) | |
6de9cd9a DN |
1602 | gfc_expand_constructor (p); |
1603 | ||
1604 | if (simplify_const_ref (p) == FAILURE) | |
1605 | return FAILURE; | |
1606 | ||
1607 | break; | |
1608 | } | |
1609 | ||
1610 | return SUCCESS; | |
1611 | } | |
1612 | ||
1613 | ||
1614 | /* Returns the type of an expression with the exception that iterator | |
1615 | variables are automatically integers no matter what else they may | |
1616 | be declared as. */ | |
1617 | ||
1618 | static bt | |
636dff67 | 1619 | et0 (gfc_expr *e) |
6de9cd9a | 1620 | { |
6de9cd9a DN |
1621 | if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS) |
1622 | return BT_INTEGER; | |
1623 | ||
1624 | return e->ts.type; | |
1625 | } | |
1626 | ||
1627 | ||
1628 | /* Check an intrinsic arithmetic operation to see if it is consistent | |
1629 | with some type of expression. */ | |
1630 | ||
1631 | static try check_init_expr (gfc_expr *); | |
1632 | ||
396b2c19 PT |
1633 | |
1634 | /* Scalarize an expression for an elemental intrinsic call. */ | |
1635 | ||
1636 | static try | |
1637 | scalarize_intrinsic_call (gfc_expr *e) | |
1638 | { | |
1639 | gfc_actual_arglist *a, *b; | |
1640 | gfc_constructor *args[5], *ctor, *new_ctor; | |
1641 | gfc_expr *expr, *old; | |
1642 | int n, i, rank[5]; | |
1643 | ||
1644 | old = gfc_copy_expr (e); | |
1645 | ||
1646 | /* Assume that the old expression carries the type information and | |
1647 | that the first arg carries all the shape information. */ | |
1648 | expr = gfc_copy_expr (old->value.function.actual->expr); | |
1649 | gfc_free_constructor (expr->value.constructor); | |
1650 | expr->value.constructor = NULL; | |
1651 | ||
1652 | expr->ts = old->ts; | |
1653 | expr->expr_type = EXPR_ARRAY; | |
1654 | ||
1655 | /* Copy the array argument constructors into an array, with nulls | |
1656 | for the scalars. */ | |
1657 | n = 0; | |
1658 | a = old->value.function.actual; | |
1659 | for (; a; a = a->next) | |
1660 | { | |
1661 | /* Check that this is OK for an initialization expression. */ | |
1662 | if (a->expr && check_init_expr (a->expr) == FAILURE) | |
1663 | goto cleanup; | |
1664 | ||
1665 | rank[n] = 0; | |
1666 | if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) | |
1667 | { | |
1668 | rank[n] = a->expr->rank; | |
1669 | ctor = a->expr->symtree->n.sym->value->value.constructor; | |
1670 | args[n] = gfc_copy_constructor (ctor); | |
1671 | } | |
1672 | else if (a->expr && a->expr->expr_type == EXPR_ARRAY) | |
1673 | { | |
1674 | if (a->expr->rank) | |
1675 | rank[n] = a->expr->rank; | |
1676 | else | |
1677 | rank[n] = 1; | |
1678 | args[n] = gfc_copy_constructor (a->expr->value.constructor); | |
1679 | } | |
1680 | else | |
1681 | args[n] = NULL; | |
1682 | n++; | |
1683 | } | |
1684 | ||
1685 | for (i = 1; i < n; i++) | |
1686 | if (rank[i] && rank[i] != rank[0]) | |
1687 | goto compliance; | |
1688 | ||
1689 | /* Using the first argument as the master, step through the array | |
1690 | calling the function for each element and advancing the array | |
1691 | constructors together. */ | |
1692 | ctor = args[0]; | |
1693 | new_ctor = NULL; | |
1694 | for (; ctor; ctor = ctor->next) | |
1695 | { | |
1696 | if (expr->value.constructor == NULL) | |
1697 | expr->value.constructor | |
1698 | = new_ctor = gfc_get_constructor (); | |
1699 | else | |
1700 | { | |
1701 | new_ctor->next = gfc_get_constructor (); | |
1702 | new_ctor = new_ctor->next; | |
1703 | } | |
1704 | new_ctor->expr = gfc_copy_expr (old); | |
1705 | gfc_free_actual_arglist (new_ctor->expr->value.function.actual); | |
1706 | a = NULL; | |
1707 | b = old->value.function.actual; | |
1708 | for (i = 0; i < n; i++) | |
1709 | { | |
1710 | if (a == NULL) | |
1711 | new_ctor->expr->value.function.actual | |
1712 | = a = gfc_get_actual_arglist (); | |
1713 | else | |
1714 | { | |
1715 | a->next = gfc_get_actual_arglist (); | |
1716 | a = a->next; | |
1717 | } | |
1718 | if (args[i]) | |
1719 | a->expr = gfc_copy_expr (args[i]->expr); | |
1720 | else | |
1721 | a->expr = gfc_copy_expr (b->expr); | |
1722 | ||
1723 | b = b->next; | |
1724 | } | |
1725 | ||
1726 | /* Simplify the function calls. */ | |
1727 | if (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE) | |
1728 | goto cleanup; | |
1729 | ||
1730 | for (i = 0; i < n; i++) | |
1731 | if (args[i]) | |
1732 | args[i] = args[i]->next; | |
1733 | ||
1734 | for (i = 1; i < n; i++) | |
1735 | if (rank[i] && ((args[i] != NULL && args[0] == NULL) | |
1736 | || (args[i] == NULL && args[0] != NULL))) | |
1737 | goto compliance; | |
1738 | } | |
1739 | ||
1740 | free_expr0 (e); | |
1741 | *e = *expr; | |
1742 | gfc_free_expr (old); | |
1743 | return SUCCESS; | |
1744 | ||
1745 | compliance: | |
1746 | gfc_error_now ("elemental function arguments at %C are not compliant"); | |
1747 | ||
1748 | cleanup: | |
1749 | gfc_free_expr (expr); | |
1750 | gfc_free_expr (old); | |
1751 | return FAILURE; | |
1752 | } | |
1753 | ||
1754 | ||
6de9cd9a | 1755 | static try |
636dff67 | 1756 | check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *)) |
6de9cd9a | 1757 | { |
58b03ab2 TS |
1758 | gfc_expr *op1 = e->value.op.op1; |
1759 | gfc_expr *op2 = e->value.op.op2; | |
6de9cd9a | 1760 | |
58b03ab2 | 1761 | if ((*check_function) (op1) == FAILURE) |
6de9cd9a DN |
1762 | return FAILURE; |
1763 | ||
58b03ab2 | 1764 | switch (e->value.op.operator) |
6de9cd9a DN |
1765 | { |
1766 | case INTRINSIC_UPLUS: | |
1767 | case INTRINSIC_UMINUS: | |
58b03ab2 | 1768 | if (!numeric_type (et0 (op1))) |
6de9cd9a DN |
1769 | goto not_numeric; |
1770 | break; | |
1771 | ||
1772 | case INTRINSIC_EQ: | |
3bed9dd0 | 1773 | case INTRINSIC_EQ_OS: |
6de9cd9a | 1774 | case INTRINSIC_NE: |
3bed9dd0 | 1775 | case INTRINSIC_NE_OS: |
6de9cd9a | 1776 | case INTRINSIC_GT: |
3bed9dd0 | 1777 | case INTRINSIC_GT_OS: |
6de9cd9a | 1778 | case INTRINSIC_GE: |
3bed9dd0 | 1779 | case INTRINSIC_GE_OS: |
6de9cd9a | 1780 | case INTRINSIC_LT: |
3bed9dd0 | 1781 | case INTRINSIC_LT_OS: |
6de9cd9a | 1782 | case INTRINSIC_LE: |
3bed9dd0 | 1783 | case INTRINSIC_LE_OS: |
58b03ab2 | 1784 | if ((*check_function) (op2) == FAILURE) |
e063a048 TS |
1785 | return FAILURE; |
1786 | ||
58b03ab2 TS |
1787 | if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) |
1788 | && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) | |
e063a048 TS |
1789 | { |
1790 | gfc_error ("Numeric or CHARACTER operands are required in " | |
1791 | "expression at %L", &e->where); | |
636dff67 | 1792 | return FAILURE; |
e063a048 TS |
1793 | } |
1794 | break; | |
6de9cd9a DN |
1795 | |
1796 | case INTRINSIC_PLUS: | |
1797 | case INTRINSIC_MINUS: | |
1798 | case INTRINSIC_TIMES: | |
1799 | case INTRINSIC_DIVIDE: | |
1800 | case INTRINSIC_POWER: | |
58b03ab2 | 1801 | if ((*check_function) (op2) == FAILURE) |
6de9cd9a DN |
1802 | return FAILURE; |
1803 | ||
58b03ab2 | 1804 | if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) |
6de9cd9a DN |
1805 | goto not_numeric; |
1806 | ||
58b03ab2 TS |
1807 | if (e->value.op.operator == INTRINSIC_POWER |
1808 | && check_function == check_init_expr && et0 (op2) != BT_INTEGER) | |
6de9cd9a | 1809 | { |
a74897c1 TB |
1810 | if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " |
1811 | "exponent in an initialization " | |
1812 | "expression at %L", &op2->where) | |
1813 | == FAILURE) | |
1814 | return FAILURE; | |
6de9cd9a DN |
1815 | } |
1816 | ||
1817 | break; | |
1818 | ||
1819 | case INTRINSIC_CONCAT: | |
58b03ab2 | 1820 | if ((*check_function) (op2) == FAILURE) |
6de9cd9a DN |
1821 | return FAILURE; |
1822 | ||
58b03ab2 | 1823 | if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) |
6de9cd9a DN |
1824 | { |
1825 | gfc_error ("Concatenation operator in expression at %L " | |
58b03ab2 | 1826 | "must have two CHARACTER operands", &op1->where); |
6de9cd9a DN |
1827 | return FAILURE; |
1828 | } | |
1829 | ||
58b03ab2 | 1830 | if (op1->ts.kind != op2->ts.kind) |
6de9cd9a DN |
1831 | { |
1832 | gfc_error ("Concat operator at %L must concatenate strings of the " | |
1833 | "same kind", &e->where); | |
1834 | return FAILURE; | |
1835 | } | |
1836 | ||
1837 | break; | |
1838 | ||
1839 | case INTRINSIC_NOT: | |
58b03ab2 | 1840 | if (et0 (op1) != BT_LOGICAL) |
6de9cd9a DN |
1841 | { |
1842 | gfc_error (".NOT. operator in expression at %L must have a LOGICAL " | |
58b03ab2 | 1843 | "operand", &op1->where); |
6de9cd9a DN |
1844 | return FAILURE; |
1845 | } | |
1846 | ||
1847 | break; | |
1848 | ||
1849 | case INTRINSIC_AND: | |
1850 | case INTRINSIC_OR: | |
1851 | case INTRINSIC_EQV: | |
1852 | case INTRINSIC_NEQV: | |
58b03ab2 | 1853 | if ((*check_function) (op2) == FAILURE) |
6de9cd9a DN |
1854 | return FAILURE; |
1855 | ||
58b03ab2 | 1856 | if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) |
6de9cd9a DN |
1857 | { |
1858 | gfc_error ("LOGICAL operands are required in expression at %L", | |
1859 | &e->where); | |
1860 | return FAILURE; | |
1861 | } | |
1862 | ||
1863 | break; | |
1864 | ||
083cc293 TS |
1865 | case INTRINSIC_PARENTHESES: |
1866 | break; | |
1867 | ||
6de9cd9a DN |
1868 | default: |
1869 | gfc_error ("Only intrinsic operators can be used in expression at %L", | |
1870 | &e->where); | |
1871 | return FAILURE; | |
1872 | } | |
1873 | ||
1874 | return SUCCESS; | |
1875 | ||
1876 | not_numeric: | |
1877 | gfc_error ("Numeric operands are required in expression at %L", &e->where); | |
1878 | ||
1879 | return FAILURE; | |
1880 | } | |
1881 | ||
1882 | ||
e1633d82 DF |
1883 | static match |
1884 | check_init_expr_arguments (gfc_expr *e) | |
1885 | { | |
1886 | gfc_actual_arglist *ap; | |
6de9cd9a | 1887 | |
e1633d82 DF |
1888 | for (ap = e->value.function.actual; ap; ap = ap->next) |
1889 | if (check_init_expr (ap->expr) == FAILURE) | |
1890 | return MATCH_ERROR; | |
6de9cd9a | 1891 | |
e1633d82 DF |
1892 | return MATCH_YES; |
1893 | } | |
1894 | ||
1895 | /* F95, 7.1.6.1, Initialization expressions, (7) | |
1896 | F2003, 7.1.7 Initialization expression, (8) */ | |
1897 | ||
1898 | static match | |
636dff67 | 1899 | check_inquiry (gfc_expr *e, int not_restricted) |
6de9cd9a DN |
1900 | { |
1901 | const char *name; | |
e1633d82 DF |
1902 | const char *const *functions; |
1903 | ||
1904 | static const char *const inquiry_func_f95[] = { | |
1905 | "lbound", "shape", "size", "ubound", | |
1906 | "bit_size", "len", "kind", | |
1907 | "digits", "epsilon", "huge", "maxexponent", "minexponent", | |
1908 | "precision", "radix", "range", "tiny", | |
1909 | NULL | |
1910 | }; | |
6de9cd9a | 1911 | |
e1633d82 DF |
1912 | static const char *const inquiry_func_f2003[] = { |
1913 | "lbound", "shape", "size", "ubound", | |
1914 | "bit_size", "len", "kind", | |
1915 | "digits", "epsilon", "huge", "maxexponent", "minexponent", | |
1916 | "precision", "radix", "range", "tiny", | |
1917 | "new_line", NULL | |
6de9cd9a DN |
1918 | }; |
1919 | ||
1920 | int i; | |
e1633d82 DF |
1921 | gfc_actual_arglist *ap; |
1922 | ||
1923 | if (!e->value.function.isym | |
1924 | || !e->value.function.isym->inquiry) | |
1925 | return MATCH_NO; | |
6de9cd9a | 1926 | |
e7f79e12 PT |
1927 | /* An undeclared parameter will get us here (PR25018). */ |
1928 | if (e->symtree == NULL) | |
e1633d82 | 1929 | return MATCH_NO; |
e7f79e12 | 1930 | |
6de9cd9a DN |
1931 | name = e->symtree->n.sym->name; |
1932 | ||
e1633d82 DF |
1933 | functions = (gfc_option.warn_std & GFC_STD_F2003) |
1934 | ? inquiry_func_f2003 : inquiry_func_f95; | |
6de9cd9a | 1935 | |
e1633d82 DF |
1936 | for (i = 0; functions[i]; i++) |
1937 | if (strcmp (functions[i], name) == 0) | |
1938 | break; | |
6de9cd9a | 1939 | |
e1633d82 DF |
1940 | if (functions[i] == NULL) |
1941 | { | |
1942 | gfc_error ("Inquiry function '%s' at %L is not permitted " | |
1943 | "in an initialization expression", name, &e->where); | |
1944 | return MATCH_ERROR; | |
1945 | } | |
6de9cd9a | 1946 | |
c2b27658 EE |
1947 | /* At this point we have an inquiry function with a variable argument. The |
1948 | type of the variable might be undefined, but we need it now, because the | |
e1633d82 | 1949 | arguments of these functions are not allowed to be undefined. */ |
6de9cd9a | 1950 | |
e1633d82 | 1951 | for (ap = e->value.function.actual; ap; ap = ap->next) |
6de9cd9a | 1952 | { |
e1633d82 DF |
1953 | if (!ap->expr) |
1954 | continue; | |
1955 | ||
1956 | if (ap->expr->ts.type == BT_UNKNOWN) | |
1957 | { | |
1958 | if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN | |
1959 | && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns) | |
1960 | == FAILURE) | |
1961 | return MATCH_NO; | |
6de9cd9a | 1962 | |
e1633d82 DF |
1963 | ap->expr->ts = ap->expr->symtree->n.sym->ts; |
1964 | } | |
1965 | ||
1966 | /* Assumed character length will not reduce to a constant expression | |
1967 | with LEN, as required by the standard. */ | |
1968 | if (i == 5 && not_restricted | |
1969 | && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER | |
1970 | && ap->expr->symtree->n.sym->ts.cl->length == NULL) | |
1971 | { | |
5ab0eadf DF |
1972 | gfc_error ("assumed character length variable '%s' in constant " |
1973 | "expression at %L", e->symtree->n.sym->name, &e->where); | |
e1633d82 DF |
1974 | return MATCH_ERROR; |
1975 | } | |
1976 | else if (not_restricted && check_init_expr (ap->expr) == FAILURE) | |
1977 | return MATCH_ERROR; | |
6de9cd9a DN |
1978 | } |
1979 | ||
e1633d82 DF |
1980 | return MATCH_YES; |
1981 | } | |
1982 | ||
e7f79e12 | 1983 | |
e1633d82 DF |
1984 | /* F95, 7.1.6.1, Initialization expressions, (5) |
1985 | F2003, 7.1.7 Initialization expression, (5) */ | |
1986 | ||
1987 | static match | |
1988 | check_transformational (gfc_expr *e) | |
1989 | { | |
1990 | static const char * const trans_func_f95[] = { | |
1991 | "repeat", "reshape", "selected_int_kind", | |
1992 | "selected_real_kind", "transfer", "trim", NULL | |
1993 | }; | |
1994 | ||
1995 | int i; | |
1996 | const char *name; | |
1997 | ||
1998 | if (!e->value.function.isym | |
1999 | || !e->value.function.isym->transformational) | |
2000 | return MATCH_NO; | |
2001 | ||
2002 | name = e->symtree->n.sym->name; | |
2003 | ||
2004 | /* NULL() is dealt with below. */ | |
2005 | if (strcmp ("null", name) == 0) | |
2006 | return MATCH_NO; | |
2007 | ||
2008 | for (i = 0; trans_func_f95[i]; i++) | |
2009 | if (strcmp (trans_func_f95[i], name) == 0) | |
2010 | break; | |
2011 | ||
5ab0eadf DF |
2012 | /* FIXME, F2003: implement translation of initialization |
2013 | expressions before enabling this check. For F95, error | |
2014 | out if the transformational function is not in the list. */ | |
2015 | #if 0 | |
e1633d82 DF |
2016 | if (trans_func_f95[i] == NULL |
2017 | && gfc_notify_std (GFC_STD_F2003, | |
2018 | "transformational intrinsic '%s' at %L is not permitted " | |
2019 | "in an initialization expression", name, &e->where) == FAILURE) | |
2020 | return MATCH_ERROR; | |
5ab0eadf DF |
2021 | #else |
2022 | if (trans_func_f95[i] == NULL) | |
2023 | { | |
2024 | gfc_error("transformational intrinsic '%s' at %L is not permitted " | |
2025 | "in an initialization expression", name, &e->where); | |
2026 | return MATCH_ERROR; | |
2027 | } | |
2028 | #endif | |
e1633d82 DF |
2029 | |
2030 | return check_init_expr_arguments (e); | |
2031 | } | |
2032 | ||
2033 | ||
2034 | /* F95, 7.1.6.1, Initialization expressions, (6) | |
2035 | F2003, 7.1.7 Initialization expression, (6) */ | |
2036 | ||
2037 | static match | |
2038 | check_null (gfc_expr *e) | |
2039 | { | |
2040 | if (strcmp ("null", e->symtree->n.sym->name) != 0) | |
2041 | return MATCH_NO; | |
2042 | ||
2043 | return check_init_expr_arguments (e); | |
2044 | } | |
2045 | ||
2046 | ||
2047 | static match | |
2048 | check_elemental (gfc_expr *e) | |
2049 | { | |
2050 | if (!e->value.function.isym | |
2051 | || !e->value.function.isym->elemental) | |
2052 | return MATCH_NO; | |
2053 | ||
2054 | if ((e->ts.type != BT_INTEGER || e->ts.type != BT_CHARACTER) | |
2055 | && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of " | |
2056 | "nonstandard initialization expression at %L", | |
2057 | &e->where) == FAILURE) | |
2058 | return MATCH_ERROR; | |
2059 | ||
2060 | return check_init_expr_arguments (e); | |
2061 | } | |
2062 | ||
2063 | ||
2064 | static match | |
2065 | check_conversion (gfc_expr *e) | |
2066 | { | |
2067 | if (!e->value.function.isym | |
2068 | || !e->value.function.isym->conversion) | |
2069 | return MATCH_NO; | |
2070 | ||
2071 | return check_init_expr_arguments (e); | |
6de9cd9a DN |
2072 | } |
2073 | ||
2074 | ||
2075 | /* Verify that an expression is an initialization expression. A side | |
2076 | effect is that the expression tree is reduced to a single constant | |
2077 | node if all goes well. This would normally happen when the | |
2078 | expression is constructed but function references are assumed to be | |
2079 | intrinsics in the context of initialization expressions. If | |
2080 | FAILURE is returned an error message has been generated. */ | |
2081 | ||
2082 | static try | |
636dff67 | 2083 | check_init_expr (gfc_expr *e) |
6de9cd9a | 2084 | { |
6de9cd9a DN |
2085 | match m; |
2086 | try t; | |
396b2c19 | 2087 | gfc_intrinsic_sym *isym; |
6de9cd9a DN |
2088 | |
2089 | if (e == NULL) | |
2090 | return SUCCESS; | |
2091 | ||
2092 | switch (e->expr_type) | |
2093 | { | |
2094 | case EXPR_OP: | |
2095 | t = check_intrinsic_op (e, check_init_expr); | |
2096 | if (t == SUCCESS) | |
2097 | t = gfc_simplify_expr (e, 0); | |
2098 | ||
2099 | break; | |
2100 | ||
2101 | case EXPR_FUNCTION: | |
e1633d82 | 2102 | t = FAILURE; |
396b2c19 | 2103 | |
e1633d82 | 2104 | if ((m = check_specification_function (e)) != MATCH_YES) |
6de9cd9a | 2105 | { |
e1633d82 DF |
2106 | if ((m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) |
2107 | { | |
2108 | gfc_error ("Function '%s' in initialization expression at %L " | |
2109 | "must be an intrinsic or a specification function", | |
2110 | e->symtree->n.sym->name, &e->where); | |
2111 | break; | |
2112 | } | |
6de9cd9a | 2113 | |
e1633d82 DF |
2114 | if ((m = check_conversion (e)) == MATCH_NO |
2115 | && (m = check_inquiry (e, 1)) == MATCH_NO | |
2116 | && (m = check_null (e)) == MATCH_NO | |
2117 | && (m = check_transformational (e)) == MATCH_NO | |
2118 | && (m = check_elemental (e)) == MATCH_NO) | |
2119 | { | |
2120 | gfc_error ("Intrinsic function '%s' at %L is not permitted " | |
2121 | "in an initialization expression", | |
2122 | e->symtree->n.sym->name, &e->where); | |
2123 | m = MATCH_ERROR; | |
2124 | } | |
6de9cd9a | 2125 | |
e1633d82 DF |
2126 | /* Try to scalarize an elemental intrinsic function that has an |
2127 | array argument. */ | |
2128 | isym = gfc_find_function (e->symtree->n.sym->name); | |
2129 | if (isym && isym->elemental | |
2130 | && e->value.function.actual->expr->expr_type == EXPR_ARRAY) | |
2131 | { | |
2132 | if ((t = scalarize_intrinsic_call (e)) == SUCCESS) | |
2133 | break; | |
2134 | } | |
6de9cd9a DN |
2135 | } |
2136 | ||
e1633d82 | 2137 | if (m == MATCH_YES) |
fd8e2796 | 2138 | t = gfc_simplify_expr (e, 0); |
e1633d82 | 2139 | |
6de9cd9a DN |
2140 | break; |
2141 | ||
2142 | case EXPR_VARIABLE: | |
2143 | t = SUCCESS; | |
2144 | ||
2145 | if (gfc_check_iter_variable (e) == SUCCESS) | |
2146 | break; | |
2147 | ||
2148 | if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) | |
2149 | { | |
2150 | t = simplify_parameter_variable (e, 0); | |
2151 | break; | |
2152 | } | |
2153 | ||
2220652d PT |
2154 | if (gfc_in_match_data ()) |
2155 | break; | |
2156 | ||
6de9cd9a | 2157 | t = FAILURE; |
e1633d82 DF |
2158 | |
2159 | if (e->symtree->n.sym->as) | |
2160 | { | |
2161 | switch (e->symtree->n.sym->as->type) | |
2162 | { | |
2163 | case AS_ASSUMED_SIZE: | |
2164 | gfc_error ("assumed size array '%s' at %L is not permitted " | |
2165 | "in an initialization expression", | |
2166 | e->symtree->n.sym->name, &e->where); | |
5ab0eadf | 2167 | break; |
e1633d82 DF |
2168 | |
2169 | case AS_ASSUMED_SHAPE: | |
2170 | gfc_error ("assumed shape array '%s' at %L is not permitted " | |
2171 | "in an initialization expression", | |
2172 | e->symtree->n.sym->name, &e->where); | |
5ab0eadf | 2173 | break; |
e1633d82 DF |
2174 | |
2175 | case AS_DEFERRED: | |
2176 | gfc_error ("deferred array '%s' at %L is not permitted " | |
2177 | "in an initialization expression", | |
2178 | e->symtree->n.sym->name, &e->where); | |
5ab0eadf | 2179 | break; |
e1633d82 DF |
2180 | |
2181 | default: | |
2182 | gcc_unreachable(); | |
2183 | } | |
2184 | } | |
2185 | else | |
2186 | gfc_error ("Parameter '%s' at %L has not been declared or is " | |
2187 | "a variable, which does not reduce to a constant " | |
2188 | "expression", e->symtree->n.sym->name, &e->where); | |
2189 | ||
6de9cd9a DN |
2190 | break; |
2191 | ||
2192 | case EXPR_CONSTANT: | |
2193 | case EXPR_NULL: | |
2194 | t = SUCCESS; | |
2195 | break; | |
2196 | ||
2197 | case EXPR_SUBSTRING: | |
eac33acc | 2198 | t = check_init_expr (e->ref->u.ss.start); |
6de9cd9a DN |
2199 | if (t == FAILURE) |
2200 | break; | |
2201 | ||
eac33acc | 2202 | t = check_init_expr (e->ref->u.ss.end); |
6de9cd9a DN |
2203 | if (t == SUCCESS) |
2204 | t = gfc_simplify_expr (e, 0); | |
2205 | ||
2206 | break; | |
2207 | ||
2208 | case EXPR_STRUCTURE: | |
2209 | t = gfc_check_constructor (e, check_init_expr); | |
2210 | break; | |
2211 | ||
2212 | case EXPR_ARRAY: | |
2213 | t = gfc_check_constructor (e, check_init_expr); | |
2214 | if (t == FAILURE) | |
2215 | break; | |
2216 | ||
2217 | t = gfc_expand_constructor (e); | |
2218 | if (t == FAILURE) | |
2219 | break; | |
2220 | ||
2221 | t = gfc_check_constructor_type (e); | |
2222 | break; | |
2223 | ||
2224 | default: | |
2225 | gfc_internal_error ("check_init_expr(): Unknown expression type"); | |
2226 | } | |
2227 | ||
2228 | return t; | |
2229 | } | |
2230 | ||
2231 | ||
2232 | /* Match an initialization expression. We work by first matching an | |
2233 | expression, then reducing it to a constant. */ | |
2234 | ||
2235 | match | |
636dff67 | 2236 | gfc_match_init_expr (gfc_expr **result) |
6de9cd9a DN |
2237 | { |
2238 | gfc_expr *expr; | |
2239 | match m; | |
2240 | try t; | |
2241 | ||
2242 | m = gfc_match_expr (&expr); | |
2243 | if (m != MATCH_YES) | |
2244 | return m; | |
2245 | ||
2246 | gfc_init_expr = 1; | |
2247 | t = gfc_resolve_expr (expr); | |
2248 | if (t == SUCCESS) | |
2249 | t = check_init_expr (expr); | |
2250 | gfc_init_expr = 0; | |
2251 | ||
2252 | if (t == FAILURE) | |
2253 | { | |
2254 | gfc_free_expr (expr); | |
2255 | return MATCH_ERROR; | |
2256 | } | |
2257 | ||
2258 | if (expr->expr_type == EXPR_ARRAY | |
2259 | && (gfc_check_constructor_type (expr) == FAILURE | |
2260 | || gfc_expand_constructor (expr) == FAILURE)) | |
2261 | { | |
2262 | gfc_free_expr (expr); | |
2263 | return MATCH_ERROR; | |
2264 | } | |
2265 | ||
e7f79e12 PT |
2266 | /* Not all inquiry functions are simplified to constant expressions |
2267 | so it is necessary to call check_inquiry again. */ | |
e1633d82 | 2268 | if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES |
636dff67 | 2269 | && !gfc_in_match_data ()) |
e7f79e12 PT |
2270 | { |
2271 | gfc_error ("Initialization expression didn't reduce %C"); | |
2272 | return MATCH_ERROR; | |
2273 | } | |
6de9cd9a DN |
2274 | |
2275 | *result = expr; | |
2276 | ||
2277 | return MATCH_YES; | |
2278 | } | |
2279 | ||
2280 | ||
6de9cd9a DN |
2281 | static try check_restricted (gfc_expr *); |
2282 | ||
2283 | /* Given an actual argument list, test to see that each argument is a | |
2284 | restricted expression and optionally if the expression type is | |
2285 | integer or character. */ | |
2286 | ||
2287 | static try | |
636dff67 | 2288 | restricted_args (gfc_actual_arglist *a) |
6de9cd9a | 2289 | { |
6de9cd9a DN |
2290 | for (; a; a = a->next) |
2291 | { | |
2292 | if (check_restricted (a->expr) == FAILURE) | |
2293 | return FAILURE; | |
6de9cd9a DN |
2294 | } |
2295 | ||
2296 | return SUCCESS; | |
2297 | } | |
2298 | ||
2299 | ||
2300 | /************* Restricted/specification expressions *************/ | |
2301 | ||
2302 | ||
2303 | /* Make sure a non-intrinsic function is a specification function. */ | |
2304 | ||
2305 | static try | |
636dff67 | 2306 | external_spec_function (gfc_expr *e) |
6de9cd9a DN |
2307 | { |
2308 | gfc_symbol *f; | |
2309 | ||
2310 | f = e->value.function.esym; | |
2311 | ||
2312 | if (f->attr.proc == PROC_ST_FUNCTION) | |
2313 | { | |
2314 | gfc_error ("Specification function '%s' at %L cannot be a statement " | |
2315 | "function", f->name, &e->where); | |
2316 | return FAILURE; | |
2317 | } | |
2318 | ||
2319 | if (f->attr.proc == PROC_INTERNAL) | |
2320 | { | |
2321 | gfc_error ("Specification function '%s' at %L cannot be an internal " | |
2322 | "function", f->name, &e->where); | |
2323 | return FAILURE; | |
2324 | } | |
2325 | ||
98cb5a54 | 2326 | if (!f->attr.pure && !f->attr.elemental) |
6de9cd9a DN |
2327 | { |
2328 | gfc_error ("Specification function '%s' at %L must be PURE", f->name, | |
2329 | &e->where); | |
2330 | return FAILURE; | |
2331 | } | |
2332 | ||
2333 | if (f->attr.recursive) | |
2334 | { | |
2335 | gfc_error ("Specification function '%s' at %L cannot be RECURSIVE", | |
2336 | f->name, &e->where); | |
2337 | return FAILURE; | |
2338 | } | |
2339 | ||
40e929f3 | 2340 | return restricted_args (e->value.function.actual); |
6de9cd9a DN |
2341 | } |
2342 | ||
2343 | ||
2344 | /* Check to see that a function reference to an intrinsic is a | |
40e929f3 | 2345 | restricted expression. */ |
6de9cd9a DN |
2346 | |
2347 | static try | |
636dff67 | 2348 | restricted_intrinsic (gfc_expr *e) |
6de9cd9a | 2349 | { |
40e929f3 | 2350 | /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ |
e1633d82 | 2351 | if (check_inquiry (e, 0) == MATCH_YES) |
40e929f3 | 2352 | return SUCCESS; |
6de9cd9a | 2353 | |
40e929f3 | 2354 | return restricted_args (e->value.function.actual); |
6de9cd9a DN |
2355 | } |
2356 | ||
2357 | ||
2358 | /* Verify that an expression is a restricted expression. Like its | |
2359 | cousin check_init_expr(), an error message is generated if we | |
2360 | return FAILURE. */ | |
2361 | ||
2362 | static try | |
636dff67 | 2363 | check_restricted (gfc_expr *e) |
6de9cd9a DN |
2364 | { |
2365 | gfc_symbol *sym; | |
2366 | try t; | |
2367 | ||
2368 | if (e == NULL) | |
2369 | return SUCCESS; | |
2370 | ||
2371 | switch (e->expr_type) | |
2372 | { | |
2373 | case EXPR_OP: | |
2374 | t = check_intrinsic_op (e, check_restricted); | |
2375 | if (t == SUCCESS) | |
2376 | t = gfc_simplify_expr (e, 0); | |
2377 | ||
2378 | break; | |
2379 | ||
2380 | case EXPR_FUNCTION: | |
636dff67 SK |
2381 | t = e->value.function.esym ? external_spec_function (e) |
2382 | : restricted_intrinsic (e); | |
6de9cd9a DN |
2383 | break; |
2384 | ||
2385 | case EXPR_VARIABLE: | |
2386 | sym = e->symtree->n.sym; | |
2387 | t = FAILURE; | |
2388 | ||
2389 | if (sym->attr.optional) | |
2390 | { | |
2391 | gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL", | |
2392 | sym->name, &e->where); | |
2393 | break; | |
2394 | } | |
2395 | ||
2396 | if (sym->attr.intent == INTENT_OUT) | |
2397 | { | |
2398 | gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)", | |
2399 | sym->name, &e->where); | |
2400 | break; | |
2401 | } | |
2402 | ||
636dff67 SK |
2403 | /* gfc_is_formal_arg broadcasts that a formal argument list is being |
2404 | processed in resolve.c(resolve_formal_arglist). This is done so | |
2405 | that host associated dummy array indices are accepted (PR23446). | |
2406 | This mechanism also does the same for the specification expressions | |
2407 | of array-valued functions. */ | |
6de9cd9a DN |
2408 | if (sym->attr.in_common |
2409 | || sym->attr.use_assoc | |
2410 | || sym->attr.dummy | |
2411 | || sym->ns != gfc_current_ns | |
2412 | || (sym->ns->proc_name != NULL | |
4213f93b | 2413 | && sym->ns->proc_name->attr.flavor == FL_MODULE) |
98bbe5ee | 2414 | || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) |
6de9cd9a DN |
2415 | { |
2416 | t = SUCCESS; | |
2417 | break; | |
2418 | } | |
2419 | ||
2420 | gfc_error ("Variable '%s' cannot appear in the expression at %L", | |
2421 | sym->name, &e->where); | |
2422 | ||
2423 | break; | |
2424 | ||
2425 | case EXPR_NULL: | |
2426 | case EXPR_CONSTANT: | |
2427 | t = SUCCESS; | |
2428 | break; | |
2429 | ||
2430 | case EXPR_SUBSTRING: | |
eac33acc | 2431 | t = gfc_specification_expr (e->ref->u.ss.start); |
6de9cd9a DN |
2432 | if (t == FAILURE) |
2433 | break; | |
2434 | ||
eac33acc | 2435 | t = gfc_specification_expr (e->ref->u.ss.end); |
6de9cd9a DN |
2436 | if (t == SUCCESS) |
2437 | t = gfc_simplify_expr (e, 0); | |
2438 | ||
2439 | break; | |
2440 | ||
2441 | case EXPR_STRUCTURE: | |
2442 | t = gfc_check_constructor (e, check_restricted); | |
2443 | break; | |
2444 | ||
2445 | case EXPR_ARRAY: | |
2446 | t = gfc_check_constructor (e, check_restricted); | |
2447 | break; | |
2448 | ||
2449 | default: | |
2450 | gfc_internal_error ("check_restricted(): Unknown expression type"); | |
2451 | } | |
2452 | ||
2453 | return t; | |
2454 | } | |
2455 | ||
2456 | ||
2457 | /* Check to see that an expression is a specification expression. If | |
2458 | we return FAILURE, an error has been generated. */ | |
2459 | ||
2460 | try | |
636dff67 | 2461 | gfc_specification_expr (gfc_expr *e) |
6de9cd9a | 2462 | { |
66e4ab31 | 2463 | |
110eec24 TS |
2464 | if (e == NULL) |
2465 | return SUCCESS; | |
6de9cd9a DN |
2466 | |
2467 | if (e->ts.type != BT_INTEGER) | |
2468 | { | |
2469 | gfc_error ("Expression at %L must be of INTEGER type", &e->where); | |
2470 | return FAILURE; | |
2471 | } | |
2472 | ||
2473 | if (e->rank != 0) | |
2474 | { | |
2475 | gfc_error ("Expression at %L must be scalar", &e->where); | |
2476 | return FAILURE; | |
2477 | } | |
2478 | ||
2479 | if (gfc_simplify_expr (e, 0) == FAILURE) | |
2480 | return FAILURE; | |
2481 | ||
2482 | return check_restricted (e); | |
2483 | } | |
2484 | ||
2485 | ||
2486 | /************** Expression conformance checks. *************/ | |
2487 | ||
2488 | /* Given two expressions, make sure that the arrays are conformable. */ | |
2489 | ||
2490 | try | |
636dff67 | 2491 | gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2) |
6de9cd9a DN |
2492 | { |
2493 | int op1_flag, op2_flag, d; | |
2494 | mpz_t op1_size, op2_size; | |
2495 | try t; | |
2496 | ||
2497 | if (op1->rank == 0 || op2->rank == 0) | |
2498 | return SUCCESS; | |
2499 | ||
2500 | if (op1->rank != op2->rank) | |
2501 | { | |
31043f6c FXC |
2502 | gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid), |
2503 | &op1->where); | |
6de9cd9a DN |
2504 | return FAILURE; |
2505 | } | |
2506 | ||
2507 | t = SUCCESS; | |
2508 | ||
2509 | for (d = 0; d < op1->rank; d++) | |
2510 | { | |
2511 | op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS; | |
2512 | op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS; | |
2513 | ||
2514 | if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) | |
2515 | { | |
17d761bb | 2516 | gfc_error ("different shape for %s at %L on dimension %d (%d/%d)", |
31043f6c FXC |
2517 | _(optype_msgid), &op1->where, d + 1, |
2518 | (int) mpz_get_si (op1_size), | |
6de9cd9a DN |
2519 | (int) mpz_get_si (op2_size)); |
2520 | ||
2521 | t = FAILURE; | |
2522 | } | |
2523 | ||
2524 | if (op1_flag) | |
2525 | mpz_clear (op1_size); | |
2526 | if (op2_flag) | |
2527 | mpz_clear (op2_size); | |
2528 | ||
2529 | if (t == FAILURE) | |
2530 | return FAILURE; | |
2531 | } | |
2532 | ||
2533 | return SUCCESS; | |
2534 | } | |
2535 | ||
2536 | ||
2537 | /* Given an assignable expression and an arbitrary expression, make | |
2538 | sure that the assignment can take place. */ | |
2539 | ||
2540 | try | |
636dff67 | 2541 | gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) |
6de9cd9a DN |
2542 | { |
2543 | gfc_symbol *sym; | |
f17facac TB |
2544 | gfc_ref *ref; |
2545 | int has_pointer; | |
6de9cd9a DN |
2546 | |
2547 | sym = lvalue->symtree->n.sym; | |
2548 | ||
f17facac TB |
2549 | /* Check INTENT(IN), unless the object itself is the component or |
2550 | sub-component of a pointer. */ | |
2551 | has_pointer = sym->attr.pointer; | |
2552 | ||
2553 | for (ref = lvalue->ref; ref; ref = ref->next) | |
2554 | if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) | |
2555 | { | |
2556 | has_pointer = 1; | |
2557 | break; | |
2558 | } | |
2559 | ||
2560 | if (!has_pointer && sym->attr.intent == INTENT_IN) | |
6de9cd9a | 2561 | { |
f17facac | 2562 | gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L", |
6de9cd9a DN |
2563 | sym->name, &lvalue->where); |
2564 | return FAILURE; | |
2565 | } | |
2566 | ||
66e4ab31 SK |
2567 | /* 12.5.2.2, Note 12.26: The result variable is very similar to any other |
2568 | variable local to a function subprogram. Its existence begins when | |
2569 | execution of the function is initiated and ends when execution of the | |
2570 | function is terminated... | |
2571 | Therefore, the left hand side is no longer a variable, when it is: */ | |
636dff67 SK |
2572 | if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION |
2573 | && !sym->attr.external) | |
2990f854 | 2574 | { |
f5f701ad PT |
2575 | bool bad_proc; |
2576 | bad_proc = false; | |
2577 | ||
66e4ab31 | 2578 | /* (i) Use associated; */ |
f5f701ad PT |
2579 | if (sym->attr.use_assoc) |
2580 | bad_proc = true; | |
2581 | ||
e2ae1407 | 2582 | /* (ii) The assignment is in the main program; or */ |
f5f701ad PT |
2583 | if (gfc_current_ns->proc_name->attr.is_main_program) |
2584 | bad_proc = true; | |
2585 | ||
66e4ab31 | 2586 | /* (iii) A module or internal procedure... */ |
f5f701ad | 2587 | if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL |
636dff67 | 2588 | || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) |
f5f701ad PT |
2589 | && gfc_current_ns->parent |
2590 | && (!(gfc_current_ns->parent->proc_name->attr.function | |
636dff67 | 2591 | || gfc_current_ns->parent->proc_name->attr.subroutine) |
f5f701ad PT |
2592 | || gfc_current_ns->parent->proc_name->attr.is_main_program)) |
2593 | { | |
66e4ab31 | 2594 | /* ... that is not a function... */ |
f5f701ad PT |
2595 | if (!gfc_current_ns->proc_name->attr.function) |
2596 | bad_proc = true; | |
2597 | ||
66e4ab31 | 2598 | /* ... or is not an entry and has a different name. */ |
f5f701ad PT |
2599 | if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) |
2600 | bad_proc = true; | |
2601 | } | |
2990f854 | 2602 | |
f5f701ad PT |
2603 | if (bad_proc) |
2604 | { | |
2605 | gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where); | |
2606 | return FAILURE; | |
2607 | } | |
2608 | } | |
2990f854 | 2609 | |
6de9cd9a DN |
2610 | if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) |
2611 | { | |
7dea5a95 TS |
2612 | gfc_error ("Incompatible ranks %d and %d in assignment at %L", |
2613 | lvalue->rank, rvalue->rank, &lvalue->where); | |
6de9cd9a DN |
2614 | return FAILURE; |
2615 | } | |
2616 | ||
2617 | if (lvalue->ts.type == BT_UNKNOWN) | |
2618 | { | |
2619 | gfc_error ("Variable type is UNKNOWN in assignment at %L", | |
2620 | &lvalue->where); | |
2621 | return FAILURE; | |
2622 | } | |
2623 | ||
37775e79 JD |
2624 | if (rvalue->expr_type == EXPR_NULL) |
2625 | { | |
2626 | if (lvalue->symtree->n.sym->attr.pointer | |
2627 | && lvalue->symtree->n.sym->attr.data) | |
2628 | return SUCCESS; | |
2629 | else | |
2630 | { | |
2631 | gfc_error ("NULL appears on right-hand side in assignment at %L", | |
2632 | &rvalue->where); | |
2633 | return FAILURE; | |
2634 | } | |
2635 | } | |
7dea5a95 | 2636 | |
83d890b9 AL |
2637 | if (sym->attr.cray_pointee |
2638 | && lvalue->ref != NULL | |
f0d0757e | 2639 | && lvalue->ref->u.ar.type == AR_FULL |
83d890b9 AL |
2640 | && lvalue->ref->u.ar.as->cp_was_assumed) |
2641 | { | |
636dff67 SK |
2642 | gfc_error ("Vector assignment to assumed-size Cray Pointee at %L " |
2643 | "is illegal", &lvalue->where); | |
83d890b9 AL |
2644 | return FAILURE; |
2645 | } | |
2646 | ||
66e4ab31 | 2647 | /* This is possibly a typo: x = f() instead of x => f(). */ |
6d1c50cc TS |
2648 | if (gfc_option.warn_surprising |
2649 | && rvalue->expr_type == EXPR_FUNCTION | |
2650 | && rvalue->symtree->n.sym->attr.pointer) | |
2651 | gfc_warning ("POINTER valued function appears on right-hand side of " | |
2652 | "assignment at %L", &rvalue->where); | |
2653 | ||
6de9cd9a DN |
2654 | /* Check size of array assignments. */ |
2655 | if (lvalue->rank != 0 && rvalue->rank != 0 | |
2656 | && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS) | |
2657 | return FAILURE; | |
2658 | ||
2659 | if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) | |
2660 | return SUCCESS; | |
2661 | ||
2662 | if (!conform) | |
2663 | { | |
d3642f89 FW |
2664 | /* Numeric can be converted to any other numeric. And Hollerith can be |
2665 | converted to any other type. */ | |
2666 | if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) | |
2667 | || rvalue->ts.type == BT_HOLLERITH) | |
6de9cd9a DN |
2668 | return SUCCESS; |
2669 | ||
f240b896 SK |
2670 | if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) |
2671 | return SUCCESS; | |
2672 | ||
6de9cd9a DN |
2673 | gfc_error ("Incompatible types in assignment at %L, %s to %s", |
2674 | &rvalue->where, gfc_typename (&rvalue->ts), | |
2675 | gfc_typename (&lvalue->ts)); | |
2676 | ||
2677 | return FAILURE; | |
2678 | } | |
2679 | ||
2680 | return gfc_convert_type (rvalue, &lvalue->ts, 1); | |
2681 | } | |
2682 | ||
2683 | ||
2684 | /* Check that a pointer assignment is OK. We first check lvalue, and | |
2685 | we only check rvalue if it's not an assignment to NULL() or a | |
2686 | NULLIFY statement. */ | |
2687 | ||
2688 | try | |
636dff67 | 2689 | gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) |
6de9cd9a DN |
2690 | { |
2691 | symbol_attribute attr; | |
f17facac | 2692 | gfc_ref *ref; |
6de9cd9a | 2693 | int is_pure; |
f17facac | 2694 | int pointer, check_intent_in; |
6de9cd9a DN |
2695 | |
2696 | if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN) | |
2697 | { | |
2698 | gfc_error ("Pointer assignment target is not a POINTER at %L", | |
2699 | &lvalue->where); | |
2700 | return FAILURE; | |
2701 | } | |
2702 | ||
2990f854 | 2703 | if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE |
636dff67 | 2704 | && lvalue->symtree->n.sym->attr.use_assoc) |
2990f854 PT |
2705 | { |
2706 | gfc_error ("'%s' in the pointer assignment at %L cannot be an " | |
2707 | "l-value since it is a procedure", | |
2708 | lvalue->symtree->n.sym->name, &lvalue->where); | |
2709 | return FAILURE; | |
2710 | } | |
2711 | ||
f17facac TB |
2712 | |
2713 | /* Check INTENT(IN), unless the object itself is the component or | |
2714 | sub-component of a pointer. */ | |
2715 | check_intent_in = 1; | |
2716 | pointer = lvalue->symtree->n.sym->attr.pointer; | |
2717 | ||
2718 | for (ref = lvalue->ref; ref; ref = ref->next) | |
2719 | { | |
2720 | if (pointer) | |
636dff67 | 2721 | check_intent_in = 0; |
f17facac TB |
2722 | |
2723 | if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) | |
636dff67 | 2724 | pointer = 1; |
f17facac TB |
2725 | } |
2726 | ||
2727 | if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN) | |
2728 | { | |
2729 | gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L", | |
636dff67 | 2730 | lvalue->symtree->n.sym->name, &lvalue->where); |
f17facac TB |
2731 | return FAILURE; |
2732 | } | |
2733 | ||
2734 | if (!pointer) | |
6de9cd9a DN |
2735 | { |
2736 | gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); | |
2737 | return FAILURE; | |
2738 | } | |
2739 | ||
2740 | is_pure = gfc_pure (NULL); | |
2741 | ||
2742 | if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)) | |
2743 | { | |
636dff67 | 2744 | gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where); |
6de9cd9a DN |
2745 | return FAILURE; |
2746 | } | |
2747 | ||
2748 | /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, | |
2749 | kind, etc for lvalue and rvalue must match, and rvalue must be a | |
2750 | pure variable if we're in a pure function. */ | |
def66134 | 2751 | if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) |
7d76d73a TS |
2752 | return SUCCESS; |
2753 | ||
2754 | if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) | |
6de9cd9a | 2755 | { |
7d76d73a TS |
2756 | gfc_error ("Different types in pointer assignment at %L", |
2757 | &lvalue->where); | |
2758 | return FAILURE; | |
2759 | } | |
6de9cd9a | 2760 | |
7d76d73a TS |
2761 | if (lvalue->ts.kind != rvalue->ts.kind) |
2762 | { | |
31043f6c | 2763 | gfc_error ("Different kind type parameters in pointer " |
7d76d73a TS |
2764 | "assignment at %L", &lvalue->where); |
2765 | return FAILURE; | |
2766 | } | |
6de9cd9a | 2767 | |
def66134 SK |
2768 | if (lvalue->rank != rvalue->rank) |
2769 | { | |
2770 | gfc_error ("Different ranks in pointer assignment at %L", | |
636dff67 | 2771 | &lvalue->where); |
def66134 SK |
2772 | return FAILURE; |
2773 | } | |
2774 | ||
2775 | /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ | |
2776 | if (rvalue->expr_type == EXPR_NULL) | |
2777 | return SUCCESS; | |
2778 | ||
2990f854 | 2779 | if (lvalue->ts.type == BT_CHARACTER |
b2890f04 | 2780 | && lvalue->ts.cl && rvalue->ts.cl |
636dff67 SK |
2781 | && lvalue->ts.cl->length && rvalue->ts.cl->length |
2782 | && abs (gfc_dep_compare_expr (lvalue->ts.cl->length, | |
2783 | rvalue->ts.cl->length)) == 1) | |
2990f854 PT |
2784 | { |
2785 | gfc_error ("Different character lengths in pointer " | |
2786 | "assignment at %L", &lvalue->where); | |
2787 | return FAILURE; | |
2788 | } | |
2789 | ||
7d76d73a TS |
2790 | attr = gfc_expr_attr (rvalue); |
2791 | if (!attr.target && !attr.pointer) | |
2792 | { | |
31043f6c | 2793 | gfc_error ("Pointer assignment target is neither TARGET " |
7d76d73a TS |
2794 | "nor POINTER at %L", &rvalue->where); |
2795 | return FAILURE; | |
2796 | } | |
6de9cd9a | 2797 | |
7d76d73a TS |
2798 | if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) |
2799 | { | |
31043f6c | 2800 | gfc_error ("Bad target in pointer assignment in PURE " |
7d76d73a TS |
2801 | "procedure at %L", &rvalue->where); |
2802 | } | |
6de9cd9a | 2803 | |
4075a94e PT |
2804 | if (gfc_has_vector_index (rvalue)) |
2805 | { | |
2806 | gfc_error ("Pointer assignment with vector subscript " | |
2807 | "on rhs at %L", &rvalue->where); | |
2808 | return FAILURE; | |
2809 | } | |
2810 | ||
ee7e677f TB |
2811 | if (attr.protected && attr.use_assoc) |
2812 | { | |
2813 | gfc_error ("Pointer assigment target has PROTECTED " | |
636dff67 | 2814 | "attribute at %L", &rvalue->where); |
ee7e677f TB |
2815 | return FAILURE; |
2816 | } | |
2817 | ||
6de9cd9a DN |
2818 | return SUCCESS; |
2819 | } | |
2820 | ||
2821 | ||
2822 | /* Relative of gfc_check_assign() except that the lvalue is a single | |
597073ac | 2823 | symbol. Used for initialization assignments. */ |
6de9cd9a DN |
2824 | |
2825 | try | |
636dff67 | 2826 | gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) |
6de9cd9a DN |
2827 | { |
2828 | gfc_expr lvalue; | |
2829 | try r; | |
2830 | ||
2831 | memset (&lvalue, '\0', sizeof (gfc_expr)); | |
2832 | ||
2833 | lvalue.expr_type = EXPR_VARIABLE; | |
2834 | lvalue.ts = sym->ts; | |
2835 | if (sym->as) | |
2836 | lvalue.rank = sym->as->rank; | |
636dff67 | 2837 | lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree)); |
6de9cd9a DN |
2838 | lvalue.symtree->n.sym = sym; |
2839 | lvalue.where = sym->declared_at; | |
2840 | ||
597073ac PB |
2841 | if (sym->attr.pointer) |
2842 | r = gfc_check_pointer_assign (&lvalue, rvalue); | |
2843 | else | |
2844 | r = gfc_check_assign (&lvalue, rvalue, 1); | |
6de9cd9a DN |
2845 | |
2846 | gfc_free (lvalue.symtree); | |
2847 | ||
2848 | return r; | |
2849 | } | |
54b4ba60 PB |
2850 | |
2851 | ||
2852 | /* Get an expression for a default initializer. */ | |
2853 | ||
2854 | gfc_expr * | |
2855 | gfc_default_initializer (gfc_typespec *ts) | |
2856 | { | |
2857 | gfc_constructor *tail; | |
2858 | gfc_expr *init; | |
2859 | gfc_component *c; | |
2860 | ||
2861 | init = NULL; | |
2862 | ||
2863 | /* See if we have a default initializer. */ | |
2864 | for (c = ts->derived->components; c; c = c->next) | |
2865 | { | |
5046aff5 | 2866 | if ((c->initializer || c->allocatable) && init == NULL) |
636dff67 | 2867 | init = gfc_get_expr (); |
54b4ba60 PB |
2868 | } |
2869 | ||
2870 | if (init == NULL) | |
2871 | return NULL; | |
2872 | ||
2873 | /* Build the constructor. */ | |
2874 | init->expr_type = EXPR_STRUCTURE; | |
2875 | init->ts = *ts; | |
2876 | init->where = ts->derived->declared_at; | |
2877 | tail = NULL; | |
2878 | for (c = ts->derived->components; c; c = c->next) | |
2879 | { | |
2880 | if (tail == NULL) | |
636dff67 | 2881 | init->value.constructor = tail = gfc_get_constructor (); |
54b4ba60 | 2882 | else |
636dff67 SK |
2883 | { |
2884 | tail->next = gfc_get_constructor (); | |
2885 | tail = tail->next; | |
2886 | } | |
54b4ba60 PB |
2887 | |
2888 | if (c->initializer) | |
636dff67 | 2889 | tail->expr = gfc_copy_expr (c->initializer); |
5046aff5 PT |
2890 | |
2891 | if (c->allocatable) | |
2892 | { | |
2893 | tail->expr = gfc_get_expr (); | |
2894 | tail->expr->expr_type = EXPR_NULL; | |
2895 | tail->expr->ts = c->ts; | |
2896 | } | |
54b4ba60 PB |
2897 | } |
2898 | return init; | |
2899 | } | |
294fbfc8 TS |
2900 | |
2901 | ||
2902 | /* Given a symbol, create an expression node with that symbol as a | |
2903 | variable. If the symbol is array valued, setup a reference of the | |
2904 | whole array. */ | |
2905 | ||
2906 | gfc_expr * | |
636dff67 | 2907 | gfc_get_variable_expr (gfc_symtree *var) |
294fbfc8 TS |
2908 | { |
2909 | gfc_expr *e; | |
2910 | ||
2911 | e = gfc_get_expr (); | |
2912 | e->expr_type = EXPR_VARIABLE; | |
2913 | e->symtree = var; | |
2914 | e->ts = var->n.sym->ts; | |
2915 | ||
2916 | if (var->n.sym->as != NULL) | |
2917 | { | |
2918 | e->rank = var->n.sym->as->rank; | |
2919 | e->ref = gfc_get_ref (); | |
2920 | e->ref->type = REF_ARRAY; | |
2921 | e->ref->u.ar.type = AR_FULL; | |
2922 | } | |
2923 | ||
2924 | return e; | |
2925 | } | |
2926 | ||
47992a4a EE |
2927 | |
2928 | /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ | |
2929 | ||
2930 | void | |
636dff67 | 2931 | gfc_expr_set_symbols_referenced (gfc_expr *expr) |
47992a4a EE |
2932 | { |
2933 | gfc_actual_arglist *arg; | |
2934 | gfc_constructor *c; | |
2935 | gfc_ref *ref; | |
2936 | int i; | |
2937 | ||
2938 | if (!expr) return; | |
2939 | ||
2940 | switch (expr->expr_type) | |
2941 | { | |
2942 | case EXPR_OP: | |
2943 | gfc_expr_set_symbols_referenced (expr->value.op.op1); | |
2944 | gfc_expr_set_symbols_referenced (expr->value.op.op2); | |
2945 | break; | |
2946 | ||
2947 | case EXPR_FUNCTION: | |
2948 | for (arg = expr->value.function.actual; arg; arg = arg->next) | |
636dff67 | 2949 | gfc_expr_set_symbols_referenced (arg->expr); |
47992a4a EE |
2950 | break; |
2951 | ||
2952 | case EXPR_VARIABLE: | |
2953 | gfc_set_sym_referenced (expr->symtree->n.sym); | |
2954 | break; | |
2955 | ||
2956 | case EXPR_CONSTANT: | |
2957 | case EXPR_NULL: | |
2958 | case EXPR_SUBSTRING: | |
2959 | break; | |
2960 | ||
2961 | case EXPR_STRUCTURE: | |
2962 | case EXPR_ARRAY: | |
2963 | for (c = expr->value.constructor; c; c = c->next) | |
636dff67 | 2964 | gfc_expr_set_symbols_referenced (c->expr); |
47992a4a EE |
2965 | break; |
2966 | ||
2967 | default: | |
2968 | gcc_unreachable (); | |
2969 | break; | |
2970 | } | |
2971 | ||
2972 | for (ref = expr->ref; ref; ref = ref->next) | |
2973 | switch (ref->type) | |
636dff67 SK |
2974 | { |
2975 | case REF_ARRAY: | |
2976 | for (i = 0; i < ref->u.ar.dimen; i++) | |
2977 | { | |
2978 | gfc_expr_set_symbols_referenced (ref->u.ar.start[i]); | |
2979 | gfc_expr_set_symbols_referenced (ref->u.ar.end[i]); | |
2980 | gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]); | |
2981 | } | |
2982 | break; | |
2983 | ||
2984 | case REF_COMPONENT: | |
2985 | break; | |
2986 | ||
2987 | case REF_SUBSTRING: | |
2988 | gfc_expr_set_symbols_referenced (ref->u.ss.start); | |
2989 | gfc_expr_set_symbols_referenced (ref->u.ss.end); | |
2990 | break; | |
2991 | ||
2992 | default: | |
2993 | gcc_unreachable (); | |
2994 | break; | |
2995 | } | |
47992a4a | 2996 | } |