Fix ifunc detection in target-supports.exp file.
[official-gcc.git] / gcc / fortran / expr.c
blobbbaabb684c9b433e6dad9b07746f7bbaef136881
1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
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.
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.
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/>. */
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"
33 /* The following set of functions provide access to gfc_expr* of
34 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
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. */
42 /* Get a new expression node. */
44 gfc_expr *
45 gfc_get_expr (void)
47 gfc_expr *e;
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;
58 /* Get a new expression node that is an array constructor
59 of given type and kind. */
61 gfc_expr *
62 gfc_get_array_expr (bt type, int kind, locus *where)
64 gfc_expr *e;
66 e = gfc_get_expr ();
67 e->expr_type = EXPR_ARRAY;
68 e->value.constructor = NULL;
69 e->rank = 1;
70 e->shape = NULL;
72 e->ts.type = type;
73 e->ts.kind = kind;
74 if (where)
75 e->where = *where;
77 return e;
81 /* Get a new expression node that is the NULL expression. */
83 gfc_expr *
84 gfc_get_null_expr (locus *where)
86 gfc_expr *e;
88 e = gfc_get_expr ();
89 e->expr_type = EXPR_NULL;
90 e->ts.type = BT_UNKNOWN;
92 if (where)
93 e->where = *where;
95 return e;
99 /* Get a new expression node that is an operator expression node. */
101 gfc_expr *
102 gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
103 gfc_expr *op1, gfc_expr *op2)
105 gfc_expr *e;
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;
113 if (where)
114 e->where = *where;
116 return e;
120 /* Get a new expression node that is an structure constructor
121 of given type and kind. */
123 gfc_expr *
124 gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
126 gfc_expr *e;
128 e = gfc_get_expr ();
129 e->expr_type = EXPR_STRUCTURE;
130 e->value.constructor = NULL;
132 e->ts.type = type;
133 e->ts.kind = kind;
134 if (where)
135 e->where = *where;
137 return e;
141 /* Get a new expression node that is an constant of given type and kind. */
143 gfc_expr *
144 gfc_get_constant_expr (bt type, int kind, locus *where)
146 gfc_expr *e;
148 if (!where)
149 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
150 "NULL");
152 e = gfc_get_expr ();
154 e->expr_type = EXPR_CONSTANT;
155 e->ts.type = type;
156 e->ts.kind = kind;
157 e->where = *where;
159 switch (type)
161 case BT_INTEGER:
162 mpz_init (e->value.integer);
163 break;
165 case BT_REAL:
166 gfc_set_model_kind (kind);
167 mpfr_init (e->value.real);
168 break;
170 case BT_COMPLEX:
171 gfc_set_model_kind (kind);
172 mpc_init2 (e->value.complex, mpfr_get_default_prec());
173 break;
175 default:
176 break;
179 return e;
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. */
187 gfc_expr *
188 gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len)
190 gfc_expr *e;
191 gfc_char_t *dest;
193 if (!src)
195 dest = gfc_get_wide_string (len + 1);
196 gfc_wide_memset (dest, ' ', len);
197 dest[len] = '\0';
199 else
200 dest = gfc_char_to_widechar (src);
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;
207 return e;
211 /* Get a new expression node that is an integer constant. */
213 gfc_expr *
214 gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value)
216 gfc_expr *p;
217 p = gfc_get_constant_expr (BT_INTEGER, kind,
218 where ? where : &gfc_current_locus);
220 const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT);
221 wi::to_mpz (w, p->value.integer, SIGNED);
223 return p;
227 /* Get a new expression node that is a logical constant. */
229 gfc_expr *
230 gfc_get_logical_expr (int kind, locus *where, bool value)
232 gfc_expr *p;
233 p = gfc_get_constant_expr (BT_LOGICAL, kind,
234 where ? where : &gfc_current_locus);
236 p->value.logical = value;
238 return p;
242 gfc_expr *
243 gfc_get_iokind_expr (locus *where, io_kind k)
245 gfc_expr *e;
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. */
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;
257 return e;
261 /* Given an expression pointer, return a copy of the expression. This
262 subroutine is recursive. */
264 gfc_expr *
265 gfc_copy_expr (gfc_expr *p)
267 gfc_expr *q;
268 gfc_char_t *s;
269 char *c;
271 if (p == NULL)
272 return NULL;
274 q = gfc_get_expr ();
275 *q = *p;
277 switch (q->expr_type)
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;
286 case EXPR_CONSTANT:
287 /* Copy target representation, if it exists. */
288 if (p->representation.string)
290 c = XCNEWVEC (char, p->representation.length + 1);
291 q->representation.string = c;
292 memcpy (c, p->representation.string, (p->representation.length + 1));
295 /* Copy the values of any pointer components of p->value. */
296 switch (q->ts.type)
298 case BT_INTEGER:
299 mpz_init_set (q->value.integer, p->value.integer);
300 break;
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;
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;
314 case BT_CHARACTER:
315 if (p->representation.string)
316 q->value.character.string
317 = gfc_char_to_widechar (q->representation.string);
318 else
320 s = gfc_get_wide_string (p->value.character.length + 1);
321 q->value.character.string = s;
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))
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;
332 else
333 memcpy (s, p->value.character.string,
334 (p->value.character.length + 1) * sizeof (gfc_char_t));
336 break;
338 case BT_HOLLERITH:
339 case BT_LOGICAL:
340 case_bt_struct:
341 case BT_CLASS:
342 case BT_ASSUMED:
343 break; /* Already done. */
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. */
353 break;
355 case EXPR_OP:
356 switch (q->value.op.op)
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;
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;
371 break;
373 case EXPR_FUNCTION:
374 q->value.function.actual =
375 gfc_copy_actual_arglist (p->value.function.actual);
376 break;
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;
385 case EXPR_STRUCTURE:
386 case EXPR_ARRAY:
387 q->value.constructor = gfc_constructor_copy (p->value.constructor);
388 break;
390 case EXPR_VARIABLE:
391 case EXPR_NULL:
392 break;
395 q->shape = gfc_copy_shape (p->shape, p->rank);
397 q->ref = gfc_copy_ref (p->ref);
399 if (p->param_list)
400 q->param_list = gfc_copy_actual_arglist (p->param_list);
402 return q;
406 void
407 gfc_clear_shape (mpz_t *shape, int rank)
409 int i;
411 for (i = 0; i < rank; i++)
412 mpz_clear (shape[i]);
416 void
417 gfc_free_shape (mpz_t **shape, int rank)
419 if (*shape == NULL)
420 return;
422 gfc_clear_shape (*shape, rank);
423 free (*shape);
424 *shape = NULL;
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. */
433 static void
434 free_expr0 (gfc_expr *e)
436 switch (e->expr_type)
438 case EXPR_CONSTANT:
439 /* Free any parts of the value that need freeing. */
440 switch (e->ts.type)
442 case BT_INTEGER:
443 mpz_clear (e->value.integer);
444 break;
446 case BT_REAL:
447 mpfr_clear (e->value.real);
448 break;
450 case BT_CHARACTER:
451 free (e->value.character.string);
452 break;
454 case BT_COMPLEX:
455 mpc_clear (e->value.complex);
456 break;
458 default:
459 break;
462 /* Free the representation. */
463 free (e->representation.string);
465 break;
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;
474 case EXPR_FUNCTION:
475 gfc_free_actual_arglist (e->value.function.actual);
476 break;
478 case EXPR_COMPCALL:
479 case EXPR_PPC:
480 gfc_free_actual_arglist (e->value.compcall.actual);
481 break;
483 case EXPR_VARIABLE:
484 break;
486 case EXPR_ARRAY:
487 case EXPR_STRUCTURE:
488 gfc_constructor_free (e->value.constructor);
489 break;
491 case EXPR_SUBSTRING:
492 free (e->value.character.string);
493 break;
495 case EXPR_NULL:
496 break;
498 default:
499 gfc_internal_error ("free_expr0(): Bad expr type");
502 /* Free a shape array. */
503 gfc_free_shape (&e->shape, e->rank);
505 gfc_free_ref_list (e->ref);
507 gfc_free_actual_arglist (e->param_list);
509 memset (e, '\0', sizeof (gfc_expr));
513 /* Free an expression node and everything beneath it. */
515 void
516 gfc_free_expr (gfc_expr *e)
518 if (e == NULL)
519 return;
520 free_expr0 (e);
521 free (e);
525 /* Free an argument list and everything below it. */
527 void
528 gfc_free_actual_arglist (gfc_actual_arglist *a1)
530 gfc_actual_arglist *a2;
532 while (a1)
534 a2 = a1->next;
535 if (a1->expr)
536 gfc_free_expr (a1->expr);
537 free (a1);
538 a1 = a2;
543 /* Copy an arglist structure and all of the arguments. */
545 gfc_actual_arglist *
546 gfc_copy_actual_arglist (gfc_actual_arglist *p)
548 gfc_actual_arglist *head, *tail, *new_arg;
550 head = tail = NULL;
552 for (; p; p = p->next)
554 new_arg = gfc_get_actual_arglist ();
555 *new_arg = *p;
557 new_arg->expr = gfc_copy_expr (p->expr);
558 new_arg->next = NULL;
560 if (head == NULL)
561 head = new_arg;
562 else
563 tail->next = new_arg;
565 tail = new_arg;
568 return head;
572 /* Free a list of reference structures. */
574 void
575 gfc_free_ref_list (gfc_ref *p)
577 gfc_ref *q;
578 int i;
580 for (; p; p = q)
582 q = p->next;
584 switch (p->type)
586 case REF_ARRAY:
587 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
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]);
594 break;
596 case REF_SUBSTRING:
597 gfc_free_expr (p->u.ss.start);
598 gfc_free_expr (p->u.ss.end);
599 break;
601 case REF_COMPONENT:
602 break;
605 free (p);
610 /* Graft the *src expression onto the *dest subexpression. */
612 void
613 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
615 free_expr0 (dest);
616 *dest = *src;
617 free (src);
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. */
626 bool
627 gfc_extract_int (gfc_expr *expr, int *result, int report_error)
629 gfc_ref *ref;
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)
636 for (ref = expr->ref; ref; ref = ref->next)
638 if (ref->u.c.component->attr.pdt_kind)
639 expr = ref->u.c.component->initializer;
643 if (expr->expr_type != EXPR_CONSTANT)
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;
652 if (expr->ts.type != BT_INTEGER)
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;
661 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
662 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
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;
671 *result = (int) mpz_get_si (expr->value.integer);
673 return false;
677 /* Same as gfc_extract_int, but use a HWI. */
679 bool
680 gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error)
682 gfc_ref *ref;
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)
689 for (ref = expr->ref; ref; ref = ref->next)
691 if (ref->u.c.component->attr.pdt_kind)
692 expr = ref->u.c.component->initializer;
696 if (expr->expr_type != EXPR_CONSTANT)
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;
705 if (expr->ts.type != BT_INTEGER)
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;
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);
718 if (!wi::fits_shwi_p (val))
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;
727 *result = val.to_shwi ();
729 return false;
733 /* Recursively copy a list of reference structures. */
735 gfc_ref *
736 gfc_copy_ref (gfc_ref *src)
738 gfc_array_ref *ar;
739 gfc_ref *dest;
741 if (src == NULL)
742 return NULL;
744 dest = gfc_get_ref ();
745 dest->type = src->type;
747 switch (src->type)
749 case REF_ARRAY:
750 ar = gfc_copy_array_ref (&src->u.ar);
751 dest->u.ar = *ar;
752 free (ar);
753 break;
755 case REF_COMPONENT:
756 dest->u.c = src->u.c;
757 break;
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;
766 dest->next = gfc_copy_ref (src->next);
768 return dest;
772 /* Detect whether an expression has any vector index array references. */
775 gfc_has_vector_index (gfc_expr *e)
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;
788 /* Copy a shape array. */
790 mpz_t *
791 gfc_copy_shape (mpz_t *shape, int rank)
793 mpz_t *new_shape;
794 int n;
796 if (shape == NULL)
797 return NULL;
799 new_shape = gfc_get_shape (rank);
801 for (n = 0; n < rank; n++)
802 mpz_init_set (new_shape[n], shape[n]);
804 return new_shape;
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.
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}
817 If anything goes wrong -- N is not a constant, its value is out
818 of range -- or anything else, just returns NULL. */
820 mpz_t *
821 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
823 mpz_t *new_shape, *s;
824 int i, n;
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;
833 n = mpz_get_si (dim->value.integer);
834 n--; /* Convert to zero based index. */
835 if (n < 0 || n >= rank)
836 return NULL;
838 s = new_shape = gfc_get_shape (rank - 1);
840 for (i = 0; i < rank; i++)
842 if (i == n)
843 continue;
844 mpz_init_set (*s, shape[i]);
845 s++;
848 return new_shape;
852 /* Return the maximum kind of two expressions. In general, higher
853 kind numbers mean more precision for numeric types. */
856 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
858 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
862 /* Returns nonzero if the type is numeric, zero otherwise. */
864 static int
865 numeric_type (bt type)
867 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
871 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
874 gfc_numeric_ts (gfc_typespec *ts)
876 return numeric_type (ts->type);
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. */
884 gfc_expr *
885 gfc_build_conversion (gfc_expr *e)
887 gfc_expr *p;
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;
895 return p;
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.
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. */
909 void
910 gfc_type_convert_binary (gfc_expr *e, int wconversion)
912 gfc_expr *op1, *op2;
914 op1 = e->value.op.op1;
915 op2 = e->value.op.op2;
917 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
919 gfc_clear_ts (&e->ts);
920 return;
923 /* Kind conversions of same type. */
924 if (op1->ts.type == op2->ts.type)
926 if (op1->ts.kind == op2->ts.kind)
928 /* No type conversions. */
929 e->ts = op1->ts;
930 goto done;
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);
938 e->ts = op1->ts;
939 goto done;
942 /* Integer combined with real or complex. */
943 if (op2->ts.type == BT_INTEGER)
945 e->ts = op1->ts;
947 /* Special case for ** operator. */
948 if (e->value.op.op == INTRINSIC_POWER)
949 goto done;
951 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
952 goto done;
955 if (op1->ts.type == BT_INTEGER)
957 e->ts = op2->ts;
958 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
959 goto done;
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);
973 done:
974 return;
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. */
981 bool
982 gfc_is_constant_expr (gfc_expr *e)
984 gfc_constructor *c;
985 gfc_actual_arglist *arg;
987 if (e == NULL)
988 return true;
990 switch (e->expr_type)
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)));
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;
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);
1011 /* Call to intrinsic with at least one argument. */
1012 if (e->value.function.isym && e->value.function.actual)
1014 for (arg = e->value.function.actual; arg; arg = arg->next)
1015 if (!gfc_is_constant_expr (arg->expr))
1016 return false;
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;
1026 return false;
1028 case EXPR_CONSTANT:
1029 case EXPR_NULL:
1030 return true;
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));
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);
1042 for (; c; c = gfc_constructor_next (c))
1043 if (!gfc_is_constant_expr (c->expr))
1044 return false;
1046 return true;
1049 default:
1050 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1051 return false;
1056 /* Is true if an array reference is followed by a component or substring
1057 reference. */
1058 bool
1059 is_subref_array (gfc_expr * e)
1061 gfc_ref * ref;
1062 bool seen_array;
1064 if (e->expr_type != EXPR_VARIABLE)
1065 return false;
1067 if (e->symtree->n.sym->attr.subref_array_pointer)
1068 return true;
1070 if (e->symtree->n.sym->ts.type == BT_CLASS
1071 && e->symtree->n.sym->attr.dummy
1072 && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
1073 return true;
1075 seen_array = false;
1076 for (ref = e->ref; ref; ref = ref->next)
1078 if (ref->type == REF_ARRAY
1079 && ref->u.ar.type != AR_ELEMENT)
1080 seen_array = true;
1082 if (seen_array
1083 && ref->type != REF_ARRAY)
1084 return seen_array;
1086 return false;
1090 /* Try to collapse intrinsic expressions. */
1092 static bool
1093 simplify_intrinsic_op (gfc_expr *p, int type)
1095 gfc_intrinsic_op op;
1096 gfc_expr *op1, *op2, *result;
1098 if (p->value.op.op == INTRINSIC_USER)
1099 return true;
1101 op1 = p->value.op.op1;
1102 op2 = p->value.op.op2;
1103 op = p->value.op.op;
1105 if (!gfc_simplify_expr (op1, type))
1106 return false;
1107 if (!gfc_simplify_expr (op2, type))
1108 return false;
1110 if (!gfc_is_constant_expr (op1)
1111 || (op2 != NULL && !gfc_is_constant_expr (op2)))
1112 return true;
1114 /* Rip p apart. */
1115 p->value.op.op1 = NULL;
1116 p->value.op.op2 = NULL;
1118 switch (op)
1120 case INTRINSIC_PARENTHESES:
1121 result = gfc_parentheses (op1);
1122 break;
1124 case INTRINSIC_UPLUS:
1125 result = gfc_uplus (op1);
1126 break;
1128 case INTRINSIC_UMINUS:
1129 result = gfc_uminus (op1);
1130 break;
1132 case INTRINSIC_PLUS:
1133 result = gfc_add (op1, op2);
1134 break;
1136 case INTRINSIC_MINUS:
1137 result = gfc_subtract (op1, op2);
1138 break;
1140 case INTRINSIC_TIMES:
1141 result = gfc_multiply (op1, op2);
1142 break;
1144 case INTRINSIC_DIVIDE:
1145 result = gfc_divide (op1, op2);
1146 break;
1148 case INTRINSIC_POWER:
1149 result = gfc_power (op1, op2);
1150 break;
1152 case INTRINSIC_CONCAT:
1153 result = gfc_concat (op1, op2);
1154 break;
1156 case INTRINSIC_EQ:
1157 case INTRINSIC_EQ_OS:
1158 result = gfc_eq (op1, op2, op);
1159 break;
1161 case INTRINSIC_NE:
1162 case INTRINSIC_NE_OS:
1163 result = gfc_ne (op1, op2, op);
1164 break;
1166 case INTRINSIC_GT:
1167 case INTRINSIC_GT_OS:
1168 result = gfc_gt (op1, op2, op);
1169 break;
1171 case INTRINSIC_GE:
1172 case INTRINSIC_GE_OS:
1173 result = gfc_ge (op1, op2, op);
1174 break;
1176 case INTRINSIC_LT:
1177 case INTRINSIC_LT_OS:
1178 result = gfc_lt (op1, op2, op);
1179 break;
1181 case INTRINSIC_LE:
1182 case INTRINSIC_LE_OS:
1183 result = gfc_le (op1, op2, op);
1184 break;
1186 case INTRINSIC_NOT:
1187 result = gfc_not (op1);
1188 break;
1190 case INTRINSIC_AND:
1191 result = gfc_and (op1, op2);
1192 break;
1194 case INTRINSIC_OR:
1195 result = gfc_or (op1, op2);
1196 break;
1198 case INTRINSIC_EQV:
1199 result = gfc_eqv (op1, op2);
1200 break;
1202 case INTRINSIC_NEQV:
1203 result = gfc_neqv (op1, op2);
1204 break;
1206 default:
1207 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1210 if (result == NULL)
1212 gfc_free_expr (op1);
1213 gfc_free_expr (op2);
1214 return false;
1217 result->rank = p->rank;
1218 result->where = p->where;
1219 gfc_replace_expr (p, result);
1221 return true;
1225 /* Subroutine to simplify constructor expressions. Mutually recursive
1226 with gfc_simplify_expr(). */
1228 static bool
1229 simplify_constructor (gfc_constructor_base base, int type)
1231 gfc_constructor *c;
1232 gfc_expr *p;
1234 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1236 if (c->iterator
1237 && (!gfc_simplify_expr(c->iterator->start, type)
1238 || !gfc_simplify_expr (c->iterator->end, type)
1239 || !gfc_simplify_expr (c->iterator->step, type)))
1240 return false;
1242 if (c->expr)
1244 /* Try and simplify a copy. Replace the original if successful
1245 but keep going through the constructor at all costs. Not
1246 doing so can make a dog's dinner of complicated things. */
1247 p = gfc_copy_expr (c->expr);
1249 if (!gfc_simplify_expr (p, type))
1251 gfc_free_expr (p);
1252 continue;
1255 gfc_replace_expr (c->expr, p);
1259 return true;
1263 /* Pull a single array element out of an array constructor. */
1265 static bool
1266 find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1267 gfc_constructor **rval)
1269 unsigned long nelemen;
1270 int i;
1271 mpz_t delta;
1272 mpz_t offset;
1273 mpz_t span;
1274 mpz_t tmp;
1275 gfc_constructor *cons;
1276 gfc_expr *e;
1277 bool t;
1279 t = true;
1280 e = NULL;
1282 mpz_init_set_ui (offset, 0);
1283 mpz_init (delta);
1284 mpz_init (tmp);
1285 mpz_init_set_ui (span, 1);
1286 for (i = 0; i < ar->dimen; i++)
1288 if (!gfc_reduce_init_expr (ar->as->lower[i])
1289 || !gfc_reduce_init_expr (ar->as->upper[i]))
1291 t = false;
1292 cons = NULL;
1293 goto depart;
1296 e = ar->start[i];
1297 if (e->expr_type != EXPR_CONSTANT)
1299 cons = NULL;
1300 goto depart;
1303 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1304 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1306 /* Check the bounds. */
1307 if ((ar->as->upper[i]
1308 && mpz_cmp (e->value.integer,
1309 ar->as->upper[i]->value.integer) > 0)
1310 || (mpz_cmp (e->value.integer,
1311 ar->as->lower[i]->value.integer) < 0))
1313 gfc_error ("Index in dimension %d is out of bounds "
1314 "at %L", i + 1, &ar->c_where[i]);
1315 cons = NULL;
1316 t = false;
1317 goto depart;
1320 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1321 mpz_mul (delta, delta, span);
1322 mpz_add (offset, offset, delta);
1324 mpz_set_ui (tmp, 1);
1325 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1326 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1327 mpz_mul (span, span, tmp);
1330 for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
1331 cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1333 if (cons->iterator)
1335 cons = NULL;
1336 goto depart;
1340 depart:
1341 mpz_clear (delta);
1342 mpz_clear (offset);
1343 mpz_clear (span);
1344 mpz_clear (tmp);
1345 *rval = cons;
1346 return t;
1350 /* Find a component of a structure constructor. */
1352 static gfc_constructor *
1353 find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1355 gfc_component *pick = ref->u.c.component;
1356 gfc_constructor *c = gfc_constructor_first (base);
1358 gfc_symbol *dt = ref->u.c.sym;
1359 int ext = dt->attr.extension;
1361 /* For extended types, check if the desired component is in one of the
1362 * parent types. */
1363 while (ext > 0 && gfc_find_component (dt->components->ts.u.derived,
1364 pick->name, true, true, NULL))
1366 dt = dt->components->ts.u.derived;
1367 c = gfc_constructor_first (c->expr->value.constructor);
1368 ext--;
1371 gfc_component *comp = dt->components;
1372 while (comp != pick)
1374 comp = comp->next;
1375 c = gfc_constructor_next (c);
1378 return c;
1382 /* Replace an expression with the contents of a constructor, removing
1383 the subobject reference in the process. */
1385 static void
1386 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1388 gfc_expr *e;
1390 if (cons)
1392 e = cons->expr;
1393 cons->expr = NULL;
1395 else
1396 e = gfc_copy_expr (p);
1397 e->ref = p->ref->next;
1398 p->ref->next = NULL;
1399 gfc_replace_expr (p, e);
1403 /* Pull an array section out of an array constructor. */
1405 static bool
1406 find_array_section (gfc_expr *expr, gfc_ref *ref)
1408 int idx;
1409 int rank;
1410 int d;
1411 int shape_i;
1412 int limit;
1413 long unsigned one = 1;
1414 bool incr_ctr;
1415 mpz_t start[GFC_MAX_DIMENSIONS];
1416 mpz_t end[GFC_MAX_DIMENSIONS];
1417 mpz_t stride[GFC_MAX_DIMENSIONS];
1418 mpz_t delta[GFC_MAX_DIMENSIONS];
1419 mpz_t ctr[GFC_MAX_DIMENSIONS];
1420 mpz_t delta_mpz;
1421 mpz_t tmp_mpz;
1422 mpz_t nelts;
1423 mpz_t ptr;
1424 gfc_constructor_base base;
1425 gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
1426 gfc_expr *begin;
1427 gfc_expr *finish;
1428 gfc_expr *step;
1429 gfc_expr *upper;
1430 gfc_expr *lower;
1431 bool t;
1433 t = true;
1435 base = expr->value.constructor;
1436 expr->value.constructor = NULL;
1438 rank = ref->u.ar.as->rank;
1440 if (expr->shape == NULL)
1441 expr->shape = gfc_get_shape (rank);
1443 mpz_init_set_ui (delta_mpz, one);
1444 mpz_init_set_ui (nelts, one);
1445 mpz_init (tmp_mpz);
1447 /* Do the initialization now, so that we can cleanup without
1448 keeping track of where we were. */
1449 for (d = 0; d < rank; d++)
1451 mpz_init (delta[d]);
1452 mpz_init (start[d]);
1453 mpz_init (end[d]);
1454 mpz_init (ctr[d]);
1455 mpz_init (stride[d]);
1456 vecsub[d] = NULL;
1459 /* Build the counters to clock through the array reference. */
1460 shape_i = 0;
1461 for (d = 0; d < rank; d++)
1463 /* Make this stretch of code easier on the eye! */
1464 begin = ref->u.ar.start[d];
1465 finish = ref->u.ar.end[d];
1466 step = ref->u.ar.stride[d];
1467 lower = ref->u.ar.as->lower[d];
1468 upper = ref->u.ar.as->upper[d];
1470 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1472 gfc_constructor *ci;
1473 gcc_assert (begin);
1475 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1477 t = false;
1478 goto cleanup;
1481 gcc_assert (begin->rank == 1);
1482 /* Zero-sized arrays have no shape and no elements, stop early. */
1483 if (!begin->shape)
1485 mpz_init_set_ui (nelts, 0);
1486 break;
1489 vecsub[d] = gfc_constructor_first (begin->value.constructor);
1490 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1491 mpz_mul (nelts, nelts, begin->shape[0]);
1492 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1494 /* Check bounds. */
1495 for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1497 if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1498 || mpz_cmp (ci->expr->value.integer,
1499 lower->value.integer) < 0)
1501 gfc_error ("index in dimension %d is out of bounds "
1502 "at %L", d + 1, &ref->u.ar.c_where[d]);
1503 t = false;
1504 goto cleanup;
1508 else
1510 if ((begin && begin->expr_type != EXPR_CONSTANT)
1511 || (finish && finish->expr_type != EXPR_CONSTANT)
1512 || (step && step->expr_type != EXPR_CONSTANT))
1514 t = false;
1515 goto cleanup;
1518 /* Obtain the stride. */
1519 if (step)
1520 mpz_set (stride[d], step->value.integer);
1521 else
1522 mpz_set_ui (stride[d], one);
1524 if (mpz_cmp_ui (stride[d], 0) == 0)
1525 mpz_set_ui (stride[d], one);
1527 /* Obtain the start value for the index. */
1528 if (begin)
1529 mpz_set (start[d], begin->value.integer);
1530 else
1531 mpz_set (start[d], lower->value.integer);
1533 mpz_set (ctr[d], start[d]);
1535 /* Obtain the end value for the index. */
1536 if (finish)
1537 mpz_set (end[d], finish->value.integer);
1538 else
1539 mpz_set (end[d], upper->value.integer);
1541 /* Separate 'if' because elements sometimes arrive with
1542 non-null end. */
1543 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1544 mpz_set (end [d], begin->value.integer);
1546 /* Check the bounds. */
1547 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1548 || mpz_cmp (end[d], upper->value.integer) > 0
1549 || mpz_cmp (ctr[d], lower->value.integer) < 0
1550 || mpz_cmp (end[d], lower->value.integer) < 0)
1552 gfc_error ("index in dimension %d is out of bounds "
1553 "at %L", d + 1, &ref->u.ar.c_where[d]);
1554 t = false;
1555 goto cleanup;
1558 /* Calculate the number of elements and the shape. */
1559 mpz_set (tmp_mpz, stride[d]);
1560 mpz_add (tmp_mpz, end[d], tmp_mpz);
1561 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1562 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1563 mpz_mul (nelts, nelts, tmp_mpz);
1565 /* An element reference reduces the rank of the expression; don't
1566 add anything to the shape array. */
1567 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1568 mpz_set (expr->shape[shape_i++], tmp_mpz);
1571 /* Calculate the 'stride' (=delta) for conversion of the
1572 counter values into the index along the constructor. */
1573 mpz_set (delta[d], delta_mpz);
1574 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1575 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1576 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1579 mpz_init (ptr);
1580 cons = gfc_constructor_first (base);
1582 /* Now clock through the array reference, calculating the index in
1583 the source constructor and transferring the elements to the new
1584 constructor. */
1585 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1587 mpz_init_set_ui (ptr, 0);
1589 incr_ctr = true;
1590 for (d = 0; d < rank; d++)
1592 mpz_set (tmp_mpz, ctr[d]);
1593 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1594 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1595 mpz_add (ptr, ptr, tmp_mpz);
1597 if (!incr_ctr) continue;
1599 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1601 gcc_assert(vecsub[d]);
1603 if (!gfc_constructor_next (vecsub[d]))
1604 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1605 else
1607 vecsub[d] = gfc_constructor_next (vecsub[d]);
1608 incr_ctr = false;
1610 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1612 else
1614 mpz_add (ctr[d], ctr[d], stride[d]);
1616 if (mpz_cmp_ui (stride[d], 0) > 0
1617 ? mpz_cmp (ctr[d], end[d]) > 0
1618 : mpz_cmp (ctr[d], end[d]) < 0)
1619 mpz_set (ctr[d], start[d]);
1620 else
1621 incr_ctr = false;
1625 limit = mpz_get_ui (ptr);
1626 if (limit >= flag_max_array_constructor)
1628 gfc_error ("The number of elements in the array constructor "
1629 "at %L requires an increase of the allowed %d "
1630 "upper limit. See -fmax-array-constructor "
1631 "option", &expr->where, flag_max_array_constructor);
1632 return false;
1635 cons = gfc_constructor_lookup (base, limit);
1636 gcc_assert (cons);
1637 gfc_constructor_append_expr (&expr->value.constructor,
1638 gfc_copy_expr (cons->expr), NULL);
1641 mpz_clear (ptr);
1643 cleanup:
1645 mpz_clear (delta_mpz);
1646 mpz_clear (tmp_mpz);
1647 mpz_clear (nelts);
1648 for (d = 0; d < rank; d++)
1650 mpz_clear (delta[d]);
1651 mpz_clear (start[d]);
1652 mpz_clear (end[d]);
1653 mpz_clear (ctr[d]);
1654 mpz_clear (stride[d]);
1656 gfc_constructor_free (base);
1657 return t;
1660 /* Pull a substring out of an expression. */
1662 static bool
1663 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1665 int end;
1666 int start;
1667 int length;
1668 gfc_char_t *chr;
1670 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1671 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1672 return false;
1674 *newp = gfc_copy_expr (p);
1675 free ((*newp)->value.character.string);
1677 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1678 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1679 length = end - start + 1;
1681 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1682 (*newp)->value.character.length = length;
1683 memcpy (chr, &p->value.character.string[start - 1],
1684 length * sizeof (gfc_char_t));
1685 chr[length] = '\0';
1686 return true;
1691 /* Simplify a subobject reference of a constructor. This occurs when
1692 parameter variable values are substituted. */
1694 static bool
1695 simplify_const_ref (gfc_expr *p)
1697 gfc_constructor *cons, *c;
1698 gfc_expr *newp;
1699 gfc_ref *last_ref;
1701 while (p->ref)
1703 switch (p->ref->type)
1705 case REF_ARRAY:
1706 switch (p->ref->u.ar.type)
1708 case AR_ELEMENT:
1709 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1710 will generate this. */
1711 if (p->expr_type != EXPR_ARRAY)
1713 remove_subobject_ref (p, NULL);
1714 break;
1716 if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons))
1717 return false;
1719 if (!cons)
1720 return true;
1722 remove_subobject_ref (p, cons);
1723 break;
1725 case AR_SECTION:
1726 if (!find_array_section (p, p->ref))
1727 return false;
1728 p->ref->u.ar.type = AR_FULL;
1730 /* Fall through. */
1732 case AR_FULL:
1733 if (p->ref->next != NULL
1734 && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type)))
1736 for (c = gfc_constructor_first (p->value.constructor);
1737 c; c = gfc_constructor_next (c))
1739 c->expr->ref = gfc_copy_ref (p->ref->next);
1740 if (!simplify_const_ref (c->expr))
1741 return false;
1744 if (gfc_bt_struct (p->ts.type)
1745 && p->ref->next
1746 && (c = gfc_constructor_first (p->value.constructor)))
1748 /* There may have been component references. */
1749 p->ts = c->expr->ts;
1752 last_ref = p->ref;
1753 for (; last_ref->next; last_ref = last_ref->next) {};
1755 if (p->ts.type == BT_CHARACTER
1756 && last_ref->type == REF_SUBSTRING)
1758 /* If this is a CHARACTER array and we possibly took
1759 a substring out of it, update the type-spec's
1760 character length according to the first element
1761 (as all should have the same length). */
1762 gfc_charlen_t string_len;
1763 if ((c = gfc_constructor_first (p->value.constructor)))
1765 const gfc_expr* first = c->expr;
1766 gcc_assert (first->expr_type == EXPR_CONSTANT);
1767 gcc_assert (first->ts.type == BT_CHARACTER);
1768 string_len = first->value.character.length;
1770 else
1771 string_len = 0;
1773 if (!p->ts.u.cl)
1774 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1775 NULL);
1776 else
1777 gfc_free_expr (p->ts.u.cl->length);
1779 p->ts.u.cl->length
1780 = gfc_get_int_expr (gfc_charlen_int_kind,
1781 NULL, string_len);
1784 gfc_free_ref_list (p->ref);
1785 p->ref = NULL;
1786 break;
1788 default:
1789 return true;
1792 break;
1794 case REF_COMPONENT:
1795 cons = find_component_ref (p->value.constructor, p->ref);
1796 remove_subobject_ref (p, cons);
1797 break;
1799 case REF_SUBSTRING:
1800 if (!find_substring_ref (p, &newp))
1801 return false;
1803 gfc_replace_expr (p, newp);
1804 gfc_free_ref_list (p->ref);
1805 p->ref = NULL;
1806 break;
1810 return true;
1814 /* Simplify a chain of references. */
1816 static bool
1817 simplify_ref_chain (gfc_ref *ref, int type)
1819 int n;
1821 for (; ref; ref = ref->next)
1823 switch (ref->type)
1825 case REF_ARRAY:
1826 for (n = 0; n < ref->u.ar.dimen; n++)
1828 if (!gfc_simplify_expr (ref->u.ar.start[n], type))
1829 return false;
1830 if (!gfc_simplify_expr (ref->u.ar.end[n], type))
1831 return false;
1832 if (!gfc_simplify_expr (ref->u.ar.stride[n], type))
1833 return false;
1835 break;
1837 case REF_SUBSTRING:
1838 if (!gfc_simplify_expr (ref->u.ss.start, type))
1839 return false;
1840 if (!gfc_simplify_expr (ref->u.ss.end, type))
1841 return false;
1842 break;
1844 default:
1845 break;
1848 return true;
1852 /* Try to substitute the value of a parameter variable. */
1854 static bool
1855 simplify_parameter_variable (gfc_expr *p, int type)
1857 gfc_expr *e;
1858 bool t;
1860 if (gfc_is_size_zero_array (p))
1862 if (p->expr_type == EXPR_ARRAY)
1863 return true;
1865 e = gfc_get_expr ();
1866 e->expr_type = EXPR_ARRAY;
1867 e->ts = p->ts;
1868 e->rank = p->rank;
1869 e->value.constructor = NULL;
1870 e->shape = gfc_copy_shape (p->shape, p->rank);
1871 e->where = p->where;
1872 gfc_replace_expr (p, e);
1873 return true;
1876 e = gfc_copy_expr (p->symtree->n.sym->value);
1877 if (e == NULL)
1878 return false;
1880 e->rank = p->rank;
1882 /* Do not copy subobject refs for constant. */
1883 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1884 e->ref = gfc_copy_ref (p->ref);
1885 t = gfc_simplify_expr (e, type);
1887 /* Only use the simplification if it eliminated all subobject references. */
1888 if (t && !e->ref)
1889 gfc_replace_expr (p, e);
1890 else
1891 gfc_free_expr (e);
1893 return t;
1896 /* Given an expression, simplify it by collapsing constant
1897 expressions. Most simplification takes place when the expression
1898 tree is being constructed. If an intrinsic function is simplified
1899 at some point, we get called again to collapse the result against
1900 other constants.
1902 We work by recursively simplifying expression nodes, simplifying
1903 intrinsic functions where possible, which can lead to further
1904 constant collapsing. If an operator has constant operand(s), we
1905 rip the expression apart, and rebuild it, hoping that it becomes
1906 something simpler.
1908 The expression type is defined for:
1909 0 Basic expression parsing
1910 1 Simplifying array constructors -- will substitute
1911 iterator values.
1912 Returns false on error, true otherwise.
1913 NOTE: Will return true even if the expression can not be simplified. */
1915 bool
1916 gfc_simplify_expr (gfc_expr *p, int type)
1918 gfc_actual_arglist *ap;
1920 if (p == NULL)
1921 return true;
1923 switch (p->expr_type)
1925 case EXPR_CONSTANT:
1926 case EXPR_NULL:
1927 break;
1929 case EXPR_FUNCTION:
1930 for (ap = p->value.function.actual; ap; ap = ap->next)
1931 if (!gfc_simplify_expr (ap->expr, type))
1932 return false;
1934 if (p->value.function.isym != NULL
1935 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1936 return false;
1938 break;
1940 case EXPR_SUBSTRING:
1941 if (!simplify_ref_chain (p->ref, type))
1942 return false;
1944 if (gfc_is_constant_expr (p))
1946 gfc_char_t *s;
1947 HOST_WIDE_INT start, end;
1949 start = 0;
1950 if (p->ref && p->ref->u.ss.start)
1952 gfc_extract_hwi (p->ref->u.ss.start, &start);
1953 start--; /* Convert from one-based to zero-based. */
1956 end = p->value.character.length;
1957 if (p->ref && p->ref->u.ss.end)
1958 gfc_extract_hwi (p->ref->u.ss.end, &end);
1960 if (end < start)
1961 end = start;
1963 s = gfc_get_wide_string (end - start + 2);
1964 memcpy (s, p->value.character.string + start,
1965 (end - start) * sizeof (gfc_char_t));
1966 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1967 free (p->value.character.string);
1968 p->value.character.string = s;
1969 p->value.character.length = end - start;
1970 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1971 p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
1972 NULL,
1973 p->value.character.length);
1974 gfc_free_ref_list (p->ref);
1975 p->ref = NULL;
1976 p->expr_type = EXPR_CONSTANT;
1978 break;
1980 case EXPR_OP:
1981 if (!simplify_intrinsic_op (p, type))
1982 return false;
1983 break;
1985 case EXPR_VARIABLE:
1986 /* Only substitute array parameter variables if we are in an
1987 initialization expression, or we want a subsection. */
1988 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1989 && (gfc_init_expr_flag || p->ref
1990 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1992 if (!simplify_parameter_variable (p, type))
1993 return false;
1994 break;
1997 if (type == 1)
1999 gfc_simplify_iterator_var (p);
2002 /* Simplify subcomponent references. */
2003 if (!simplify_ref_chain (p->ref, type))
2004 return false;
2006 break;
2008 case EXPR_STRUCTURE:
2009 case EXPR_ARRAY:
2010 if (!simplify_ref_chain (p->ref, type))
2011 return false;
2013 if (!simplify_constructor (p->value.constructor, type))
2014 return false;
2016 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
2017 && p->ref->u.ar.type == AR_FULL)
2018 gfc_expand_constructor (p, false);
2020 if (!simplify_const_ref (p))
2021 return false;
2023 break;
2025 case EXPR_COMPCALL:
2026 case EXPR_PPC:
2027 break;
2030 return true;
2034 /* Returns the type of an expression with the exception that iterator
2035 variables are automatically integers no matter what else they may
2036 be declared as. */
2038 static bt
2039 et0 (gfc_expr *e)
2041 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
2042 return BT_INTEGER;
2044 return e->ts.type;
2048 /* Scalarize an expression for an elemental intrinsic call. */
2050 static bool
2051 scalarize_intrinsic_call (gfc_expr *e)
2053 gfc_actual_arglist *a, *b;
2054 gfc_constructor_base ctor;
2055 gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */
2056 gfc_constructor *ci, *new_ctor;
2057 gfc_expr *expr, *old;
2058 int n, i, rank[5], array_arg;
2060 /* Find which, if any, arguments are arrays. Assume that the old
2061 expression carries the type information and that the first arg
2062 that is an array expression carries all the shape information.*/
2063 n = array_arg = 0;
2064 a = e->value.function.actual;
2065 for (; a; a = a->next)
2067 n++;
2068 if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
2069 continue;
2070 array_arg = n;
2071 expr = gfc_copy_expr (a->expr);
2072 break;
2075 if (!array_arg)
2076 return false;
2078 old = gfc_copy_expr (e);
2080 gfc_constructor_free (expr->value.constructor);
2081 expr->value.constructor = NULL;
2082 expr->ts = old->ts;
2083 expr->where = old->where;
2084 expr->expr_type = EXPR_ARRAY;
2086 /* Copy the array argument constructors into an array, with nulls
2087 for the scalars. */
2088 n = 0;
2089 a = old->value.function.actual;
2090 for (; a; a = a->next)
2092 /* Check that this is OK for an initialization expression. */
2093 if (a->expr && !gfc_check_init_expr (a->expr))
2094 goto cleanup;
2096 rank[n] = 0;
2097 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2099 rank[n] = a->expr->rank;
2100 ctor = a->expr->symtree->n.sym->value->value.constructor;
2101 args[n] = gfc_constructor_first (ctor);
2103 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2105 if (a->expr->rank)
2106 rank[n] = a->expr->rank;
2107 else
2108 rank[n] = 1;
2109 ctor = gfc_constructor_copy (a->expr->value.constructor);
2110 args[n] = gfc_constructor_first (ctor);
2112 else
2113 args[n] = NULL;
2115 n++;
2119 /* Using the array argument as the master, step through the array
2120 calling the function for each element and advancing the array
2121 constructors together. */
2122 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2124 new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2125 gfc_copy_expr (old), NULL);
2127 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2128 a = NULL;
2129 b = old->value.function.actual;
2130 for (i = 0; i < n; i++)
2132 if (a == NULL)
2133 new_ctor->expr->value.function.actual
2134 = a = gfc_get_actual_arglist ();
2135 else
2137 a->next = gfc_get_actual_arglist ();
2138 a = a->next;
2141 if (args[i])
2142 a->expr = gfc_copy_expr (args[i]->expr);
2143 else
2144 a->expr = gfc_copy_expr (b->expr);
2146 b = b->next;
2149 /* Simplify the function calls. If the simplification fails, the
2150 error will be flagged up down-stream or the library will deal
2151 with it. */
2152 gfc_simplify_expr (new_ctor->expr, 0);
2154 for (i = 0; i < n; i++)
2155 if (args[i])
2156 args[i] = gfc_constructor_next (args[i]);
2158 for (i = 1; i < n; i++)
2159 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
2160 || (args[i] == NULL && args[array_arg - 1] != NULL)))
2161 goto compliance;
2164 free_expr0 (e);
2165 *e = *expr;
2166 /* Free "expr" but not the pointers it contains. */
2167 free (expr);
2168 gfc_free_expr (old);
2169 return true;
2171 compliance:
2172 gfc_error_now ("elemental function arguments at %C are not compliant");
2174 cleanup:
2175 gfc_free_expr (expr);
2176 gfc_free_expr (old);
2177 return false;
2181 static bool
2182 check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
2184 gfc_expr *op1 = e->value.op.op1;
2185 gfc_expr *op2 = e->value.op.op2;
2187 if (!(*check_function)(op1))
2188 return false;
2190 switch (e->value.op.op)
2192 case INTRINSIC_UPLUS:
2193 case INTRINSIC_UMINUS:
2194 if (!numeric_type (et0 (op1)))
2195 goto not_numeric;
2196 break;
2198 case INTRINSIC_EQ:
2199 case INTRINSIC_EQ_OS:
2200 case INTRINSIC_NE:
2201 case INTRINSIC_NE_OS:
2202 case INTRINSIC_GT:
2203 case INTRINSIC_GT_OS:
2204 case INTRINSIC_GE:
2205 case INTRINSIC_GE_OS:
2206 case INTRINSIC_LT:
2207 case INTRINSIC_LT_OS:
2208 case INTRINSIC_LE:
2209 case INTRINSIC_LE_OS:
2210 if (!(*check_function)(op2))
2211 return false;
2213 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2214 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2216 gfc_error ("Numeric or CHARACTER operands are required in "
2217 "expression at %L", &e->where);
2218 return false;
2220 break;
2222 case INTRINSIC_PLUS:
2223 case INTRINSIC_MINUS:
2224 case INTRINSIC_TIMES:
2225 case INTRINSIC_DIVIDE:
2226 case INTRINSIC_POWER:
2227 if (!(*check_function)(op2))
2228 return false;
2230 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2231 goto not_numeric;
2233 break;
2235 case INTRINSIC_CONCAT:
2236 if (!(*check_function)(op2))
2237 return false;
2239 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2241 gfc_error ("Concatenation operator in expression at %L "
2242 "must have two CHARACTER operands", &op1->where);
2243 return false;
2246 if (op1->ts.kind != op2->ts.kind)
2248 gfc_error ("Concat operator at %L must concatenate strings of the "
2249 "same kind", &e->where);
2250 return false;
2253 break;
2255 case INTRINSIC_NOT:
2256 if (et0 (op1) != BT_LOGICAL)
2258 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2259 "operand", &op1->where);
2260 return false;
2263 break;
2265 case INTRINSIC_AND:
2266 case INTRINSIC_OR:
2267 case INTRINSIC_EQV:
2268 case INTRINSIC_NEQV:
2269 if (!(*check_function)(op2))
2270 return false;
2272 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2274 gfc_error ("LOGICAL operands are required in expression at %L",
2275 &e->where);
2276 return false;
2279 break;
2281 case INTRINSIC_PARENTHESES:
2282 break;
2284 default:
2285 gfc_error ("Only intrinsic operators can be used in expression at %L",
2286 &e->where);
2287 return false;
2290 return true;
2292 not_numeric:
2293 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2295 return false;
2298 /* F2003, 7.1.7 (3): In init expression, allocatable components
2299 must not be data-initialized. */
2300 static bool
2301 check_alloc_comp_init (gfc_expr *e)
2303 gfc_component *comp;
2304 gfc_constructor *ctor;
2306 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2307 gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);
2309 for (comp = e->ts.u.derived->components,
2310 ctor = gfc_constructor_first (e->value.constructor);
2311 comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2313 if (comp->attr.allocatable && ctor->expr
2314 && ctor->expr->expr_type != EXPR_NULL)
2316 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2317 "component %qs in structure constructor at %L",
2318 comp->name, &ctor->expr->where);
2319 return false;
2323 return true;
2326 static match
2327 check_init_expr_arguments (gfc_expr *e)
2329 gfc_actual_arglist *ap;
2331 for (ap = e->value.function.actual; ap; ap = ap->next)
2332 if (!gfc_check_init_expr (ap->expr))
2333 return MATCH_ERROR;
2335 return MATCH_YES;
2338 static bool check_restricted (gfc_expr *);
2340 /* F95, 7.1.6.1, Initialization expressions, (7)
2341 F2003, 7.1.7 Initialization expression, (8) */
2343 static match
2344 check_inquiry (gfc_expr *e, int not_restricted)
2346 const char *name;
2347 const char *const *functions;
2349 static const char *const inquiry_func_f95[] = {
2350 "lbound", "shape", "size", "ubound",
2351 "bit_size", "len", "kind",
2352 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2353 "precision", "radix", "range", "tiny",
2354 NULL
2357 static const char *const inquiry_func_f2003[] = {
2358 "lbound", "shape", "size", "ubound",
2359 "bit_size", "len", "kind",
2360 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2361 "precision", "radix", "range", "tiny",
2362 "new_line", NULL
2365 int i = 0;
2366 gfc_actual_arglist *ap;
2368 if (!e->value.function.isym
2369 || !e->value.function.isym->inquiry)
2370 return MATCH_NO;
2372 /* An undeclared parameter will get us here (PR25018). */
2373 if (e->symtree == NULL)
2374 return MATCH_NO;
2376 if (e->symtree->n.sym->from_intmod)
2378 if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
2379 && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
2380 && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
2381 return MATCH_NO;
2383 if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
2384 && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
2385 return MATCH_NO;
2387 else
2389 name = e->symtree->n.sym->name;
2391 functions = (gfc_option.warn_std & GFC_STD_F2003)
2392 ? inquiry_func_f2003 : inquiry_func_f95;
2394 for (i = 0; functions[i]; i++)
2395 if (strcmp (functions[i], name) == 0)
2396 break;
2398 if (functions[i] == NULL)
2399 return MATCH_ERROR;
2402 /* At this point we have an inquiry function with a variable argument. The
2403 type of the variable might be undefined, but we need it now, because the
2404 arguments of these functions are not allowed to be undefined. */
2406 for (ap = e->value.function.actual; ap; ap = ap->next)
2408 if (!ap->expr)
2409 continue;
2411 if (ap->expr->ts.type == BT_UNKNOWN)
2413 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2414 && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
2415 return MATCH_NO;
2417 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2420 /* Assumed character length will not reduce to a constant expression
2421 with LEN, as required by the standard. */
2422 if (i == 5 && not_restricted
2423 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2424 && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
2425 || ap->expr->symtree->n.sym->ts.deferred))
2427 gfc_error ("Assumed or deferred character length variable %qs "
2428 "in constant expression at %L",
2429 ap->expr->symtree->n.sym->name,
2430 &ap->expr->where);
2431 return MATCH_ERROR;
2433 else if (not_restricted && !gfc_check_init_expr (ap->expr))
2434 return MATCH_ERROR;
2436 if (not_restricted == 0
2437 && ap->expr->expr_type != EXPR_VARIABLE
2438 && !check_restricted (ap->expr))
2439 return MATCH_ERROR;
2441 if (not_restricted == 0
2442 && ap->expr->expr_type == EXPR_VARIABLE
2443 && ap->expr->symtree->n.sym->attr.dummy
2444 && ap->expr->symtree->n.sym->attr.optional)
2445 return MATCH_NO;
2448 return MATCH_YES;
2452 /* F95, 7.1.6.1, Initialization expressions, (5)
2453 F2003, 7.1.7 Initialization expression, (5) */
2455 static match
2456 check_transformational (gfc_expr *e)
2458 static const char * const trans_func_f95[] = {
2459 "repeat", "reshape", "selected_int_kind",
2460 "selected_real_kind", "transfer", "trim", NULL
2463 static const char * const trans_func_f2003[] = {
2464 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2465 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2466 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2467 "trim", "unpack", NULL
2470 int i;
2471 const char *name;
2472 const char *const *functions;
2474 if (!e->value.function.isym
2475 || !e->value.function.isym->transformational)
2476 return MATCH_NO;
2478 name = e->symtree->n.sym->name;
2480 functions = (gfc_option.allow_std & GFC_STD_F2003)
2481 ? trans_func_f2003 : trans_func_f95;
2483 /* NULL() is dealt with below. */
2484 if (strcmp ("null", name) == 0)
2485 return MATCH_NO;
2487 for (i = 0; functions[i]; i++)
2488 if (strcmp (functions[i], name) == 0)
2489 break;
2491 if (functions[i] == NULL)
2493 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2494 "in an initialization expression", name, &e->where);
2495 return MATCH_ERROR;
2498 return check_init_expr_arguments (e);
2502 /* F95, 7.1.6.1, Initialization expressions, (6)
2503 F2003, 7.1.7 Initialization expression, (6) */
2505 static match
2506 check_null (gfc_expr *e)
2508 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2509 return MATCH_NO;
2511 return check_init_expr_arguments (e);
2515 static match
2516 check_elemental (gfc_expr *e)
2518 if (!e->value.function.isym
2519 || !e->value.function.isym->elemental)
2520 return MATCH_NO;
2522 if (e->ts.type != BT_INTEGER
2523 && e->ts.type != BT_CHARACTER
2524 && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard "
2525 "initialization expression at %L", &e->where))
2526 return MATCH_ERROR;
2528 return check_init_expr_arguments (e);
2532 static match
2533 check_conversion (gfc_expr *e)
2535 if (!e->value.function.isym
2536 || !e->value.function.isym->conversion)
2537 return MATCH_NO;
2539 return check_init_expr_arguments (e);
2543 /* Verify that an expression is an initialization expression. A side
2544 effect is that the expression tree is reduced to a single constant
2545 node if all goes well. This would normally happen when the
2546 expression is constructed but function references are assumed to be
2547 intrinsics in the context of initialization expressions. If
2548 false is returned an error message has been generated. */
2550 bool
2551 gfc_check_init_expr (gfc_expr *e)
2553 match m;
2554 bool t;
2556 if (e == NULL)
2557 return true;
2559 switch (e->expr_type)
2561 case EXPR_OP:
2562 t = check_intrinsic_op (e, gfc_check_init_expr);
2563 if (t)
2564 t = gfc_simplify_expr (e, 0);
2566 break;
2568 case EXPR_FUNCTION:
2569 t = false;
2572 bool conversion;
2573 gfc_intrinsic_sym* isym = NULL;
2574 gfc_symbol* sym = e->symtree->n.sym;
2576 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2577 IEEE_EXCEPTIONS modules. */
2578 int mod = sym->from_intmod;
2579 if (mod == INTMOD_NONE && sym->generic)
2580 mod = sym->generic->sym->from_intmod;
2581 if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
2583 gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
2584 if (new_expr)
2586 gfc_replace_expr (e, new_expr);
2587 t = true;
2588 break;
2592 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2593 into an array constructor, we need to skip the error check here.
2594 Conversion errors are caught below in scalarize_intrinsic_call. */
2595 conversion = e->value.function.isym
2596 && (e->value.function.isym->conversion == 1);
2598 if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
2599 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES))
2601 gfc_error ("Function %qs in initialization expression at %L "
2602 "must be an intrinsic function",
2603 e->symtree->n.sym->name, &e->where);
2604 break;
2607 if ((m = check_conversion (e)) == MATCH_NO
2608 && (m = check_inquiry (e, 1)) == MATCH_NO
2609 && (m = check_null (e)) == MATCH_NO
2610 && (m = check_transformational (e)) == MATCH_NO
2611 && (m = check_elemental (e)) == MATCH_NO)
2613 gfc_error ("Intrinsic function %qs at %L is not permitted "
2614 "in an initialization expression",
2615 e->symtree->n.sym->name, &e->where);
2616 m = MATCH_ERROR;
2619 if (m == MATCH_ERROR)
2620 return false;
2622 /* Try to scalarize an elemental intrinsic function that has an
2623 array argument. */
2624 isym = gfc_find_function (e->symtree->n.sym->name);
2625 if (isym && isym->elemental
2626 && (t = scalarize_intrinsic_call (e)))
2627 break;
2630 if (m == MATCH_YES)
2631 t = gfc_simplify_expr (e, 0);
2633 break;
2635 case EXPR_VARIABLE:
2636 t = true;
2638 /* This occurs when parsing pdt templates. */
2639 if (gfc_expr_attr (e).pdt_kind)
2640 break;
2642 if (gfc_check_iter_variable (e))
2643 break;
2645 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2647 /* A PARAMETER shall not be used to define itself, i.e.
2648 REAL, PARAMETER :: x = transfer(0, x)
2649 is invalid. */
2650 if (!e->symtree->n.sym->value)
2652 gfc_error ("PARAMETER %qs is used at %L before its definition "
2653 "is complete", e->symtree->n.sym->name, &e->where);
2654 t = false;
2656 else
2657 t = simplify_parameter_variable (e, 0);
2659 break;
2662 if (gfc_in_match_data ())
2663 break;
2665 t = false;
2667 if (e->symtree->n.sym->as)
2669 switch (e->symtree->n.sym->as->type)
2671 case AS_ASSUMED_SIZE:
2672 gfc_error ("Assumed size array %qs at %L is not permitted "
2673 "in an initialization expression",
2674 e->symtree->n.sym->name, &e->where);
2675 break;
2677 case AS_ASSUMED_SHAPE:
2678 gfc_error ("Assumed shape array %qs at %L is not permitted "
2679 "in an initialization expression",
2680 e->symtree->n.sym->name, &e->where);
2681 break;
2683 case AS_DEFERRED:
2684 gfc_error ("Deferred array %qs at %L is not permitted "
2685 "in an initialization expression",
2686 e->symtree->n.sym->name, &e->where);
2687 break;
2689 case AS_EXPLICIT:
2690 gfc_error ("Array %qs at %L is a variable, which does "
2691 "not reduce to a constant expression",
2692 e->symtree->n.sym->name, &e->where);
2693 break;
2695 default:
2696 gcc_unreachable();
2699 else
2700 gfc_error ("Parameter %qs at %L has not been declared or is "
2701 "a variable, which does not reduce to a constant "
2702 "expression", e->symtree->name, &e->where);
2704 break;
2706 case EXPR_CONSTANT:
2707 case EXPR_NULL:
2708 t = true;
2709 break;
2711 case EXPR_SUBSTRING:
2712 if (e->ref)
2714 t = gfc_check_init_expr (e->ref->u.ss.start);
2715 if (!t)
2716 break;
2718 t = gfc_check_init_expr (e->ref->u.ss.end);
2719 if (t)
2720 t = gfc_simplify_expr (e, 0);
2722 else
2723 t = false;
2724 break;
2726 case EXPR_STRUCTURE:
2727 t = e->ts.is_iso_c ? true : false;
2728 if (t)
2729 break;
2731 t = check_alloc_comp_init (e);
2732 if (!t)
2733 break;
2735 t = gfc_check_constructor (e, gfc_check_init_expr);
2736 if (!t)
2737 break;
2739 break;
2741 case EXPR_ARRAY:
2742 t = gfc_check_constructor (e, gfc_check_init_expr);
2743 if (!t)
2744 break;
2746 t = gfc_expand_constructor (e, true);
2747 if (!t)
2748 break;
2750 t = gfc_check_constructor_type (e);
2751 break;
2753 default:
2754 gfc_internal_error ("check_init_expr(): Unknown expression type");
2757 return t;
2760 /* Reduces a general expression to an initialization expression (a constant).
2761 This used to be part of gfc_match_init_expr.
2762 Note that this function doesn't free the given expression on false. */
2764 bool
2765 gfc_reduce_init_expr (gfc_expr *expr)
2767 bool t;
2769 gfc_init_expr_flag = true;
2770 t = gfc_resolve_expr (expr);
2771 if (t)
2772 t = gfc_check_init_expr (expr);
2773 gfc_init_expr_flag = false;
2775 if (!t)
2776 return false;
2778 if (expr->expr_type == EXPR_ARRAY)
2780 if (!gfc_check_constructor_type (expr))
2781 return false;
2782 if (!gfc_expand_constructor (expr, true))
2783 return false;
2786 return true;
2790 /* Match an initialization expression. We work by first matching an
2791 expression, then reducing it to a constant. */
2793 match
2794 gfc_match_init_expr (gfc_expr **result)
2796 gfc_expr *expr;
2797 match m;
2798 bool t;
2800 expr = NULL;
2802 gfc_init_expr_flag = true;
2804 m = gfc_match_expr (&expr);
2805 if (m != MATCH_YES)
2807 gfc_init_expr_flag = false;
2808 return m;
2811 if (gfc_derived_parameter_expr (expr))
2813 *result = expr;
2814 gfc_init_expr_flag = false;
2815 return m;
2818 t = gfc_reduce_init_expr (expr);
2819 if (!t)
2821 gfc_free_expr (expr);
2822 gfc_init_expr_flag = false;
2823 return MATCH_ERROR;
2826 *result = expr;
2827 gfc_init_expr_flag = false;
2829 return MATCH_YES;
2833 /* Given an actual argument list, test to see that each argument is a
2834 restricted expression and optionally if the expression type is
2835 integer or character. */
2837 static bool
2838 restricted_args (gfc_actual_arglist *a)
2840 for (; a; a = a->next)
2842 if (!check_restricted (a->expr))
2843 return false;
2846 return true;
2850 /************* Restricted/specification expressions *************/
2853 /* Make sure a non-intrinsic function is a specification function,
2854 * see F08:7.1.11.5. */
2856 static bool
2857 external_spec_function (gfc_expr *e)
2859 gfc_symbol *f;
2861 f = e->value.function.esym;
2863 /* IEEE functions allowed are "a reference to a transformational function
2864 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2865 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2866 IEEE_EXCEPTIONS". */
2867 if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
2868 || f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
2870 if (!strcmp (f->name, "ieee_selected_real_kind")
2871 || !strcmp (f->name, "ieee_support_rounding")
2872 || !strcmp (f->name, "ieee_support_flag")
2873 || !strcmp (f->name, "ieee_support_halting")
2874 || !strcmp (f->name, "ieee_support_datatype")
2875 || !strcmp (f->name, "ieee_support_denormal")
2876 || !strcmp (f->name, "ieee_support_divide")
2877 || !strcmp (f->name, "ieee_support_inf")
2878 || !strcmp (f->name, "ieee_support_io")
2879 || !strcmp (f->name, "ieee_support_nan")
2880 || !strcmp (f->name, "ieee_support_sqrt")
2881 || !strcmp (f->name, "ieee_support_standard")
2882 || !strcmp (f->name, "ieee_support_underflow_control"))
2883 goto function_allowed;
2886 if (f->attr.proc == PROC_ST_FUNCTION)
2888 gfc_error ("Specification function %qs at %L cannot be a statement "
2889 "function", f->name, &e->where);
2890 return false;
2893 if (f->attr.proc == PROC_INTERNAL)
2895 gfc_error ("Specification function %qs at %L cannot be an internal "
2896 "function", f->name, &e->where);
2897 return false;
2900 if (!f->attr.pure && !f->attr.elemental)
2902 gfc_error ("Specification function %qs at %L must be PURE", f->name,
2903 &e->where);
2904 return false;
2907 /* F08:7.1.11.6. */
2908 if (f->attr.recursive
2909 && !gfc_notify_std (GFC_STD_F2003,
2910 "Specification function %qs "
2911 "at %L cannot be RECURSIVE", f->name, &e->where))
2912 return false;
2914 function_allowed:
2915 return restricted_args (e->value.function.actual);
2919 /* Check to see that a function reference to an intrinsic is a
2920 restricted expression. */
2922 static bool
2923 restricted_intrinsic (gfc_expr *e)
2925 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2926 if (check_inquiry (e, 0) == MATCH_YES)
2927 return true;
2929 return restricted_args (e->value.function.actual);
2933 /* Check the expressions of an actual arglist. Used by check_restricted. */
2935 static bool
2936 check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*))
2938 for (; arg; arg = arg->next)
2939 if (!checker (arg->expr))
2940 return false;
2942 return true;
2946 /* Check the subscription expressions of a reference chain with a checking
2947 function; used by check_restricted. */
2949 static bool
2950 check_references (gfc_ref* ref, bool (*checker) (gfc_expr*))
2952 int dim;
2954 if (!ref)
2955 return true;
2957 switch (ref->type)
2959 case REF_ARRAY:
2960 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2962 if (!checker (ref->u.ar.start[dim]))
2963 return false;
2964 if (!checker (ref->u.ar.end[dim]))
2965 return false;
2966 if (!checker (ref->u.ar.stride[dim]))
2967 return false;
2969 break;
2971 case REF_COMPONENT:
2972 /* Nothing needed, just proceed to next reference. */
2973 break;
2975 case REF_SUBSTRING:
2976 if (!checker (ref->u.ss.start))
2977 return false;
2978 if (!checker (ref->u.ss.end))
2979 return false;
2980 break;
2982 default:
2983 gcc_unreachable ();
2984 break;
2987 return check_references (ref->next, checker);
2990 /* Return true if ns is a parent of the current ns. */
2992 static bool
2993 is_parent_of_current_ns (gfc_namespace *ns)
2995 gfc_namespace *p;
2996 for (p = gfc_current_ns->parent; p; p = p->parent)
2997 if (ns == p)
2998 return true;
3000 return false;
3003 /* Verify that an expression is a restricted expression. Like its
3004 cousin check_init_expr(), an error message is generated if we
3005 return false. */
3007 static bool
3008 check_restricted (gfc_expr *e)
3010 gfc_symbol* sym;
3011 bool t;
3013 if (e == NULL)
3014 return true;
3016 switch (e->expr_type)
3018 case EXPR_OP:
3019 t = check_intrinsic_op (e, check_restricted);
3020 if (t)
3021 t = gfc_simplify_expr (e, 0);
3023 break;
3025 case EXPR_FUNCTION:
3026 if (e->value.function.esym)
3028 t = check_arglist (e->value.function.actual, &check_restricted);
3029 if (t)
3030 t = external_spec_function (e);
3032 else
3034 if (e->value.function.isym && e->value.function.isym->inquiry)
3035 t = true;
3036 else
3037 t = check_arglist (e->value.function.actual, &check_restricted);
3039 if (t)
3040 t = restricted_intrinsic (e);
3042 break;
3044 case EXPR_VARIABLE:
3045 sym = e->symtree->n.sym;
3046 t = false;
3048 /* If a dummy argument appears in a context that is valid for a
3049 restricted expression in an elemental procedure, it will have
3050 already been simplified away once we get here. Therefore we
3051 don't need to jump through hoops to distinguish valid from
3052 invalid cases. */
3053 if (sym->attr.dummy && sym->ns == gfc_current_ns
3054 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
3056 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3057 sym->name, &e->where);
3058 break;
3061 if (sym->attr.optional)
3063 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3064 sym->name, &e->where);
3065 break;
3068 if (sym->attr.intent == INTENT_OUT)
3070 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3071 sym->name, &e->where);
3072 break;
3075 /* Check reference chain if any. */
3076 if (!check_references (e->ref, &check_restricted))
3077 break;
3079 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3080 processed in resolve.c(resolve_formal_arglist). This is done so
3081 that host associated dummy array indices are accepted (PR23446).
3082 This mechanism also does the same for the specification expressions
3083 of array-valued functions. */
3084 if (e->error
3085 || sym->attr.in_common
3086 || sym->attr.use_assoc
3087 || sym->attr.dummy
3088 || sym->attr.implied_index
3089 || sym->attr.flavor == FL_PARAMETER
3090 || is_parent_of_current_ns (sym->ns)
3091 || (sym->ns->proc_name != NULL
3092 && sym->ns->proc_name->attr.flavor == FL_MODULE)
3093 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
3095 t = true;
3096 break;
3099 gfc_error ("Variable %qs cannot appear in the expression at %L",
3100 sym->name, &e->where);
3101 /* Prevent a repetition of the error. */
3102 e->error = 1;
3103 break;
3105 case EXPR_NULL:
3106 case EXPR_CONSTANT:
3107 t = true;
3108 break;
3110 case EXPR_SUBSTRING:
3111 t = gfc_specification_expr (e->ref->u.ss.start);
3112 if (!t)
3113 break;
3115 t = gfc_specification_expr (e->ref->u.ss.end);
3116 if (t)
3117 t = gfc_simplify_expr (e, 0);
3119 break;
3121 case EXPR_STRUCTURE:
3122 t = gfc_check_constructor (e, check_restricted);
3123 break;
3125 case EXPR_ARRAY:
3126 t = gfc_check_constructor (e, check_restricted);
3127 break;
3129 default:
3130 gfc_internal_error ("check_restricted(): Unknown expression type");
3133 return t;
3137 /* Check to see that an expression is a specification expression. If
3138 we return false, an error has been generated. */
3140 bool
3141 gfc_specification_expr (gfc_expr *e)
3143 gfc_component *comp;
3145 if (e == NULL)
3146 return true;
3148 if (e->ts.type != BT_INTEGER)
3150 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3151 &e->where, gfc_basic_typename (e->ts.type));
3152 return false;
3155 comp = gfc_get_proc_ptr_comp (e);
3156 if (e->expr_type == EXPR_FUNCTION
3157 && !e->value.function.isym
3158 && !e->value.function.esym
3159 && !gfc_pure (e->symtree->n.sym)
3160 && (!comp || !comp->attr.pure))
3162 gfc_error ("Function %qs at %L must be PURE",
3163 e->symtree->n.sym->name, &e->where);
3164 /* Prevent repeat error messages. */
3165 e->symtree->n.sym->attr.pure = 1;
3166 return false;
3169 if (e->rank != 0)
3171 gfc_error ("Expression at %L must be scalar", &e->where);
3172 return false;
3175 if (!gfc_simplify_expr (e, 0))
3176 return false;
3178 return check_restricted (e);
3182 /************** Expression conformance checks. *************/
3184 /* Given two expressions, make sure that the arrays are conformable. */
3186 bool
3187 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
3189 int op1_flag, op2_flag, d;
3190 mpz_t op1_size, op2_size;
3191 bool t;
3193 va_list argp;
3194 char buffer[240];
3196 if (op1->rank == 0 || op2->rank == 0)
3197 return true;
3199 va_start (argp, optype_msgid);
3200 vsnprintf (buffer, 240, optype_msgid, argp);
3201 va_end (argp);
3203 if (op1->rank != op2->rank)
3205 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
3206 op1->rank, op2->rank, &op1->where);
3207 return false;
3210 t = true;
3212 for (d = 0; d < op1->rank; d++)
3214 op1_flag = gfc_array_dimen_size(op1, d, &op1_size);
3215 op2_flag = gfc_array_dimen_size(op2, d, &op2_size);
3217 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3219 gfc_error ("Different shape for %s at %L on dimension %d "
3220 "(%d and %d)", _(buffer), &op1->where, d + 1,
3221 (int) mpz_get_si (op1_size),
3222 (int) mpz_get_si (op2_size));
3224 t = false;
3227 if (op1_flag)
3228 mpz_clear (op1_size);
3229 if (op2_flag)
3230 mpz_clear (op2_size);
3232 if (!t)
3233 return false;
3236 return true;
3240 /* Given an assignable expression and an arbitrary expression, make
3241 sure that the assignment can take place. Only add a call to the intrinsic
3242 conversion routines, when allow_convert is set. When this assign is a
3243 coarray call, then the convert is done by the coarray routine implictly and
3244 adding the intrinsic conversion would do harm in most cases. */
3246 bool
3247 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
3248 bool allow_convert)
3250 gfc_symbol *sym;
3251 gfc_ref *ref;
3252 int has_pointer;
3254 sym = lvalue->symtree->n.sym;
3256 /* See if this is the component or subcomponent of a pointer. */
3257 has_pointer = sym->attr.pointer;
3258 for (ref = lvalue->ref; ref; ref = ref->next)
3259 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3261 has_pointer = 1;
3262 break;
3265 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3266 variable local to a function subprogram. Its existence begins when
3267 execution of the function is initiated and ends when execution of the
3268 function is terminated...
3269 Therefore, the left hand side is no longer a variable, when it is: */
3270 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3271 && !sym->attr.external)
3273 bool bad_proc;
3274 bad_proc = false;
3276 /* (i) Use associated; */
3277 if (sym->attr.use_assoc)
3278 bad_proc = true;
3280 /* (ii) The assignment is in the main program; or */
3281 if (gfc_current_ns->proc_name
3282 && gfc_current_ns->proc_name->attr.is_main_program)
3283 bad_proc = true;
3285 /* (iii) A module or internal procedure... */
3286 if (gfc_current_ns->proc_name
3287 && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3288 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3289 && gfc_current_ns->parent
3290 && (!(gfc_current_ns->parent->proc_name->attr.function
3291 || gfc_current_ns->parent->proc_name->attr.subroutine)
3292 || gfc_current_ns->parent->proc_name->attr.is_main_program))
3294 /* ... that is not a function... */
3295 if (gfc_current_ns->proc_name
3296 && !gfc_current_ns->proc_name->attr.function)
3297 bad_proc = true;
3299 /* ... or is not an entry and has a different name. */
3300 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3301 bad_proc = true;
3304 /* (iv) Host associated and not the function symbol or the
3305 parent result. This picks up sibling references, which
3306 cannot be entries. */
3307 if (!sym->attr.entry
3308 && sym->ns == gfc_current_ns->parent
3309 && sym != gfc_current_ns->proc_name
3310 && sym != gfc_current_ns->parent->proc_name->result)
3311 bad_proc = true;
3313 if (bad_proc)
3315 gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
3316 return false;
3320 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3322 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3323 lvalue->rank, rvalue->rank, &lvalue->where);
3324 return false;
3327 if (lvalue->ts.type == BT_UNKNOWN)
3329 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3330 &lvalue->where);
3331 return false;
3334 if (rvalue->expr_type == EXPR_NULL)
3336 if (has_pointer && (ref == NULL || ref->next == NULL)
3337 && lvalue->symtree->n.sym->attr.data)
3338 return true;
3339 else
3341 gfc_error ("NULL appears on right-hand side in assignment at %L",
3342 &rvalue->where);
3343 return false;
3347 /* This is possibly a typo: x = f() instead of x => f(). */
3348 if (warn_surprising
3349 && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
3350 gfc_warning (OPT_Wsurprising,
3351 "POINTER-valued function appears on right-hand side of "
3352 "assignment at %L", &rvalue->where);
3354 /* Check size of array assignments. */
3355 if (lvalue->rank != 0 && rvalue->rank != 0
3356 && !gfc_check_conformance (lvalue, rvalue, "array assignment"))
3357 return false;
3359 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3360 && lvalue->symtree->n.sym->attr.data
3361 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
3362 "initialize non-integer variable %qs",
3363 &rvalue->where, lvalue->symtree->n.sym->name))
3364 return false;
3365 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3366 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
3367 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3368 &rvalue->where))
3369 return false;
3371 /* Handle the case of a BOZ literal on the RHS. */
3372 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3374 int rc;
3375 if (warn_surprising)
3376 gfc_warning (OPT_Wsurprising,
3377 "BOZ literal at %L is bitwise transferred "
3378 "non-integer symbol %qs", &rvalue->where,
3379 lvalue->symtree->n.sym->name);
3380 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3381 return false;
3382 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3384 if (rc == ARITH_UNDERFLOW)
3385 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3386 ". This check can be disabled with the option "
3387 "%<-fno-range-check%>", &rvalue->where);
3388 else if (rc == ARITH_OVERFLOW)
3389 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3390 ". This check can be disabled with the option "
3391 "%<-fno-range-check%>", &rvalue->where);
3392 else if (rc == ARITH_NAN)
3393 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3394 ". This check can be disabled with the option "
3395 "%<-fno-range-check%>", &rvalue->where);
3396 return false;
3400 if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
3402 gfc_error ("The assignment to a KIND or LEN component of a "
3403 "parameterized type at %L is not allowed",
3404 &lvalue->where);
3405 return false;
3408 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3409 return true;
3411 /* Only DATA Statements come here. */
3412 if (!conform)
3414 /* Numeric can be converted to any other numeric. And Hollerith can be
3415 converted to any other type. */
3416 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3417 || rvalue->ts.type == BT_HOLLERITH)
3418 return true;
3420 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3421 return true;
3423 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3424 "conversion of %s to %s", &lvalue->where,
3425 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3427 return false;
3430 /* Assignment is the only case where character variables of different
3431 kind values can be converted into one another. */
3432 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3434 if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
3435 return gfc_convert_chartype (rvalue, &lvalue->ts);
3436 else
3437 return true;
3440 if (!allow_convert)
3441 return true;
3443 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3447 /* Check that a pointer assignment is OK. We first check lvalue, and
3448 we only check rvalue if it's not an assignment to NULL() or a
3449 NULLIFY statement. */
3451 bool
3452 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3454 symbol_attribute attr, lhs_attr;
3455 gfc_ref *ref;
3456 bool is_pure, is_implicit_pure, rank_remap;
3457 int proc_pointer;
3459 lhs_attr = gfc_expr_attr (lvalue);
3460 if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
3462 gfc_error ("Pointer assignment target is not a POINTER at %L",
3463 &lvalue->where);
3464 return false;
3467 if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
3468 && !lhs_attr.proc_pointer)
3470 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3471 "l-value since it is a procedure",
3472 lvalue->symtree->n.sym->name, &lvalue->where);
3473 return false;
3476 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3478 rank_remap = false;
3479 for (ref = lvalue->ref; ref; ref = ref->next)
3481 if (ref->type == REF_COMPONENT)
3482 proc_pointer = ref->u.c.component->attr.proc_pointer;
3484 if (ref->type == REF_ARRAY && ref->next == NULL)
3486 int dim;
3488 if (ref->u.ar.type == AR_FULL)
3489 break;
3491 if (ref->u.ar.type != AR_SECTION)
3493 gfc_error ("Expected bounds specification for %qs at %L",
3494 lvalue->symtree->n.sym->name, &lvalue->where);
3495 return false;
3498 if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
3499 "for %qs in pointer assignment at %L",
3500 lvalue->symtree->n.sym->name, &lvalue->where))
3501 return false;
3503 /* When bounds are given, all lbounds are necessary and either all
3504 or none of the upper bounds; no strides are allowed. If the
3505 upper bounds are present, we may do rank remapping. */
3506 for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3508 if (!ref->u.ar.start[dim]
3509 || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3511 gfc_error ("Lower bound has to be present at %L",
3512 &lvalue->where);
3513 return false;
3515 if (ref->u.ar.stride[dim])
3517 gfc_error ("Stride must not be present at %L",
3518 &lvalue->where);
3519 return false;
3522 if (dim == 0)
3523 rank_remap = (ref->u.ar.end[dim] != NULL);
3524 else
3526 if ((rank_remap && !ref->u.ar.end[dim])
3527 || (!rank_remap && ref->u.ar.end[dim]))
3529 gfc_error ("Either all or none of the upper bounds"
3530 " must be specified at %L", &lvalue->where);
3531 return false;
3538 is_pure = gfc_pure (NULL);
3539 is_implicit_pure = gfc_implicit_pure (NULL);
3541 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3542 kind, etc for lvalue and rvalue must match, and rvalue must be a
3543 pure variable if we're in a pure function. */
3544 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3545 return true;
3547 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3548 if (lvalue->expr_type == EXPR_VARIABLE
3549 && gfc_is_coindexed (lvalue))
3551 gfc_ref *ref;
3552 for (ref = lvalue->ref; ref; ref = ref->next)
3553 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3555 gfc_error ("Pointer object at %L shall not have a coindex",
3556 &lvalue->where);
3557 return false;
3561 /* Checks on rvalue for procedure pointer assignments. */
3562 if (proc_pointer)
3564 char err[200];
3565 gfc_symbol *s1,*s2;
3566 gfc_component *comp1, *comp2;
3567 const char *name;
3569 attr = gfc_expr_attr (rvalue);
3570 if (!((rvalue->expr_type == EXPR_NULL)
3571 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3572 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3573 || (rvalue->expr_type == EXPR_VARIABLE
3574 && attr.flavor == FL_PROCEDURE)))
3576 gfc_error ("Invalid procedure pointer assignment at %L",
3577 &rvalue->where);
3578 return false;
3580 if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
3582 /* Check for intrinsics. */
3583 gfc_symbol *sym = rvalue->symtree->n.sym;
3584 if (!sym->attr.intrinsic
3585 && (gfc_is_intrinsic (sym, 0, sym->declared_at)
3586 || gfc_is_intrinsic (sym, 1, sym->declared_at)))
3588 sym->attr.intrinsic = 1;
3589 gfc_resolve_intrinsic (sym, &rvalue->where);
3590 attr = gfc_expr_attr (rvalue);
3592 /* Check for result of embracing function. */
3593 if (sym->attr.function && sym->result == sym)
3595 gfc_namespace *ns;
3597 for (ns = gfc_current_ns; ns; ns = ns->parent)
3598 if (sym == ns->proc_name)
3600 gfc_error ("Function result %qs is invalid as proc-target "
3601 "in procedure pointer assignment at %L",
3602 sym->name, &rvalue->where);
3603 return false;
3607 if (attr.abstract)
3609 gfc_error ("Abstract interface %qs is invalid "
3610 "in procedure pointer assignment at %L",
3611 rvalue->symtree->name, &rvalue->where);
3612 return false;
3614 /* Check for F08:C729. */
3615 if (attr.flavor == FL_PROCEDURE)
3617 if (attr.proc == PROC_ST_FUNCTION)
3619 gfc_error ("Statement function %qs is invalid "
3620 "in procedure pointer assignment at %L",
3621 rvalue->symtree->name, &rvalue->where);
3622 return false;
3624 if (attr.proc == PROC_INTERNAL &&
3625 !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs "
3626 "is invalid in procedure pointer assignment "
3627 "at %L", rvalue->symtree->name, &rvalue->where))
3628 return false;
3629 if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
3630 attr.subroutine) == 0)
3632 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3633 "assignment", rvalue->symtree->name, &rvalue->where);
3634 return false;
3637 /* Check for F08:C730. */
3638 if (attr.elemental && !attr.intrinsic)
3640 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3641 "in procedure pointer assignment at %L",
3642 rvalue->symtree->name, &rvalue->where);
3643 return false;
3646 /* Ensure that the calling convention is the same. As other attributes
3647 such as DLLEXPORT may differ, one explicitly only tests for the
3648 calling conventions. */
3649 if (rvalue->expr_type == EXPR_VARIABLE
3650 && lvalue->symtree->n.sym->attr.ext_attr
3651 != rvalue->symtree->n.sym->attr.ext_attr)
3653 symbol_attribute calls;
3655 calls.ext_attr = 0;
3656 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3657 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3658 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3660 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3661 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3663 gfc_error ("Mismatch in the procedure pointer assignment "
3664 "at %L: mismatch in the calling convention",
3665 &rvalue->where);
3666 return false;
3670 comp1 = gfc_get_proc_ptr_comp (lvalue);
3671 if (comp1)
3672 s1 = comp1->ts.interface;
3673 else
3675 s1 = lvalue->symtree->n.sym;
3676 if (s1->ts.interface)
3677 s1 = s1->ts.interface;
3680 comp2 = gfc_get_proc_ptr_comp (rvalue);
3681 if (comp2)
3683 if (rvalue->expr_type == EXPR_FUNCTION)
3685 s2 = comp2->ts.interface->result;
3686 name = s2->name;
3688 else
3690 s2 = comp2->ts.interface;
3691 name = comp2->name;
3694 else if (rvalue->expr_type == EXPR_FUNCTION)
3696 if (rvalue->value.function.esym)
3697 s2 = rvalue->value.function.esym->result;
3698 else
3699 s2 = rvalue->symtree->n.sym->result;
3701 name = s2->name;
3703 else
3705 s2 = rvalue->symtree->n.sym;
3706 name = s2->name;
3709 if (s2 && s2->attr.proc_pointer && s2->ts.interface)
3710 s2 = s2->ts.interface;
3712 /* Special check for the case of absent interface on the lvalue.
3713 * All other interface checks are done below. */
3714 if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
3716 gfc_error ("Interface mismatch in procedure pointer assignment "
3717 "at %L: %qs is not a subroutine", &rvalue->where, name);
3718 return false;
3721 /* F08:7.2.2.4 (4) */
3722 if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err)))
3724 if (comp1 && !s1)
3726 gfc_error ("Explicit interface required for component %qs at %L: %s",
3727 comp1->name, &lvalue->where, err);
3728 return false;
3730 else if (s1->attr.if_source == IFSRC_UNKNOWN)
3732 gfc_error ("Explicit interface required for %qs at %L: %s",
3733 s1->name, &lvalue->where, err);
3734 return false;
3737 if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err)))
3739 if (comp2 && !s2)
3741 gfc_error ("Explicit interface required for component %qs at %L: %s",
3742 comp2->name, &rvalue->where, err);
3743 return false;
3745 else if (s2->attr.if_source == IFSRC_UNKNOWN)
3747 gfc_error ("Explicit interface required for %qs at %L: %s",
3748 s2->name, &rvalue->where, err);
3749 return false;
3753 if (s1 == s2 || !s1 || !s2)
3754 return true;
3756 if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
3757 err, sizeof(err), NULL, NULL))
3759 gfc_error ("Interface mismatch in procedure pointer assignment "
3760 "at %L: %s", &rvalue->where, err);
3761 return false;
3764 /* Check F2008Cor2, C729. */
3765 if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
3766 && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
3768 gfc_error ("Procedure pointer target %qs at %L must be either an "
3769 "intrinsic, host or use associated, referenced or have "
3770 "the EXTERNAL attribute", s2->name, &rvalue->where);
3771 return false;
3774 return true;
3777 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3779 /* Check for F03:C717. */
3780 if (UNLIMITED_POLY (rvalue)
3781 && !(UNLIMITED_POLY (lvalue)
3782 || (lvalue->ts.type == BT_DERIVED
3783 && (lvalue->ts.u.derived->attr.is_bind_c
3784 || lvalue->ts.u.derived->attr.sequence))))
3785 gfc_error ("Data-pointer-object at %L must be unlimited "
3786 "polymorphic, or of a type with the BIND or SEQUENCE "
3787 "attribute, to be compatible with an unlimited "
3788 "polymorphic target", &lvalue->where);
3789 else
3790 gfc_error ("Different types in pointer assignment at %L; "
3791 "attempted assignment of %s to %s", &lvalue->where,
3792 gfc_typename (&rvalue->ts),
3793 gfc_typename (&lvalue->ts));
3794 return false;
3797 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3799 gfc_error ("Different kind type parameters in pointer "
3800 "assignment at %L", &lvalue->where);
3801 return false;
3804 if (lvalue->rank != rvalue->rank && !rank_remap)
3806 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
3807 return false;
3810 /* Make sure the vtab is present. */
3811 if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
3812 gfc_find_vtab (&rvalue->ts);
3814 /* Check rank remapping. */
3815 if (rank_remap)
3817 mpz_t lsize, rsize;
3819 /* If this can be determined, check that the target must be at least as
3820 large as the pointer assigned to it is. */
3821 if (gfc_array_size (lvalue, &lsize)
3822 && gfc_array_size (rvalue, &rsize)
3823 && mpz_cmp (rsize, lsize) < 0)
3825 gfc_error ("Rank remapping target is smaller than size of the"
3826 " pointer (%ld < %ld) at %L",
3827 mpz_get_si (rsize), mpz_get_si (lsize),
3828 &lvalue->where);
3829 return false;
3832 /* The target must be either rank one or it must be simply contiguous
3833 and F2008 must be allowed. */
3834 if (rvalue->rank != 1)
3836 if (!gfc_is_simply_contiguous (rvalue, true, false))
3838 gfc_error ("Rank remapping target must be rank 1 or"
3839 " simply contiguous at %L", &rvalue->where);
3840 return false;
3842 if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not "
3843 "rank 1 at %L", &rvalue->where))
3844 return false;
3848 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3849 if (rvalue->expr_type == EXPR_NULL)
3850 return true;
3852 if (lvalue->ts.type == BT_CHARACTER)
3854 bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3855 if (!t)
3856 return false;
3859 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3860 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3862 attr = gfc_expr_attr (rvalue);
3864 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
3866 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
3867 to caf_get. Map this to the same error message as below when it is
3868 still a variable expression. */
3869 if (rvalue->value.function.isym
3870 && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET)
3871 /* The test above might need to be extend when F08, Note 5.4 has to be
3872 interpreted in the way that target and pointer with the same coindex
3873 are allowed. */
3874 gfc_error ("Data target at %L shall not have a coindex",
3875 &rvalue->where);
3876 else
3877 gfc_error ("Target expression in pointer assignment "
3878 "at %L must deliver a pointer result",
3879 &rvalue->where);
3880 return false;
3883 if (!attr.target && !attr.pointer)
3885 gfc_error ("Pointer assignment target is neither TARGET "
3886 "nor POINTER at %L", &rvalue->where);
3887 return false;
3890 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3892 gfc_error ("Bad target in pointer assignment in PURE "
3893 "procedure at %L", &rvalue->where);
3896 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3897 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3899 if (gfc_has_vector_index (rvalue))
3901 gfc_error ("Pointer assignment with vector subscript "
3902 "on rhs at %L", &rvalue->where);
3903 return false;
3906 if (attr.is_protected && attr.use_assoc
3907 && !(attr.pointer || attr.proc_pointer))
3909 gfc_error ("Pointer assignment target has PROTECTED "
3910 "attribute at %L", &rvalue->where);
3911 return false;
3914 /* F2008, C725. For PURE also C1283. */
3915 if (rvalue->expr_type == EXPR_VARIABLE
3916 && gfc_is_coindexed (rvalue))
3918 gfc_ref *ref;
3919 for (ref = rvalue->ref; ref; ref = ref->next)
3920 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3922 gfc_error ("Data target at %L shall not have a coindex",
3923 &rvalue->where);
3924 return false;
3928 /* Error for assignments of contiguous pointers to targets which is not
3929 contiguous. Be lenient in the definition of what counts as
3930 contiguous. */
3932 if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true))
3933 gfc_error ("Assignment to contiguous pointer from non-contiguous "
3934 "target at %L", &rvalue->where);
3936 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3937 if (warn_target_lifetime
3938 && rvalue->expr_type == EXPR_VARIABLE
3939 && !rvalue->symtree->n.sym->attr.save
3940 && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer
3941 && !rvalue->symtree->n.sym->attr.host_assoc
3942 && !rvalue->symtree->n.sym->attr.in_common
3943 && !rvalue->symtree->n.sym->attr.use_assoc
3944 && !rvalue->symtree->n.sym->attr.dummy)
3946 bool warn;
3947 gfc_namespace *ns;
3949 warn = lvalue->symtree->n.sym->attr.dummy
3950 || lvalue->symtree->n.sym->attr.result
3951 || lvalue->symtree->n.sym->attr.function
3952 || (lvalue->symtree->n.sym->attr.host_assoc
3953 && lvalue->symtree->n.sym->ns
3954 != rvalue->symtree->n.sym->ns)
3955 || lvalue->symtree->n.sym->attr.use_assoc
3956 || lvalue->symtree->n.sym->attr.in_common;
3958 if (rvalue->symtree->n.sym->ns->proc_name
3959 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE
3960 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM)
3961 for (ns = rvalue->symtree->n.sym->ns;
3962 ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
3963 ns = ns->parent)
3964 if (ns->parent == lvalue->symtree->n.sym->ns)
3966 warn = true;
3967 break;
3970 if (warn)
3971 gfc_warning (OPT_Wtarget_lifetime,
3972 "Pointer at %L in pointer assignment might outlive the "
3973 "pointer target", &lvalue->where);
3976 return true;
3980 /* Relative of gfc_check_assign() except that the lvalue is a single
3981 symbol. Used for initialization assignments. */
3983 bool
3984 gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
3986 gfc_expr lvalue;
3987 bool r;
3988 bool pointer, proc_pointer;
3990 memset (&lvalue, '\0', sizeof (gfc_expr));
3992 lvalue.expr_type = EXPR_VARIABLE;
3993 lvalue.ts = sym->ts;
3994 if (sym->as)
3995 lvalue.rank = sym->as->rank;
3996 lvalue.symtree = XCNEW (gfc_symtree);
3997 lvalue.symtree->n.sym = sym;
3998 lvalue.where = sym->declared_at;
4000 if (comp)
4002 lvalue.ref = gfc_get_ref ();
4003 lvalue.ref->type = REF_COMPONENT;
4004 lvalue.ref->u.c.component = comp;
4005 lvalue.ref->u.c.sym = sym;
4006 lvalue.ts = comp->ts;
4007 lvalue.rank = comp->as ? comp->as->rank : 0;
4008 lvalue.where = comp->loc;
4009 pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)
4010 ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
4011 proc_pointer = comp->attr.proc_pointer;
4013 else
4015 pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)
4016 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
4017 proc_pointer = sym->attr.proc_pointer;
4020 if (pointer || proc_pointer)
4021 r = gfc_check_pointer_assign (&lvalue, rvalue);
4022 else
4024 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4025 into an array constructor, we should check if it can be reduced
4026 as an initialization expression. */
4027 if (rvalue->expr_type == EXPR_FUNCTION
4028 && rvalue->value.function.isym
4029 && (rvalue->value.function.isym->conversion == 1))
4030 gfc_check_init_expr (rvalue);
4032 r = gfc_check_assign (&lvalue, rvalue, 1);
4035 free (lvalue.symtree);
4036 free (lvalue.ref);
4038 if (!r)
4039 return r;
4041 if (pointer && rvalue->expr_type != EXPR_NULL)
4043 /* F08:C461. Additional checks for pointer initialization. */
4044 symbol_attribute attr;
4045 attr = gfc_expr_attr (rvalue);
4046 if (attr.allocatable)
4048 gfc_error ("Pointer initialization target at %L "
4049 "must not be ALLOCATABLE", &rvalue->where);
4050 return false;
4052 if (!attr.target || attr.pointer)
4054 gfc_error ("Pointer initialization target at %L "
4055 "must have the TARGET attribute", &rvalue->where);
4056 return false;
4059 if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
4060 && rvalue->symtree->n.sym->ns->proc_name
4061 && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
4063 rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
4064 attr.save = SAVE_IMPLICIT;
4067 if (!attr.save)
4069 gfc_error ("Pointer initialization target at %L "
4070 "must have the SAVE attribute", &rvalue->where);
4071 return false;
4075 if (proc_pointer && rvalue->expr_type != EXPR_NULL)
4077 /* F08:C1220. Additional checks for procedure pointer initialization. */
4078 symbol_attribute attr = gfc_expr_attr (rvalue);
4079 if (attr.proc_pointer)
4081 gfc_error ("Procedure pointer initialization target at %L "
4082 "may not be a procedure pointer", &rvalue->where);
4083 return false;
4087 return true;
4090 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4091 * require that an expression be built. */
4093 gfc_expr *
4094 gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
4096 return gfc_build_init_expr (ts, where, false);
4099 /* Build an initializer for a local integer, real, complex, logical, or
4100 character variable, based on the command line flags finit-local-zero,
4101 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4102 With force, an initializer is ALWAYS generated. */
4104 gfc_expr *
4105 gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force)
4107 gfc_expr *init_expr;
4109 /* Try to build an initializer expression. */
4110 init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
4112 /* If we want to force generation, make sure we default to zero. */
4113 gfc_init_local_real init_real = flag_init_real;
4114 int init_logical = gfc_option.flag_init_logical;
4115 if (force)
4117 if (init_real == GFC_INIT_REAL_OFF)
4118 init_real = GFC_INIT_REAL_ZERO;
4119 if (init_logical == GFC_INIT_LOGICAL_OFF)
4120 init_logical = GFC_INIT_LOGICAL_FALSE;
4123 /* We will only initialize integers, reals, complex, logicals, and
4124 characters, and only if the corresponding command-line flags
4125 were set. Otherwise, we free init_expr and return null. */
4126 switch (ts->type)
4128 case BT_INTEGER:
4129 if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
4130 mpz_set_si (init_expr->value.integer,
4131 gfc_option.flag_init_integer_value);
4132 else
4134 gfc_free_expr (init_expr);
4135 init_expr = NULL;
4137 break;
4139 case BT_REAL:
4140 switch (init_real)
4142 case GFC_INIT_REAL_SNAN:
4143 init_expr->is_snan = 1;
4144 /* Fall through. */
4145 case GFC_INIT_REAL_NAN:
4146 mpfr_set_nan (init_expr->value.real);
4147 break;
4149 case GFC_INIT_REAL_INF:
4150 mpfr_set_inf (init_expr->value.real, 1);
4151 break;
4153 case GFC_INIT_REAL_NEG_INF:
4154 mpfr_set_inf (init_expr->value.real, -1);
4155 break;
4157 case GFC_INIT_REAL_ZERO:
4158 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
4159 break;
4161 default:
4162 gfc_free_expr (init_expr);
4163 init_expr = NULL;
4164 break;
4166 break;
4168 case BT_COMPLEX:
4169 switch (init_real)
4171 case GFC_INIT_REAL_SNAN:
4172 init_expr->is_snan = 1;
4173 /* Fall through. */
4174 case GFC_INIT_REAL_NAN:
4175 mpfr_set_nan (mpc_realref (init_expr->value.complex));
4176 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
4177 break;
4179 case GFC_INIT_REAL_INF:
4180 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
4181 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
4182 break;
4184 case GFC_INIT_REAL_NEG_INF:
4185 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
4186 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
4187 break;
4189 case GFC_INIT_REAL_ZERO:
4190 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
4191 break;
4193 default:
4194 gfc_free_expr (init_expr);
4195 init_expr = NULL;
4196 break;
4198 break;
4200 case BT_LOGICAL:
4201 if (init_logical == GFC_INIT_LOGICAL_FALSE)
4202 init_expr->value.logical = 0;
4203 else if (init_logical == GFC_INIT_LOGICAL_TRUE)
4204 init_expr->value.logical = 1;
4205 else
4207 gfc_free_expr (init_expr);
4208 init_expr = NULL;
4210 break;
4212 case BT_CHARACTER:
4213 /* For characters, the length must be constant in order to
4214 create a default initializer. */
4215 if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
4216 && ts->u.cl->length
4217 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
4219 HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
4220 init_expr->value.character.length = char_len;
4221 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
4222 for (size_t i = 0; i < (size_t) char_len; i++)
4223 init_expr->value.character.string[i]
4224 = (unsigned char) gfc_option.flag_init_character_value;
4226 else
4228 gfc_free_expr (init_expr);
4229 init_expr = NULL;
4231 if (!init_expr
4232 && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
4233 && ts->u.cl->length && flag_max_stack_var_size != 0)
4235 gfc_actual_arglist *arg;
4236 init_expr = gfc_get_expr ();
4237 init_expr->where = *where;
4238 init_expr->ts = *ts;
4239 init_expr->expr_type = EXPR_FUNCTION;
4240 init_expr->value.function.isym =
4241 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
4242 init_expr->value.function.name = "repeat";
4243 arg = gfc_get_actual_arglist ();
4244 arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1);
4245 arg->expr->value.character.string[0] =
4246 gfc_option.flag_init_character_value;
4247 arg->next = gfc_get_actual_arglist ();
4248 arg->next->expr = gfc_copy_expr (ts->u.cl->length);
4249 init_expr->value.function.actual = arg;
4251 break;
4253 default:
4254 gfc_free_expr (init_expr);
4255 init_expr = NULL;
4258 return init_expr;
4261 /* Apply an initialization expression to a typespec. Can be used for symbols or
4262 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4263 combined with some effort. */
4265 void
4266 gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
4268 if (ts->type == BT_CHARACTER && !attr->pointer && init
4269 && ts->u.cl
4270 && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT)
4272 gcc_assert (ts->u.cl && ts->u.cl->length);
4273 gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT);
4274 gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER);
4276 HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
4278 if (init->expr_type == EXPR_CONSTANT)
4279 gfc_set_constant_character_len (len, init, -1);
4280 else if (init
4281 && init->ts.type == BT_CHARACTER
4282 && init->ts.u.cl && init->ts.u.cl->length
4283 && mpz_cmp (ts->u.cl->length->value.integer,
4284 init->ts.u.cl->length->value.integer))
4286 gfc_constructor *ctor;
4287 ctor = gfc_constructor_first (init->value.constructor);
4289 if (ctor)
4291 bool has_ts = (init->ts.u.cl
4292 && init->ts.u.cl->length_from_typespec);
4294 /* Remember the length of the first element for checking
4295 that all elements *in the constructor* have the same
4296 length. This need not be the length of the LHS! */
4297 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
4298 gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
4299 gfc_charlen_t first_len = ctor->expr->value.character.length;
4301 for ( ; ctor; ctor = gfc_constructor_next (ctor))
4302 if (ctor->expr->expr_type == EXPR_CONSTANT)
4304 gfc_set_constant_character_len (len, ctor->expr,
4305 has_ts ? -1 : first_len);
4306 if (!ctor->expr->ts.u.cl)
4307 ctor->expr->ts.u.cl
4308 = gfc_new_charlen (gfc_current_ns, ts->u.cl);
4309 else
4310 ctor->expr->ts.u.cl->length
4311 = gfc_copy_expr (ts->u.cl->length);
4319 /* Check whether an expression is a structure constructor and whether it has
4320 other values than NULL. */
4322 bool
4323 is_non_empty_structure_constructor (gfc_expr * e)
4325 if (e->expr_type != EXPR_STRUCTURE)
4326 return false;
4328 gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
4329 while (cons)
4331 if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
4332 return true;
4333 cons = gfc_constructor_next (cons);
4335 return false;
4339 /* Check for default initializer; sym->value is not enough
4340 as it is also set for EXPR_NULL of allocatables. */
4342 bool
4343 gfc_has_default_initializer (gfc_symbol *der)
4345 gfc_component *c;
4347 gcc_assert (gfc_fl_struct (der->attr.flavor));
4348 for (c = der->components; c; c = c->next)
4349 if (gfc_bt_struct (c->ts.type))
4351 if (!c->attr.pointer && !c->attr.proc_pointer
4352 && !(c->attr.allocatable && der == c->ts.u.derived)
4353 && ((c->initializer
4354 && is_non_empty_structure_constructor (c->initializer))
4355 || gfc_has_default_initializer (c->ts.u.derived)))
4356 return true;
4357 if (c->attr.pointer && c->initializer)
4358 return true;
4360 else
4362 if (c->initializer)
4363 return true;
4366 return false;
4371 Generate an initializer expression which initializes the entirety of a union.
4372 A normal structure constructor is insufficient without undue effort, because
4373 components of maps may be oddly aligned/overlapped. (For example if a
4374 character is initialized from one map overtop a real from the other, only one
4375 byte of the real is actually initialized.) Unfortunately we don't know the
4376 size of the union right now, so we can't generate a proper initializer, but
4377 we use a NULL expr as a placeholder and do the right thing later in
4378 gfc_trans_subcomponent_assign.
4380 static gfc_expr *
4381 generate_union_initializer (gfc_component *un)
4383 if (un == NULL || un->ts.type != BT_UNION)
4384 return NULL;
4386 gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
4387 placeholder->ts = un->ts;
4388 return placeholder;
4392 /* Get the user-specified initializer for a union, if any. This means the user
4393 has said to initialize component(s) of a map. For simplicity's sake we
4394 only allow the user to initialize the first map. We don't have to worry
4395 about overlapping initializers as they are released early in resolution (see
4396 resolve_fl_struct). */
4398 static gfc_expr *
4399 get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
4401 gfc_component *map;
4402 gfc_expr *init=NULL;
4404 if (!union_type || union_type->attr.flavor != FL_UNION)
4405 return NULL;
4407 for (map = union_type->components; map; map = map->next)
4409 if (gfc_has_default_initializer (map->ts.u.derived))
4411 init = gfc_default_initializer (&map->ts);
4412 if (map_p)
4413 *map_p = map;
4414 break;
4418 if (map_p && !init)
4419 *map_p = NULL;
4421 return init;
4424 /* Fetch or generate an initializer for the given component.
4425 Only generate an initializer if generate is true. */
4427 static gfc_expr *
4428 component_initializer (gfc_typespec *ts, gfc_component *c, bool generate)
4430 gfc_expr *init = NULL;
4432 /* See if we can find the initializer immediately.
4433 Some components should never get initializers. */
4434 if (c->initializer || !generate
4435 || (ts->type == BT_CLASS && !c->attr.allocatable)
4436 || c->attr.pointer
4437 || c->attr.class_pointer
4438 || c->attr.proc_pointer)
4439 return c->initializer;
4441 /* Recursively handle derived type components. */
4442 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
4443 init = gfc_generate_initializer (&c->ts, true);
4445 else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
4447 gfc_component *map = NULL;
4448 gfc_constructor *ctor;
4449 gfc_expr *user_init;
4451 /* If we don't have a user initializer and we aren't generating one, this
4452 union has no initializer. */
4453 user_init = get_union_initializer (c->ts.u.derived, &map);
4454 if (!user_init && !generate)
4455 return NULL;
4457 /* Otherwise use a structure constructor. */
4458 init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
4459 &c->loc);
4460 init->ts = c->ts;
4462 /* If we are to generate an initializer for the union, add a constructor
4463 which initializes the whole union first. */
4464 if (generate)
4466 ctor = gfc_constructor_get ();
4467 ctor->expr = generate_union_initializer (c);
4468 gfc_constructor_append (&init->value.constructor, ctor);
4471 /* If we found an initializer in one of our maps, apply it. Note this
4472 is applied _after_ the entire-union initializer above if any. */
4473 if (user_init)
4475 ctor = gfc_constructor_get ();
4476 ctor->expr = user_init;
4477 ctor->n.component = map;
4478 gfc_constructor_append (&init->value.constructor, ctor);
4482 /* Treat simple components like locals. */
4483 else
4485 /* We MUST give an initializer, so force generation. */
4486 init = gfc_build_init_expr (&c->ts, &c->loc, true);
4487 gfc_apply_init (&c->ts, &c->attr, init);
4490 return init;
4494 /* Get an expression for a default initializer of a derived type. */
4496 gfc_expr *
4497 gfc_default_initializer (gfc_typespec *ts)
4499 return gfc_generate_initializer (ts, false);
4503 /* Get or generate an expression for a default initializer of a derived type.
4504 If -finit-derived is specified, generate default initialization expressions
4505 for components that lack them when generate is set. */
4507 gfc_expr *
4508 gfc_generate_initializer (gfc_typespec *ts, bool generate)
4510 gfc_expr *init, *tmp;
4511 gfc_component *comp;
4512 generate = flag_init_derived && generate;
4514 /* See if we have a default initializer in this, but not in nested
4515 types (otherwise we could use gfc_has_default_initializer()).
4516 We don't need to check if we are going to generate them. */
4517 comp = ts->u.derived->components;
4518 if (!generate)
4520 for (; comp; comp = comp->next)
4521 if (comp->initializer || comp->attr.allocatable
4522 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
4523 && CLASS_DATA (comp)->attr.allocatable))
4524 break;
4527 if (!comp)
4528 return NULL;
4530 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
4531 &ts->u.derived->declared_at);
4532 init->ts = *ts;
4534 for (comp = ts->u.derived->components; comp; comp = comp->next)
4536 gfc_constructor *ctor = gfc_constructor_get();
4538 /* Fetch or generate an initializer for the component. */
4539 tmp = component_initializer (ts, comp, generate);
4540 if (tmp)
4542 /* Save the component ref for STRUCTUREs and UNIONs. */
4543 if (ts->u.derived->attr.flavor == FL_STRUCT
4544 || ts->u.derived->attr.flavor == FL_UNION)
4545 ctor->n.component = comp;
4547 /* If the initializer was not generated, we need a copy. */
4548 ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
4549 if ((comp->ts.type != tmp->ts.type
4550 || comp->ts.kind != tmp->ts.kind)
4551 && !comp->attr.pointer && !comp->attr.proc_pointer)
4553 bool val;
4554 val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false);
4555 if (val == false)
4556 return NULL;
4560 if (comp->attr.allocatable
4561 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
4563 ctor->expr = gfc_get_expr ();
4564 ctor->expr->expr_type = EXPR_NULL;
4565 ctor->expr->where = init->where;
4566 ctor->expr->ts = comp->ts;
4569 gfc_constructor_append (&init->value.constructor, ctor);
4572 return init;
4576 /* Given a symbol, create an expression node with that symbol as a
4577 variable. If the symbol is array valued, setup a reference of the
4578 whole array. */
4580 gfc_expr *
4581 gfc_get_variable_expr (gfc_symtree *var)
4583 gfc_expr *e;
4585 e = gfc_get_expr ();
4586 e->expr_type = EXPR_VARIABLE;
4587 e->symtree = var;
4588 e->ts = var->n.sym->ts;
4590 if (var->n.sym->attr.flavor != FL_PROCEDURE
4591 && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
4592 || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
4593 && CLASS_DATA (var->n.sym)->as)))
4595 e->rank = var->n.sym->ts.type == BT_CLASS
4596 ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
4597 e->ref = gfc_get_ref ();
4598 e->ref->type = REF_ARRAY;
4599 e->ref->u.ar.type = AR_FULL;
4600 e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
4601 ? CLASS_DATA (var->n.sym)->as
4602 : var->n.sym->as);
4605 return e;
4609 /* Adds a full array reference to an expression, as needed. */
4611 void
4612 gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
4614 gfc_ref *ref;
4615 for (ref = e->ref; ref; ref = ref->next)
4616 if (!ref->next)
4617 break;
4618 if (ref)
4620 ref->next = gfc_get_ref ();
4621 ref = ref->next;
4623 else
4625 e->ref = gfc_get_ref ();
4626 ref = e->ref;
4628 ref->type = REF_ARRAY;
4629 ref->u.ar.type = AR_FULL;
4630 ref->u.ar.dimen = e->rank;
4631 ref->u.ar.where = e->where;
4632 ref->u.ar.as = as;
4636 gfc_expr *
4637 gfc_lval_expr_from_sym (gfc_symbol *sym)
4639 gfc_expr *lval;
4640 gfc_array_spec *as;
4641 lval = gfc_get_expr ();
4642 lval->expr_type = EXPR_VARIABLE;
4643 lval->where = sym->declared_at;
4644 lval->ts = sym->ts;
4645 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
4647 /* It will always be a full array. */
4648 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
4649 lval->rank = as ? as->rank : 0;
4650 if (lval->rank)
4651 gfc_add_full_array_ref (lval, as);
4652 return lval;
4656 /* Returns the array_spec of a full array expression. A NULL is
4657 returned otherwise. */
4658 gfc_array_spec *
4659 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
4661 gfc_array_spec *as;
4662 gfc_ref *ref;
4664 if (expr->rank == 0)
4665 return NULL;
4667 /* Follow any component references. */
4668 if (expr->expr_type == EXPR_VARIABLE
4669 || expr->expr_type == EXPR_CONSTANT)
4671 if (expr->symtree)
4672 as = expr->symtree->n.sym->as;
4673 else
4674 as = NULL;
4676 for (ref = expr->ref; ref; ref = ref->next)
4678 switch (ref->type)
4680 case REF_COMPONENT:
4681 as = ref->u.c.component->as;
4682 continue;
4684 case REF_SUBSTRING:
4685 continue;
4687 case REF_ARRAY:
4689 switch (ref->u.ar.type)
4691 case AR_ELEMENT:
4692 case AR_SECTION:
4693 case AR_UNKNOWN:
4694 as = NULL;
4695 continue;
4697 case AR_FULL:
4698 break;
4700 break;
4705 else
4706 as = NULL;
4708 return as;
4712 /* General expression traversal function. */
4714 bool
4715 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
4716 bool (*func)(gfc_expr *, gfc_symbol *, int*),
4717 int f)
4719 gfc_array_ref ar;
4720 gfc_ref *ref;
4721 gfc_actual_arglist *args;
4722 gfc_constructor *c;
4723 int i;
4725 if (!expr)
4726 return false;
4728 if ((*func) (expr, sym, &f))
4729 return true;
4731 if (expr->ts.type == BT_CHARACTER
4732 && expr->ts.u.cl
4733 && expr->ts.u.cl->length
4734 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
4735 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
4736 return true;
4738 switch (expr->expr_type)
4740 case EXPR_PPC:
4741 case EXPR_COMPCALL:
4742 case EXPR_FUNCTION:
4743 for (args = expr->value.function.actual; args; args = args->next)
4745 if (gfc_traverse_expr (args->expr, sym, func, f))
4746 return true;
4748 break;
4750 case EXPR_VARIABLE:
4751 case EXPR_CONSTANT:
4752 case EXPR_NULL:
4753 case EXPR_SUBSTRING:
4754 break;
4756 case EXPR_STRUCTURE:
4757 case EXPR_ARRAY:
4758 for (c = gfc_constructor_first (expr->value.constructor);
4759 c; c = gfc_constructor_next (c))
4761 if (gfc_traverse_expr (c->expr, sym, func, f))
4762 return true;
4763 if (c->iterator)
4765 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
4766 return true;
4767 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
4768 return true;
4769 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
4770 return true;
4771 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
4772 return true;
4775 break;
4777 case EXPR_OP:
4778 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
4779 return true;
4780 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
4781 return true;
4782 break;
4784 default:
4785 gcc_unreachable ();
4786 break;
4789 ref = expr->ref;
4790 while (ref != NULL)
4792 switch (ref->type)
4794 case REF_ARRAY:
4795 ar = ref->u.ar;
4796 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4798 if (gfc_traverse_expr (ar.start[i], sym, func, f))
4799 return true;
4800 if (gfc_traverse_expr (ar.end[i], sym, func, f))
4801 return true;
4802 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
4803 return true;
4805 break;
4807 case REF_SUBSTRING:
4808 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
4809 return true;
4810 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
4811 return true;
4812 break;
4814 case REF_COMPONENT:
4815 if (ref->u.c.component->ts.type == BT_CHARACTER
4816 && ref->u.c.component->ts.u.cl
4817 && ref->u.c.component->ts.u.cl->length
4818 && ref->u.c.component->ts.u.cl->length->expr_type
4819 != EXPR_CONSTANT
4820 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
4821 sym, func, f))
4822 return true;
4824 if (ref->u.c.component->as)
4825 for (i = 0; i < ref->u.c.component->as->rank
4826 + ref->u.c.component->as->corank; i++)
4828 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
4829 sym, func, f))
4830 return true;
4831 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
4832 sym, func, f))
4833 return true;
4835 break;
4837 default:
4838 gcc_unreachable ();
4840 ref = ref->next;
4842 return false;
4845 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4847 static bool
4848 expr_set_symbols_referenced (gfc_expr *expr,
4849 gfc_symbol *sym ATTRIBUTE_UNUSED,
4850 int *f ATTRIBUTE_UNUSED)
4852 if (expr->expr_type != EXPR_VARIABLE)
4853 return false;
4854 gfc_set_sym_referenced (expr->symtree->n.sym);
4855 return false;
4858 void
4859 gfc_expr_set_symbols_referenced (gfc_expr *expr)
4861 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
4865 /* Determine if an expression is a procedure pointer component and return
4866 the component in that case. Otherwise return NULL. */
4868 gfc_component *
4869 gfc_get_proc_ptr_comp (gfc_expr *expr)
4871 gfc_ref *ref;
4873 if (!expr || !expr->ref)
4874 return NULL;
4876 ref = expr->ref;
4877 while (ref->next)
4878 ref = ref->next;
4880 if (ref->type == REF_COMPONENT
4881 && ref->u.c.component->attr.proc_pointer)
4882 return ref->u.c.component;
4884 return NULL;
4888 /* Determine if an expression is a procedure pointer component. */
4890 bool
4891 gfc_is_proc_ptr_comp (gfc_expr *expr)
4893 return (gfc_get_proc_ptr_comp (expr) != NULL);
4897 /* Determine if an expression is a function with an allocatable class scalar
4898 result. */
4899 bool
4900 gfc_is_alloc_class_scalar_function (gfc_expr *expr)
4902 if (expr->expr_type == EXPR_FUNCTION
4903 && expr->value.function.esym
4904 && expr->value.function.esym->result
4905 && expr->value.function.esym->result->ts.type == BT_CLASS
4906 && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
4907 && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
4908 return true;
4910 return false;
4914 /* Determine if an expression is a function with an allocatable class array
4915 result. */
4916 bool
4917 gfc_is_class_array_function (gfc_expr *expr)
4919 if (expr->expr_type == EXPR_FUNCTION
4920 && expr->value.function.esym
4921 && expr->value.function.esym->result
4922 && expr->value.function.esym->result->ts.type == BT_CLASS
4923 && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
4924 && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable
4925 || CLASS_DATA (expr->value.function.esym->result)->attr.pointer))
4926 return true;
4928 return false;
4932 /* Walk an expression tree and check each variable encountered for being typed.
4933 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4934 mode as is a basic arithmetic expression using those; this is for things in
4935 legacy-code like:
4937 INTEGER :: arr(n), n
4938 INTEGER :: arr(n + 1), n
4940 The namespace is needed for IMPLICIT typing. */
4942 static gfc_namespace* check_typed_ns;
4944 static bool
4945 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4946 int* f ATTRIBUTE_UNUSED)
4948 bool t;
4950 if (e->expr_type != EXPR_VARIABLE)
4951 return false;
4953 gcc_assert (e->symtree);
4954 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
4955 true, e->where);
4957 return (!t);
4960 bool
4961 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
4963 bool error_found;
4965 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4966 to us. */
4967 if (!strict)
4969 if (e->expr_type == EXPR_VARIABLE && !e->ref)
4970 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
4972 if (e->expr_type == EXPR_OP)
4974 bool t = true;
4976 gcc_assert (e->value.op.op1);
4977 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
4979 if (t && e->value.op.op2)
4980 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
4982 return t;
4986 /* Otherwise, walk the expression and do it strictly. */
4987 check_typed_ns = ns;
4988 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
4990 return error_found ? false : true;
4994 /* This function returns true if it contains any references to PDT KIND
4995 or LEN parameters. */
4997 static bool
4998 derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4999 int* f ATTRIBUTE_UNUSED)
5001 if (e->expr_type != EXPR_VARIABLE)
5002 return false;
5004 gcc_assert (e->symtree);
5005 if (e->symtree->n.sym->attr.pdt_kind
5006 || e->symtree->n.sym->attr.pdt_len)
5007 return true;
5009 return false;
5013 bool
5014 gfc_derived_parameter_expr (gfc_expr *e)
5016 return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0);
5020 /* This function returns the overall type of a type parameter spec list.
5021 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5022 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5023 unless derived is not NULL. In this latter case, all the LEN parameters
5024 must be either assumed or deferred for the return argument to be set to
5025 anything other than SPEC_EXPLICIT. */
5027 gfc_param_spec_type
5028 gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
5030 gfc_param_spec_type res = SPEC_EXPLICIT;
5031 gfc_component *c;
5032 bool seen_assumed = false;
5033 bool seen_deferred = false;
5035 if (derived == NULL)
5037 for (; param_list; param_list = param_list->next)
5038 if (param_list->spec_type == SPEC_ASSUMED
5039 || param_list->spec_type == SPEC_DEFERRED)
5040 return param_list->spec_type;
5042 else
5044 for (; param_list; param_list = param_list->next)
5046 c = gfc_find_component (derived, param_list->name,
5047 true, true, NULL);
5048 gcc_assert (c != NULL);
5049 if (c->attr.pdt_kind)
5050 continue;
5051 else if (param_list->spec_type == SPEC_EXPLICIT)
5052 return SPEC_EXPLICIT;
5053 seen_assumed = param_list->spec_type == SPEC_ASSUMED;
5054 seen_deferred = param_list->spec_type == SPEC_DEFERRED;
5055 if (seen_assumed && seen_deferred)
5056 return SPEC_EXPLICIT;
5058 res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
5060 return res;
5064 bool
5065 gfc_ref_this_image (gfc_ref *ref)
5067 int n;
5069 gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
5071 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5072 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
5073 return false;
5075 return true;
5078 gfc_expr *
5079 gfc_find_team_co (gfc_expr *e)
5081 gfc_ref *ref;
5083 for (ref = e->ref; ref; ref = ref->next)
5084 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5085 return ref->u.ar.team;
5087 if (e->value.function.actual->expr)
5088 for (ref = e->value.function.actual->expr->ref; ref;
5089 ref = ref->next)
5090 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5091 return ref->u.ar.team;
5093 return NULL;
5096 gfc_expr *
5097 gfc_find_stat_co (gfc_expr *e)
5099 gfc_ref *ref;
5101 for (ref = e->ref; ref; ref = ref->next)
5102 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5103 return ref->u.ar.stat;
5105 if (e->value.function.actual->expr)
5106 for (ref = e->value.function.actual->expr->ref; ref;
5107 ref = ref->next)
5108 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5109 return ref->u.ar.stat;
5111 return NULL;
5114 bool
5115 gfc_is_coindexed (gfc_expr *e)
5117 gfc_ref *ref;
5119 for (ref = e->ref; ref; ref = ref->next)
5120 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5121 return !gfc_ref_this_image (ref);
5123 return false;
5127 /* Coarrays are variables with a corank but not being coindexed. However, also
5128 the following is a coarray: A subobject of a coarray is a coarray if it does
5129 not have any cosubscripts, vector subscripts, allocatable component
5130 selection, or pointer component selection. (F2008, 2.4.7) */
5132 bool
5133 gfc_is_coarray (gfc_expr *e)
5135 gfc_ref *ref;
5136 gfc_symbol *sym;
5137 gfc_component *comp;
5138 bool coindexed;
5139 bool coarray;
5140 int i;
5142 if (e->expr_type != EXPR_VARIABLE)
5143 return false;
5145 coindexed = false;
5146 sym = e->symtree->n.sym;
5148 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
5149 coarray = CLASS_DATA (sym)->attr.codimension;
5150 else
5151 coarray = sym->attr.codimension;
5153 for (ref = e->ref; ref; ref = ref->next)
5154 switch (ref->type)
5156 case REF_COMPONENT:
5157 comp = ref->u.c.component;
5158 if (comp->ts.type == BT_CLASS && comp->attr.class_ok
5159 && (CLASS_DATA (comp)->attr.class_pointer
5160 || CLASS_DATA (comp)->attr.allocatable))
5162 coindexed = false;
5163 coarray = CLASS_DATA (comp)->attr.codimension;
5165 else if (comp->attr.pointer || comp->attr.allocatable)
5167 coindexed = false;
5168 coarray = comp->attr.codimension;
5170 break;
5172 case REF_ARRAY:
5173 if (!coarray)
5174 break;
5176 if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
5178 coindexed = true;
5179 break;
5182 for (i = 0; i < ref->u.ar.dimen; i++)
5183 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5185 coarray = false;
5186 break;
5188 break;
5190 case REF_SUBSTRING:
5191 break;
5194 return coarray && !coindexed;
5199 gfc_get_corank (gfc_expr *e)
5201 int corank;
5202 gfc_ref *ref;
5204 if (!gfc_is_coarray (e))
5205 return 0;
5207 if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
5208 corank = e->ts.u.derived->components->as
5209 ? e->ts.u.derived->components->as->corank : 0;
5210 else
5211 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
5213 for (ref = e->ref; ref; ref = ref->next)
5215 if (ref->type == REF_ARRAY)
5216 corank = ref->u.ar.as->corank;
5217 gcc_assert (ref->type != REF_SUBSTRING);
5220 return corank;
5224 /* Check whether the expression has an ultimate allocatable component.
5225 Being itself allocatable does not count. */
5226 bool
5227 gfc_has_ultimate_allocatable (gfc_expr *e)
5229 gfc_ref *ref, *last = NULL;
5231 if (e->expr_type != EXPR_VARIABLE)
5232 return false;
5234 for (ref = e->ref; ref; ref = ref->next)
5235 if (ref->type == REF_COMPONENT)
5236 last = ref;
5238 if (last && last->u.c.component->ts.type == BT_CLASS)
5239 return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
5240 else if (last && last->u.c.component->ts.type == BT_DERIVED)
5241 return last->u.c.component->ts.u.derived->attr.alloc_comp;
5242 else if (last)
5243 return false;
5245 if (e->ts.type == BT_CLASS)
5246 return CLASS_DATA (e)->attr.alloc_comp;
5247 else if (e->ts.type == BT_DERIVED)
5248 return e->ts.u.derived->attr.alloc_comp;
5249 else
5250 return false;
5254 /* Check whether the expression has an pointer component.
5255 Being itself a pointer does not count. */
5256 bool
5257 gfc_has_ultimate_pointer (gfc_expr *e)
5259 gfc_ref *ref, *last = NULL;
5261 if (e->expr_type != EXPR_VARIABLE)
5262 return false;
5264 for (ref = e->ref; ref; ref = ref->next)
5265 if (ref->type == REF_COMPONENT)
5266 last = ref;
5268 if (last && last->u.c.component->ts.type == BT_CLASS)
5269 return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
5270 else if (last && last->u.c.component->ts.type == BT_DERIVED)
5271 return last->u.c.component->ts.u.derived->attr.pointer_comp;
5272 else if (last)
5273 return false;
5275 if (e->ts.type == BT_CLASS)
5276 return CLASS_DATA (e)->attr.pointer_comp;
5277 else if (e->ts.type == BT_DERIVED)
5278 return e->ts.u.derived->attr.pointer_comp;
5279 else
5280 return false;
5284 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5285 Note: A scalar is not regarded as "simply contiguous" by the standard.
5286 if bool is not strict, some further checks are done - for instance,
5287 a "(::1)" is accepted. */
5289 bool
5290 gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
5292 bool colon;
5293 int i;
5294 gfc_array_ref *ar = NULL;
5295 gfc_ref *ref, *part_ref = NULL;
5296 gfc_symbol *sym;
5298 if (expr->expr_type == EXPR_FUNCTION)
5300 if (expr->value.function.esym)
5301 return expr->value.function.esym->result->attr.contiguous;
5302 else
5304 /* We have to jump through some hoops if this is a vtab entry. */
5305 gfc_symbol *s;
5306 gfc_ref *r, *rc;
5308 s = expr->symtree->n.sym;
5309 if (s->ts.type != BT_CLASS)
5310 return false;
5312 rc = NULL;
5313 for (r = expr->ref; r; r = r->next)
5314 if (r->type == REF_COMPONENT)
5315 rc = r;
5317 if (rc == NULL || rc->u.c.component == NULL
5318 || rc->u.c.component->ts.interface == NULL)
5319 return false;
5321 return rc->u.c.component->ts.interface->attr.contiguous;
5324 else if (expr->expr_type != EXPR_VARIABLE)
5325 return false;
5327 if (!permit_element && expr->rank == 0)
5328 return false;
5330 for (ref = expr->ref; ref; ref = ref->next)
5332 if (ar)
5333 return false; /* Array shall be last part-ref. */
5335 if (ref->type == REF_COMPONENT)
5336 part_ref = ref;
5337 else if (ref->type == REF_SUBSTRING)
5338 return false;
5339 else if (ref->u.ar.type != AR_ELEMENT)
5340 ar = &ref->u.ar;
5343 sym = expr->symtree->n.sym;
5344 if (expr->ts.type != BT_CLASS
5345 && ((part_ref
5346 && !part_ref->u.c.component->attr.contiguous
5347 && part_ref->u.c.component->attr.pointer)
5348 || (!part_ref
5349 && !sym->attr.contiguous
5350 && (sym->attr.pointer
5351 || (sym->as && sym->as->type == AS_ASSUMED_RANK)
5352 || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))))
5353 return false;
5355 if (!ar || ar->type == AR_FULL)
5356 return true;
5358 gcc_assert (ar->type == AR_SECTION);
5360 /* Check for simply contiguous array */
5361 colon = true;
5362 for (i = 0; i < ar->dimen; i++)
5364 if (ar->dimen_type[i] == DIMEN_VECTOR)
5365 return false;
5367 if (ar->dimen_type[i] == DIMEN_ELEMENT)
5369 colon = false;
5370 continue;
5373 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
5376 /* If the previous section was not contiguous, that's an error,
5377 unless we have effective only one element and checking is not
5378 strict. */
5379 if (!colon && (strict || !ar->start[i] || !ar->end[i]
5380 || ar->start[i]->expr_type != EXPR_CONSTANT
5381 || ar->end[i]->expr_type != EXPR_CONSTANT
5382 || mpz_cmp (ar->start[i]->value.integer,
5383 ar->end[i]->value.integer) != 0))
5384 return false;
5386 /* Following the standard, "(::1)" or - if known at compile time -
5387 "(lbound:ubound)" are not simply contiguous; if strict
5388 is false, they are regarded as simply contiguous. */
5389 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
5390 || ar->stride[i]->ts.type != BT_INTEGER
5391 || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
5392 return false;
5394 if (ar->start[i]
5395 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
5396 || !ar->as->lower[i]
5397 || ar->as->lower[i]->expr_type != EXPR_CONSTANT
5398 || mpz_cmp (ar->start[i]->value.integer,
5399 ar->as->lower[i]->value.integer) != 0))
5400 colon = false;
5402 if (ar->end[i]
5403 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
5404 || !ar->as->upper[i]
5405 || ar->as->upper[i]->expr_type != EXPR_CONSTANT
5406 || mpz_cmp (ar->end[i]->value.integer,
5407 ar->as->upper[i]->value.integer) != 0))
5408 colon = false;
5411 return true;
5415 /* Build call to an intrinsic procedure. The number of arguments has to be
5416 passed (rather than ending the list with a NULL value) because we may
5417 want to add arguments but with a NULL-expression. */
5419 gfc_expr*
5420 gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
5421 locus where, unsigned numarg, ...)
5423 gfc_expr* result;
5424 gfc_actual_arglist* atail;
5425 gfc_intrinsic_sym* isym;
5426 va_list ap;
5427 unsigned i;
5428 const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
5430 isym = gfc_intrinsic_function_by_id (id);
5431 gcc_assert (isym);
5433 result = gfc_get_expr ();
5434 result->expr_type = EXPR_FUNCTION;
5435 result->ts = isym->ts;
5436 result->where = where;
5437 result->value.function.name = mangled_name;
5438 result->value.function.isym = isym;
5440 gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
5441 gfc_commit_symbol (result->symtree->n.sym);
5442 gcc_assert (result->symtree
5443 && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
5444 || result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
5445 result->symtree->n.sym->intmod_sym_id = id;
5446 result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5447 result->symtree->n.sym->attr.intrinsic = 1;
5448 result->symtree->n.sym->attr.artificial = 1;
5450 va_start (ap, numarg);
5451 atail = NULL;
5452 for (i = 0; i < numarg; ++i)
5454 if (atail)
5456 atail->next = gfc_get_actual_arglist ();
5457 atail = atail->next;
5459 else
5460 atail = result->value.function.actual = gfc_get_actual_arglist ();
5462 atail->expr = va_arg (ap, gfc_expr*);
5464 va_end (ap);
5466 return result;
5470 /* Check if an expression may appear in a variable definition context
5471 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5472 This is called from the various places when resolving
5473 the pieces that make up such a context.
5474 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5475 variables), some checks are not performed.
5477 Optionally, a possible error message can be suppressed if context is NULL
5478 and just the return status (true / false) be requested. */
5480 bool
5481 gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
5482 bool own_scope, const char* context)
5484 gfc_symbol* sym = NULL;
5485 bool is_pointer;
5486 bool check_intentin;
5487 bool ptr_component;
5488 symbol_attribute attr;
5489 gfc_ref* ref;
5490 int i;
5492 if (e->expr_type == EXPR_VARIABLE)
5494 gcc_assert (e->symtree);
5495 sym = e->symtree->n.sym;
5497 else if (e->expr_type == EXPR_FUNCTION)
5499 gcc_assert (e->symtree);
5500 sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
5503 attr = gfc_expr_attr (e);
5504 if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
5506 if (!(gfc_option.allow_std & GFC_STD_F2008))
5508 if (context)
5509 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5510 " context (%s) at %L", context, &e->where);
5511 return false;
5514 else if (e->expr_type != EXPR_VARIABLE)
5516 if (context)
5517 gfc_error ("Non-variable expression in variable definition context (%s)"
5518 " at %L", context, &e->where);
5519 return false;
5522 if (!pointer && sym->attr.flavor == FL_PARAMETER)
5524 if (context)
5525 gfc_error ("Named constant %qs in variable definition context (%s)"
5526 " at %L", sym->name, context, &e->where);
5527 return false;
5529 if (!pointer && sym->attr.flavor != FL_VARIABLE
5530 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
5531 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
5533 if (context)
5534 gfc_error ("%qs in variable definition context (%s) at %L is not"
5535 " a variable", sym->name, context, &e->where);
5536 return false;
5539 /* Find out whether the expr is a pointer; this also means following
5540 component references to the last one. */
5541 is_pointer = (attr.pointer || attr.proc_pointer);
5542 if (pointer && !is_pointer)
5544 if (context)
5545 gfc_error ("Non-POINTER in pointer association context (%s)"
5546 " at %L", context, &e->where);
5547 return false;
5550 if (e->ts.type == BT_DERIVED
5551 && e->ts.u.derived == NULL)
5553 if (context)
5554 gfc_error ("Type inaccessible in variable definition context (%s) "
5555 "at %L", context, &e->where);
5556 return false;
5559 /* F2008, C1303. */
5560 if (!alloc_obj
5561 && (attr.lock_comp
5562 || (e->ts.type == BT_DERIVED
5563 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5564 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
5566 if (context)
5567 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5568 context, &e->where);
5569 return false;
5572 /* TS18508, C702/C203. */
5573 if (!alloc_obj
5574 && (attr.lock_comp
5575 || (e->ts.type == BT_DERIVED
5576 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5577 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
5579 if (context)
5580 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5581 context, &e->where);
5582 return false;
5585 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5586 component of sub-component of a pointer; we need to distinguish
5587 assignment to a pointer component from pointer-assignment to a pointer
5588 component. Note that (normal) assignment to procedure pointers is not
5589 possible. */
5590 check_intentin = !own_scope;
5591 ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived
5592 && CLASS_DATA (sym))
5593 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
5594 for (ref = e->ref; ref && check_intentin; ref = ref->next)
5596 if (ptr_component && ref->type == REF_COMPONENT)
5597 check_intentin = false;
5598 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
5600 ptr_component = true;
5601 if (!pointer)
5602 check_intentin = false;
5605 if (check_intentin && sym->attr.intent == INTENT_IN)
5607 if (pointer && is_pointer)
5609 if (context)
5610 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5611 " association context (%s) at %L",
5612 sym->name, context, &e->where);
5613 return false;
5615 if (!pointer && !is_pointer && !sym->attr.pointer)
5617 if (context)
5618 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5619 " definition context (%s) at %L",
5620 sym->name, context, &e->where);
5621 return false;
5625 /* PROTECTED and use-associated. */
5626 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
5628 if (pointer && is_pointer)
5630 if (context)
5631 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5632 " pointer association context (%s) at %L",
5633 sym->name, context, &e->where);
5634 return false;
5636 if (!pointer && !is_pointer)
5638 if (context)
5639 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5640 " variable definition context (%s) at %L",
5641 sym->name, context, &e->where);
5642 return false;
5646 /* Variable not assignable from a PURE procedure but appears in
5647 variable definition context. */
5648 if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
5650 if (context)
5651 gfc_error ("Variable %qs can not appear in a variable definition"
5652 " context (%s) at %L in PURE procedure",
5653 sym->name, context, &e->where);
5654 return false;
5657 if (!pointer && context && gfc_implicit_pure (NULL)
5658 && gfc_impure_variable (sym))
5660 gfc_namespace *ns;
5661 gfc_symbol *sym;
5663 for (ns = gfc_current_ns; ns; ns = ns->parent)
5665 sym = ns->proc_name;
5666 if (sym == NULL)
5667 break;
5668 if (sym->attr.flavor == FL_PROCEDURE)
5670 sym->attr.implicit_pure = 0;
5671 break;
5675 /* Check variable definition context for associate-names. */
5676 if (!pointer && sym->assoc)
5678 const char* name;
5679 gfc_association_list* assoc;
5681 gcc_assert (sym->assoc->target);
5683 /* If this is a SELECT TYPE temporary (the association is used internally
5684 for SELECT TYPE), silently go over to the target. */
5685 if (sym->attr.select_type_temporary)
5687 gfc_expr* t = sym->assoc->target;
5689 gcc_assert (t->expr_type == EXPR_VARIABLE);
5690 name = t->symtree->name;
5692 if (t->symtree->n.sym->assoc)
5693 assoc = t->symtree->n.sym->assoc;
5694 else
5695 assoc = sym->assoc;
5697 else
5699 name = sym->name;
5700 assoc = sym->assoc;
5702 gcc_assert (name && assoc);
5704 /* Is association to a valid variable? */
5705 if (!assoc->variable)
5707 if (context)
5709 if (assoc->target->expr_type == EXPR_VARIABLE)
5710 gfc_error ("%qs at %L associated to vector-indexed target can"
5711 " not be used in a variable definition context (%s)",
5712 name, &e->where, context);
5713 else
5714 gfc_error ("%qs at %L associated to expression can"
5715 " not be used in a variable definition context (%s)",
5716 name, &e->where, context);
5718 return false;
5721 /* Target must be allowed to appear in a variable definition context. */
5722 if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
5724 if (context)
5725 gfc_error ("Associate-name %qs can not appear in a variable"
5726 " definition context (%s) at %L because its target"
5727 " at %L can not, either",
5728 name, context, &e->where,
5729 &assoc->target->where);
5730 return false;
5734 /* Check for same value in vector expression subscript. */
5736 if (e->rank > 0)
5737 for (ref = e->ref; ref != NULL; ref = ref->next)
5738 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
5739 for (i = 0; i < GFC_MAX_DIMENSIONS
5740 && ref->u.ar.dimen_type[i] != 0; i++)
5741 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5743 gfc_expr *arr = ref->u.ar.start[i];
5744 if (arr->expr_type == EXPR_ARRAY)
5746 gfc_constructor *c, *n;
5747 gfc_expr *ec, *en;
5749 for (c = gfc_constructor_first (arr->value.constructor);
5750 c != NULL; c = gfc_constructor_next (c))
5752 if (c == NULL || c->iterator != NULL)
5753 continue;
5755 ec = c->expr;
5757 for (n = gfc_constructor_next (c); n != NULL;
5758 n = gfc_constructor_next (n))
5760 if (n->iterator != NULL)
5761 continue;
5763 en = n->expr;
5764 if (gfc_dep_compare_expr (ec, en) == 0)
5766 if (context)
5767 gfc_error_now ("Elements with the same value "
5768 "at %L and %L in vector "
5769 "subscript in a variable "
5770 "definition context (%s)",
5771 &(ec->where), &(en->where),
5772 context);
5773 return false;
5780 return true;