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