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

source code of gcc/fortran/expr.cc