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