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