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