Allow gather loads to be used for grouped accesses
[official-gcc.git] / gcc / fortran / expr.c
blob45ccc184fc18a27d09fabebe8d978b2a2242fbb6
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 e = gfc_copy_expr (p->symtree->n.sym->value);
1861 if (e == NULL)
1862 return false;
1864 e->rank = p->rank;
1866 /* Do not copy subobject refs for constant. */
1867 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1868 e->ref = gfc_copy_ref (p->ref);
1869 t = gfc_simplify_expr (e, type);
1871 /* Only use the simplification if it eliminated all subobject references. */
1872 if (t && !e->ref)
1873 gfc_replace_expr (p, e);
1874 else
1875 gfc_free_expr (e);
1877 return t;
1880 /* Given an expression, simplify it by collapsing constant
1881 expressions. Most simplification takes place when the expression
1882 tree is being constructed. If an intrinsic function is simplified
1883 at some point, we get called again to collapse the result against
1884 other constants.
1886 We work by recursively simplifying expression nodes, simplifying
1887 intrinsic functions where possible, which can lead to further
1888 constant collapsing. If an operator has constant operand(s), we
1889 rip the expression apart, and rebuild it, hoping that it becomes
1890 something simpler.
1892 The expression type is defined for:
1893 0 Basic expression parsing
1894 1 Simplifying array constructors -- will substitute
1895 iterator values.
1896 Returns false on error, true otherwise.
1897 NOTE: Will return true even if the expression can not be simplified. */
1899 bool
1900 gfc_simplify_expr (gfc_expr *p, int type)
1902 gfc_actual_arglist *ap;
1904 if (p == NULL)
1905 return true;
1907 switch (p->expr_type)
1909 case EXPR_CONSTANT:
1910 case EXPR_NULL:
1911 break;
1913 case EXPR_FUNCTION:
1914 for (ap = p->value.function.actual; ap; ap = ap->next)
1915 if (!gfc_simplify_expr (ap->expr, type))
1916 return false;
1918 if (p->value.function.isym != NULL
1919 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1920 return false;
1922 break;
1924 case EXPR_SUBSTRING:
1925 if (!simplify_ref_chain (p->ref, type))
1926 return false;
1928 if (gfc_is_constant_expr (p))
1930 gfc_char_t *s;
1931 HOST_WIDE_INT start, end;
1933 start = 0;
1934 if (p->ref && p->ref->u.ss.start)
1936 gfc_extract_hwi (p->ref->u.ss.start, &start);
1937 start--; /* Convert from one-based to zero-based. */
1940 end = p->value.character.length;
1941 if (p->ref && p->ref->u.ss.end)
1942 gfc_extract_hwi (p->ref->u.ss.end, &end);
1944 if (end < start)
1945 end = start;
1947 s = gfc_get_wide_string (end - start + 2);
1948 memcpy (s, p->value.character.string + start,
1949 (end - start) * sizeof (gfc_char_t));
1950 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1951 free (p->value.character.string);
1952 p->value.character.string = s;
1953 p->value.character.length = end - start;
1954 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1955 p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
1956 NULL,
1957 p->value.character.length);
1958 gfc_free_ref_list (p->ref);
1959 p->ref = NULL;
1960 p->expr_type = EXPR_CONSTANT;
1962 break;
1964 case EXPR_OP:
1965 if (!simplify_intrinsic_op (p, type))
1966 return false;
1967 break;
1969 case EXPR_VARIABLE:
1970 /* Only substitute array parameter variables if we are in an
1971 initialization expression, or we want a subsection. */
1972 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1973 && (gfc_init_expr_flag || p->ref
1974 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1976 if (!simplify_parameter_variable (p, type))
1977 return false;
1978 break;
1981 if (type == 1)
1983 gfc_simplify_iterator_var (p);
1986 /* Simplify subcomponent references. */
1987 if (!simplify_ref_chain (p->ref, type))
1988 return false;
1990 break;
1992 case EXPR_STRUCTURE:
1993 case EXPR_ARRAY:
1994 if (!simplify_ref_chain (p->ref, type))
1995 return false;
1997 if (!simplify_constructor (p->value.constructor, type))
1998 return false;
2000 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
2001 && p->ref->u.ar.type == AR_FULL)
2002 gfc_expand_constructor (p, false);
2004 if (!simplify_const_ref (p))
2005 return false;
2007 break;
2009 case EXPR_COMPCALL:
2010 case EXPR_PPC:
2011 break;
2014 return true;
2018 /* Returns the type of an expression with the exception that iterator
2019 variables are automatically integers no matter what else they may
2020 be declared as. */
2022 static bt
2023 et0 (gfc_expr *e)
2025 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e))
2026 return BT_INTEGER;
2028 return e->ts.type;
2032 /* Scalarize an expression for an elemental intrinsic call. */
2034 static bool
2035 scalarize_intrinsic_call (gfc_expr *e)
2037 gfc_actual_arglist *a, *b;
2038 gfc_constructor_base ctor;
2039 gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */
2040 gfc_constructor *ci, *new_ctor;
2041 gfc_expr *expr, *old;
2042 int n, i, rank[5], array_arg;
2044 /* Find which, if any, arguments are arrays. Assume that the old
2045 expression carries the type information and that the first arg
2046 that is an array expression carries all the shape information.*/
2047 n = array_arg = 0;
2048 a = e->value.function.actual;
2049 for (; a; a = a->next)
2051 n++;
2052 if (!a->expr || a->expr->expr_type != EXPR_ARRAY)
2053 continue;
2054 array_arg = n;
2055 expr = gfc_copy_expr (a->expr);
2056 break;
2059 if (!array_arg)
2060 return false;
2062 old = gfc_copy_expr (e);
2064 gfc_constructor_free (expr->value.constructor);
2065 expr->value.constructor = NULL;
2066 expr->ts = old->ts;
2067 expr->where = old->where;
2068 expr->expr_type = EXPR_ARRAY;
2070 /* Copy the array argument constructors into an array, with nulls
2071 for the scalars. */
2072 n = 0;
2073 a = old->value.function.actual;
2074 for (; a; a = a->next)
2076 /* Check that this is OK for an initialization expression. */
2077 if (a->expr && !gfc_check_init_expr (a->expr))
2078 goto cleanup;
2080 rank[n] = 0;
2081 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
2083 rank[n] = a->expr->rank;
2084 ctor = a->expr->symtree->n.sym->value->value.constructor;
2085 args[n] = gfc_constructor_first (ctor);
2087 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
2089 if (a->expr->rank)
2090 rank[n] = a->expr->rank;
2091 else
2092 rank[n] = 1;
2093 ctor = gfc_constructor_copy (a->expr->value.constructor);
2094 args[n] = gfc_constructor_first (ctor);
2096 else
2097 args[n] = NULL;
2099 n++;
2103 /* Using the array argument as the master, step through the array
2104 calling the function for each element and advancing the array
2105 constructors together. */
2106 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2108 new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2109 gfc_copy_expr (old), NULL);
2111 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2112 a = NULL;
2113 b = old->value.function.actual;
2114 for (i = 0; i < n; i++)
2116 if (a == NULL)
2117 new_ctor->expr->value.function.actual
2118 = a = gfc_get_actual_arglist ();
2119 else
2121 a->next = gfc_get_actual_arglist ();
2122 a = a->next;
2125 if (args[i])
2126 a->expr = gfc_copy_expr (args[i]->expr);
2127 else
2128 a->expr = gfc_copy_expr (b->expr);
2130 b = b->next;
2133 /* Simplify the function calls. If the simplification fails, the
2134 error will be flagged up down-stream or the library will deal
2135 with it. */
2136 gfc_simplify_expr (new_ctor->expr, 0);
2138 for (i = 0; i < n; i++)
2139 if (args[i])
2140 args[i] = gfc_constructor_next (args[i]);
2142 for (i = 1; i < n; i++)
2143 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
2144 || (args[i] == NULL && args[array_arg - 1] != NULL)))
2145 goto compliance;
2148 free_expr0 (e);
2149 *e = *expr;
2150 /* Free "expr" but not the pointers it contains. */
2151 free (expr);
2152 gfc_free_expr (old);
2153 return true;
2155 compliance:
2156 gfc_error_now ("elemental function arguments at %C are not compliant");
2158 cleanup:
2159 gfc_free_expr (expr);
2160 gfc_free_expr (old);
2161 return false;
2165 static bool
2166 check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *))
2168 gfc_expr *op1 = e->value.op.op1;
2169 gfc_expr *op2 = e->value.op.op2;
2171 if (!(*check_function)(op1))
2172 return false;
2174 switch (e->value.op.op)
2176 case INTRINSIC_UPLUS:
2177 case INTRINSIC_UMINUS:
2178 if (!numeric_type (et0 (op1)))
2179 goto not_numeric;
2180 break;
2182 case INTRINSIC_EQ:
2183 case INTRINSIC_EQ_OS:
2184 case INTRINSIC_NE:
2185 case INTRINSIC_NE_OS:
2186 case INTRINSIC_GT:
2187 case INTRINSIC_GT_OS:
2188 case INTRINSIC_GE:
2189 case INTRINSIC_GE_OS:
2190 case INTRINSIC_LT:
2191 case INTRINSIC_LT_OS:
2192 case INTRINSIC_LE:
2193 case INTRINSIC_LE_OS:
2194 if (!(*check_function)(op2))
2195 return false;
2197 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2198 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2200 gfc_error ("Numeric or CHARACTER operands are required in "
2201 "expression at %L", &e->where);
2202 return false;
2204 break;
2206 case INTRINSIC_PLUS:
2207 case INTRINSIC_MINUS:
2208 case INTRINSIC_TIMES:
2209 case INTRINSIC_DIVIDE:
2210 case INTRINSIC_POWER:
2211 if (!(*check_function)(op2))
2212 return false;
2214 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2215 goto not_numeric;
2217 break;
2219 case INTRINSIC_CONCAT:
2220 if (!(*check_function)(op2))
2221 return false;
2223 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2225 gfc_error ("Concatenation operator in expression at %L "
2226 "must have two CHARACTER operands", &op1->where);
2227 return false;
2230 if (op1->ts.kind != op2->ts.kind)
2232 gfc_error ("Concat operator at %L must concatenate strings of the "
2233 "same kind", &e->where);
2234 return false;
2237 break;
2239 case INTRINSIC_NOT:
2240 if (et0 (op1) != BT_LOGICAL)
2242 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2243 "operand", &op1->where);
2244 return false;
2247 break;
2249 case INTRINSIC_AND:
2250 case INTRINSIC_OR:
2251 case INTRINSIC_EQV:
2252 case INTRINSIC_NEQV:
2253 if (!(*check_function)(op2))
2254 return false;
2256 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2258 gfc_error ("LOGICAL operands are required in expression at %L",
2259 &e->where);
2260 return false;
2263 break;
2265 case INTRINSIC_PARENTHESES:
2266 break;
2268 default:
2269 gfc_error ("Only intrinsic operators can be used in expression at %L",
2270 &e->where);
2271 return false;
2274 return true;
2276 not_numeric:
2277 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2279 return false;
2282 /* F2003, 7.1.7 (3): In init expression, allocatable components
2283 must not be data-initialized. */
2284 static bool
2285 check_alloc_comp_init (gfc_expr *e)
2287 gfc_component *comp;
2288 gfc_constructor *ctor;
2290 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2291 gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS);
2293 for (comp = e->ts.u.derived->components,
2294 ctor = gfc_constructor_first (e->value.constructor);
2295 comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2297 if (comp->attr.allocatable && ctor->expr
2298 && ctor->expr->expr_type != EXPR_NULL)
2300 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2301 "component %qs in structure constructor at %L",
2302 comp->name, &ctor->expr->where);
2303 return false;
2307 return true;
2310 static match
2311 check_init_expr_arguments (gfc_expr *e)
2313 gfc_actual_arglist *ap;
2315 for (ap = e->value.function.actual; ap; ap = ap->next)
2316 if (!gfc_check_init_expr (ap->expr))
2317 return MATCH_ERROR;
2319 return MATCH_YES;
2322 static bool check_restricted (gfc_expr *);
2324 /* F95, 7.1.6.1, Initialization expressions, (7)
2325 F2003, 7.1.7 Initialization expression, (8) */
2327 static match
2328 check_inquiry (gfc_expr *e, int not_restricted)
2330 const char *name;
2331 const char *const *functions;
2333 static const char *const inquiry_func_f95[] = {
2334 "lbound", "shape", "size", "ubound",
2335 "bit_size", "len", "kind",
2336 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2337 "precision", "radix", "range", "tiny",
2338 NULL
2341 static const char *const inquiry_func_f2003[] = {
2342 "lbound", "shape", "size", "ubound",
2343 "bit_size", "len", "kind",
2344 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2345 "precision", "radix", "range", "tiny",
2346 "new_line", NULL
2349 int i = 0;
2350 gfc_actual_arglist *ap;
2352 if (!e->value.function.isym
2353 || !e->value.function.isym->inquiry)
2354 return MATCH_NO;
2356 /* An undeclared parameter will get us here (PR25018). */
2357 if (e->symtree == NULL)
2358 return MATCH_NO;
2360 if (e->symtree->n.sym->from_intmod)
2362 if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
2363 && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
2364 && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
2365 return MATCH_NO;
2367 if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
2368 && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
2369 return MATCH_NO;
2371 else
2373 name = e->symtree->n.sym->name;
2375 functions = (gfc_option.warn_std & GFC_STD_F2003)
2376 ? inquiry_func_f2003 : inquiry_func_f95;
2378 for (i = 0; functions[i]; i++)
2379 if (strcmp (functions[i], name) == 0)
2380 break;
2382 if (functions[i] == NULL)
2383 return MATCH_ERROR;
2386 /* At this point we have an inquiry function with a variable argument. The
2387 type of the variable might be undefined, but we need it now, because the
2388 arguments of these functions are not allowed to be undefined. */
2390 for (ap = e->value.function.actual; ap; ap = ap->next)
2392 if (!ap->expr)
2393 continue;
2395 if (ap->expr->ts.type == BT_UNKNOWN)
2397 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2398 && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
2399 return MATCH_NO;
2401 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2404 /* Assumed character length will not reduce to a constant expression
2405 with LEN, as required by the standard. */
2406 if (i == 5 && not_restricted
2407 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2408 && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
2409 || ap->expr->symtree->n.sym->ts.deferred))
2411 gfc_error ("Assumed or deferred character length variable %qs "
2412 "in constant expression at %L",
2413 ap->expr->symtree->n.sym->name,
2414 &ap->expr->where);
2415 return MATCH_ERROR;
2417 else if (not_restricted && !gfc_check_init_expr (ap->expr))
2418 return MATCH_ERROR;
2420 if (not_restricted == 0
2421 && ap->expr->expr_type != EXPR_VARIABLE
2422 && !check_restricted (ap->expr))
2423 return MATCH_ERROR;
2425 if (not_restricted == 0
2426 && ap->expr->expr_type == EXPR_VARIABLE
2427 && ap->expr->symtree->n.sym->attr.dummy
2428 && ap->expr->symtree->n.sym->attr.optional)
2429 return MATCH_NO;
2432 return MATCH_YES;
2436 /* F95, 7.1.6.1, Initialization expressions, (5)
2437 F2003, 7.1.7 Initialization expression, (5) */
2439 static match
2440 check_transformational (gfc_expr *e)
2442 static const char * const trans_func_f95[] = {
2443 "repeat", "reshape", "selected_int_kind",
2444 "selected_real_kind", "transfer", "trim", NULL
2447 static const char * const trans_func_f2003[] = {
2448 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2449 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2450 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2451 "trim", "unpack", NULL
2454 int i;
2455 const char *name;
2456 const char *const *functions;
2458 if (!e->value.function.isym
2459 || !e->value.function.isym->transformational)
2460 return MATCH_NO;
2462 name = e->symtree->n.sym->name;
2464 functions = (gfc_option.allow_std & GFC_STD_F2003)
2465 ? trans_func_f2003 : trans_func_f95;
2467 /* NULL() is dealt with below. */
2468 if (strcmp ("null", name) == 0)
2469 return MATCH_NO;
2471 for (i = 0; functions[i]; i++)
2472 if (strcmp (functions[i], name) == 0)
2473 break;
2475 if (functions[i] == NULL)
2477 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2478 "in an initialization expression", name, &e->where);
2479 return MATCH_ERROR;
2482 return check_init_expr_arguments (e);
2486 /* F95, 7.1.6.1, Initialization expressions, (6)
2487 F2003, 7.1.7 Initialization expression, (6) */
2489 static match
2490 check_null (gfc_expr *e)
2492 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2493 return MATCH_NO;
2495 return check_init_expr_arguments (e);
2499 static match
2500 check_elemental (gfc_expr *e)
2502 if (!e->value.function.isym
2503 || !e->value.function.isym->elemental)
2504 return MATCH_NO;
2506 if (e->ts.type != BT_INTEGER
2507 && e->ts.type != BT_CHARACTER
2508 && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard "
2509 "initialization expression at %L", &e->where))
2510 return MATCH_ERROR;
2512 return check_init_expr_arguments (e);
2516 static match
2517 check_conversion (gfc_expr *e)
2519 if (!e->value.function.isym
2520 || !e->value.function.isym->conversion)
2521 return MATCH_NO;
2523 return check_init_expr_arguments (e);
2527 /* Verify that an expression is an initialization expression. A side
2528 effect is that the expression tree is reduced to a single constant
2529 node if all goes well. This would normally happen when the
2530 expression is constructed but function references are assumed to be
2531 intrinsics in the context of initialization expressions. If
2532 false is returned an error message has been generated. */
2534 bool
2535 gfc_check_init_expr (gfc_expr *e)
2537 match m;
2538 bool t;
2540 if (e == NULL)
2541 return true;
2543 switch (e->expr_type)
2545 case EXPR_OP:
2546 t = check_intrinsic_op (e, gfc_check_init_expr);
2547 if (t)
2548 t = gfc_simplify_expr (e, 0);
2550 break;
2552 case EXPR_FUNCTION:
2553 t = false;
2556 bool conversion;
2557 gfc_intrinsic_sym* isym = NULL;
2558 gfc_symbol* sym = e->symtree->n.sym;
2560 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2561 IEEE_EXCEPTIONS modules. */
2562 int mod = sym->from_intmod;
2563 if (mod == INTMOD_NONE && sym->generic)
2564 mod = sym->generic->sym->from_intmod;
2565 if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS)
2567 gfc_expr *new_expr = gfc_simplify_ieee_functions (e);
2568 if (new_expr)
2570 gfc_replace_expr (e, new_expr);
2571 t = true;
2572 break;
2576 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2577 into an array constructor, we need to skip the error check here.
2578 Conversion errors are caught below in scalarize_intrinsic_call. */
2579 conversion = e->value.function.isym
2580 && (e->value.function.isym->conversion == 1);
2582 if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where)
2583 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES))
2585 gfc_error ("Function %qs in initialization expression at %L "
2586 "must be an intrinsic function",
2587 e->symtree->n.sym->name, &e->where);
2588 break;
2591 if ((m = check_conversion (e)) == MATCH_NO
2592 && (m = check_inquiry (e, 1)) == MATCH_NO
2593 && (m = check_null (e)) == MATCH_NO
2594 && (m = check_transformational (e)) == MATCH_NO
2595 && (m = check_elemental (e)) == MATCH_NO)
2597 gfc_error ("Intrinsic function %qs at %L is not permitted "
2598 "in an initialization expression",
2599 e->symtree->n.sym->name, &e->where);
2600 m = MATCH_ERROR;
2603 if (m == MATCH_ERROR)
2604 return false;
2606 /* Try to scalarize an elemental intrinsic function that has an
2607 array argument. */
2608 isym = gfc_find_function (e->symtree->n.sym->name);
2609 if (isym && isym->elemental
2610 && (t = scalarize_intrinsic_call (e)))
2611 break;
2614 if (m == MATCH_YES)
2615 t = gfc_simplify_expr (e, 0);
2617 break;
2619 case EXPR_VARIABLE:
2620 t = true;
2622 /* This occurs when parsing pdt templates. */
2623 if (gfc_expr_attr (e).pdt_kind)
2624 break;
2626 if (gfc_check_iter_variable (e))
2627 break;
2629 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2631 /* A PARAMETER shall not be used to define itself, i.e.
2632 REAL, PARAMETER :: x = transfer(0, x)
2633 is invalid. */
2634 if (!e->symtree->n.sym->value)
2636 gfc_error ("PARAMETER %qs is used at %L before its definition "
2637 "is complete", e->symtree->n.sym->name, &e->where);
2638 t = false;
2640 else
2641 t = simplify_parameter_variable (e, 0);
2643 break;
2646 if (gfc_in_match_data ())
2647 break;
2649 t = false;
2651 if (e->symtree->n.sym->as)
2653 switch (e->symtree->n.sym->as->type)
2655 case AS_ASSUMED_SIZE:
2656 gfc_error ("Assumed size array %qs at %L is not permitted "
2657 "in an initialization expression",
2658 e->symtree->n.sym->name, &e->where);
2659 break;
2661 case AS_ASSUMED_SHAPE:
2662 gfc_error ("Assumed shape array %qs at %L is not permitted "
2663 "in an initialization expression",
2664 e->symtree->n.sym->name, &e->where);
2665 break;
2667 case AS_DEFERRED:
2668 gfc_error ("Deferred array %qs at %L is not permitted "
2669 "in an initialization expression",
2670 e->symtree->n.sym->name, &e->where);
2671 break;
2673 case AS_EXPLICIT:
2674 gfc_error ("Array %qs at %L is a variable, which does "
2675 "not reduce to a constant expression",
2676 e->symtree->n.sym->name, &e->where);
2677 break;
2679 default:
2680 gcc_unreachable();
2683 else
2684 gfc_error ("Parameter %qs at %L has not been declared or is "
2685 "a variable, which does not reduce to a constant "
2686 "expression", e->symtree->name, &e->where);
2688 break;
2690 case EXPR_CONSTANT:
2691 case EXPR_NULL:
2692 t = true;
2693 break;
2695 case EXPR_SUBSTRING:
2696 if (e->ref)
2698 t = gfc_check_init_expr (e->ref->u.ss.start);
2699 if (!t)
2700 break;
2702 t = gfc_check_init_expr (e->ref->u.ss.end);
2703 if (t)
2704 t = gfc_simplify_expr (e, 0);
2706 else
2707 t = false;
2708 break;
2710 case EXPR_STRUCTURE:
2711 t = e->ts.is_iso_c ? true : false;
2712 if (t)
2713 break;
2715 t = check_alloc_comp_init (e);
2716 if (!t)
2717 break;
2719 t = gfc_check_constructor (e, gfc_check_init_expr);
2720 if (!t)
2721 break;
2723 break;
2725 case EXPR_ARRAY:
2726 t = gfc_check_constructor (e, gfc_check_init_expr);
2727 if (!t)
2728 break;
2730 t = gfc_expand_constructor (e, true);
2731 if (!t)
2732 break;
2734 t = gfc_check_constructor_type (e);
2735 break;
2737 default:
2738 gfc_internal_error ("check_init_expr(): Unknown expression type");
2741 return t;
2744 /* Reduces a general expression to an initialization expression (a constant).
2745 This used to be part of gfc_match_init_expr.
2746 Note that this function doesn't free the given expression on false. */
2748 bool
2749 gfc_reduce_init_expr (gfc_expr *expr)
2751 bool t;
2753 gfc_init_expr_flag = true;
2754 t = gfc_resolve_expr (expr);
2755 if (t)
2756 t = gfc_check_init_expr (expr);
2757 gfc_init_expr_flag = false;
2759 if (!t)
2760 return false;
2762 if (expr->expr_type == EXPR_ARRAY)
2764 if (!gfc_check_constructor_type (expr))
2765 return false;
2766 if (!gfc_expand_constructor (expr, true))
2767 return false;
2770 return true;
2774 /* Match an initialization expression. We work by first matching an
2775 expression, then reducing it to a constant. */
2777 match
2778 gfc_match_init_expr (gfc_expr **result)
2780 gfc_expr *expr;
2781 match m;
2782 bool t;
2784 expr = NULL;
2786 gfc_init_expr_flag = true;
2788 m = gfc_match_expr (&expr);
2789 if (m != MATCH_YES)
2791 gfc_init_expr_flag = false;
2792 return m;
2795 if (gfc_derived_parameter_expr (expr))
2797 *result = expr;
2798 gfc_init_expr_flag = false;
2799 return m;
2802 t = gfc_reduce_init_expr (expr);
2803 if (!t)
2805 gfc_free_expr (expr);
2806 gfc_init_expr_flag = false;
2807 return MATCH_ERROR;
2810 *result = expr;
2811 gfc_init_expr_flag = false;
2813 return MATCH_YES;
2817 /* Given an actual argument list, test to see that each argument is a
2818 restricted expression and optionally if the expression type is
2819 integer or character. */
2821 static bool
2822 restricted_args (gfc_actual_arglist *a)
2824 for (; a; a = a->next)
2826 if (!check_restricted (a->expr))
2827 return false;
2830 return true;
2834 /************* Restricted/specification expressions *************/
2837 /* Make sure a non-intrinsic function is a specification function,
2838 * see F08:7.1.11.5. */
2840 static bool
2841 external_spec_function (gfc_expr *e)
2843 gfc_symbol *f;
2845 f = e->value.function.esym;
2847 /* IEEE functions allowed are "a reference to a transformational function
2848 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2849 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2850 IEEE_EXCEPTIONS". */
2851 if (f->from_intmod == INTMOD_IEEE_ARITHMETIC
2852 || f->from_intmod == INTMOD_IEEE_EXCEPTIONS)
2854 if (!strcmp (f->name, "ieee_selected_real_kind")
2855 || !strcmp (f->name, "ieee_support_rounding")
2856 || !strcmp (f->name, "ieee_support_flag")
2857 || !strcmp (f->name, "ieee_support_halting")
2858 || !strcmp (f->name, "ieee_support_datatype")
2859 || !strcmp (f->name, "ieee_support_denormal")
2860 || !strcmp (f->name, "ieee_support_divide")
2861 || !strcmp (f->name, "ieee_support_inf")
2862 || !strcmp (f->name, "ieee_support_io")
2863 || !strcmp (f->name, "ieee_support_nan")
2864 || !strcmp (f->name, "ieee_support_sqrt")
2865 || !strcmp (f->name, "ieee_support_standard")
2866 || !strcmp (f->name, "ieee_support_underflow_control"))
2867 goto function_allowed;
2870 if (f->attr.proc == PROC_ST_FUNCTION)
2872 gfc_error ("Specification function %qs at %L cannot be a statement "
2873 "function", f->name, &e->where);
2874 return false;
2877 if (f->attr.proc == PROC_INTERNAL)
2879 gfc_error ("Specification function %qs at %L cannot be an internal "
2880 "function", f->name, &e->where);
2881 return false;
2884 if (!f->attr.pure && !f->attr.elemental)
2886 gfc_error ("Specification function %qs at %L must be PURE", f->name,
2887 &e->where);
2888 return false;
2891 /* F08:7.1.11.6. */
2892 if (f->attr.recursive
2893 && !gfc_notify_std (GFC_STD_F2003,
2894 "Specification function %qs "
2895 "at %L cannot be RECURSIVE", f->name, &e->where))
2896 return false;
2898 function_allowed:
2899 return restricted_args (e->value.function.actual);
2903 /* Check to see that a function reference to an intrinsic is a
2904 restricted expression. */
2906 static bool
2907 restricted_intrinsic (gfc_expr *e)
2909 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2910 if (check_inquiry (e, 0) == MATCH_YES)
2911 return true;
2913 return restricted_args (e->value.function.actual);
2917 /* Check the expressions of an actual arglist. Used by check_restricted. */
2919 static bool
2920 check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*))
2922 for (; arg; arg = arg->next)
2923 if (!checker (arg->expr))
2924 return false;
2926 return true;
2930 /* Check the subscription expressions of a reference chain with a checking
2931 function; used by check_restricted. */
2933 static bool
2934 check_references (gfc_ref* ref, bool (*checker) (gfc_expr*))
2936 int dim;
2938 if (!ref)
2939 return true;
2941 switch (ref->type)
2943 case REF_ARRAY:
2944 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2946 if (!checker (ref->u.ar.start[dim]))
2947 return false;
2948 if (!checker (ref->u.ar.end[dim]))
2949 return false;
2950 if (!checker (ref->u.ar.stride[dim]))
2951 return false;
2953 break;
2955 case REF_COMPONENT:
2956 /* Nothing needed, just proceed to next reference. */
2957 break;
2959 case REF_SUBSTRING:
2960 if (!checker (ref->u.ss.start))
2961 return false;
2962 if (!checker (ref->u.ss.end))
2963 return false;
2964 break;
2966 default:
2967 gcc_unreachable ();
2968 break;
2971 return check_references (ref->next, checker);
2974 /* Return true if ns is a parent of the current ns. */
2976 static bool
2977 is_parent_of_current_ns (gfc_namespace *ns)
2979 gfc_namespace *p;
2980 for (p = gfc_current_ns->parent; p; p = p->parent)
2981 if (ns == p)
2982 return true;
2984 return false;
2987 /* Verify that an expression is a restricted expression. Like its
2988 cousin check_init_expr(), an error message is generated if we
2989 return false. */
2991 static bool
2992 check_restricted (gfc_expr *e)
2994 gfc_symbol* sym;
2995 bool t;
2997 if (e == NULL)
2998 return true;
3000 switch (e->expr_type)
3002 case EXPR_OP:
3003 t = check_intrinsic_op (e, check_restricted);
3004 if (t)
3005 t = gfc_simplify_expr (e, 0);
3007 break;
3009 case EXPR_FUNCTION:
3010 if (e->value.function.esym)
3012 t = check_arglist (e->value.function.actual, &check_restricted);
3013 if (t)
3014 t = external_spec_function (e);
3016 else
3018 if (e->value.function.isym && e->value.function.isym->inquiry)
3019 t = true;
3020 else
3021 t = check_arglist (e->value.function.actual, &check_restricted);
3023 if (t)
3024 t = restricted_intrinsic (e);
3026 break;
3028 case EXPR_VARIABLE:
3029 sym = e->symtree->n.sym;
3030 t = false;
3032 /* If a dummy argument appears in a context that is valid for a
3033 restricted expression in an elemental procedure, it will have
3034 already been simplified away once we get here. Therefore we
3035 don't need to jump through hoops to distinguish valid from
3036 invalid cases. */
3037 if (sym->attr.dummy && sym->ns == gfc_current_ns
3038 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
3040 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3041 sym->name, &e->where);
3042 break;
3045 if (sym->attr.optional)
3047 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3048 sym->name, &e->where);
3049 break;
3052 if (sym->attr.intent == INTENT_OUT)
3054 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3055 sym->name, &e->where);
3056 break;
3059 /* Check reference chain if any. */
3060 if (!check_references (e->ref, &check_restricted))
3061 break;
3063 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3064 processed in resolve.c(resolve_formal_arglist). This is done so
3065 that host associated dummy array indices are accepted (PR23446).
3066 This mechanism also does the same for the specification expressions
3067 of array-valued functions. */
3068 if (e->error
3069 || sym->attr.in_common
3070 || sym->attr.use_assoc
3071 || sym->attr.dummy
3072 || sym->attr.implied_index
3073 || sym->attr.flavor == FL_PARAMETER
3074 || is_parent_of_current_ns (sym->ns)
3075 || (sym->ns->proc_name != NULL
3076 && sym->ns->proc_name->attr.flavor == FL_MODULE)
3077 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
3079 t = true;
3080 break;
3083 gfc_error ("Variable %qs cannot appear in the expression at %L",
3084 sym->name, &e->where);
3085 /* Prevent a repetition of the error. */
3086 e->error = 1;
3087 break;
3089 case EXPR_NULL:
3090 case EXPR_CONSTANT:
3091 t = true;
3092 break;
3094 case EXPR_SUBSTRING:
3095 t = gfc_specification_expr (e->ref->u.ss.start);
3096 if (!t)
3097 break;
3099 t = gfc_specification_expr (e->ref->u.ss.end);
3100 if (t)
3101 t = gfc_simplify_expr (e, 0);
3103 break;
3105 case EXPR_STRUCTURE:
3106 t = gfc_check_constructor (e, check_restricted);
3107 break;
3109 case EXPR_ARRAY:
3110 t = gfc_check_constructor (e, check_restricted);
3111 break;
3113 default:
3114 gfc_internal_error ("check_restricted(): Unknown expression type");
3117 return t;
3121 /* Check to see that an expression is a specification expression. If
3122 we return false, an error has been generated. */
3124 bool
3125 gfc_specification_expr (gfc_expr *e)
3127 gfc_component *comp;
3129 if (e == NULL)
3130 return true;
3132 if (e->ts.type != BT_INTEGER)
3134 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3135 &e->where, gfc_basic_typename (e->ts.type));
3136 return false;
3139 comp = gfc_get_proc_ptr_comp (e);
3140 if (e->expr_type == EXPR_FUNCTION
3141 && !e->value.function.isym
3142 && !e->value.function.esym
3143 && !gfc_pure (e->symtree->n.sym)
3144 && (!comp || !comp->attr.pure))
3146 gfc_error ("Function %qs at %L must be PURE",
3147 e->symtree->n.sym->name, &e->where);
3148 /* Prevent repeat error messages. */
3149 e->symtree->n.sym->attr.pure = 1;
3150 return false;
3153 if (e->rank != 0)
3155 gfc_error ("Expression at %L must be scalar", &e->where);
3156 return false;
3159 if (!gfc_simplify_expr (e, 0))
3160 return false;
3162 return check_restricted (e);
3166 /************** Expression conformance checks. *************/
3168 /* Given two expressions, make sure that the arrays are conformable. */
3170 bool
3171 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
3173 int op1_flag, op2_flag, d;
3174 mpz_t op1_size, op2_size;
3175 bool t;
3177 va_list argp;
3178 char buffer[240];
3180 if (op1->rank == 0 || op2->rank == 0)
3181 return true;
3183 va_start (argp, optype_msgid);
3184 vsnprintf (buffer, 240, optype_msgid, argp);
3185 va_end (argp);
3187 if (op1->rank != op2->rank)
3189 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
3190 op1->rank, op2->rank, &op1->where);
3191 return false;
3194 t = true;
3196 for (d = 0; d < op1->rank; d++)
3198 op1_flag = gfc_array_dimen_size(op1, d, &op1_size);
3199 op2_flag = gfc_array_dimen_size(op2, d, &op2_size);
3201 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3203 gfc_error ("Different shape for %s at %L on dimension %d "
3204 "(%d and %d)", _(buffer), &op1->where, d + 1,
3205 (int) mpz_get_si (op1_size),
3206 (int) mpz_get_si (op2_size));
3208 t = false;
3211 if (op1_flag)
3212 mpz_clear (op1_size);
3213 if (op2_flag)
3214 mpz_clear (op2_size);
3216 if (!t)
3217 return false;
3220 return true;
3224 /* Given an assignable expression and an arbitrary expression, make
3225 sure that the assignment can take place. Only add a call to the intrinsic
3226 conversion routines, when allow_convert is set. When this assign is a
3227 coarray call, then the convert is done by the coarray routine implictly and
3228 adding the intrinsic conversion would do harm in most cases. */
3230 bool
3231 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
3232 bool allow_convert)
3234 gfc_symbol *sym;
3235 gfc_ref *ref;
3236 int has_pointer;
3238 sym = lvalue->symtree->n.sym;
3240 /* See if this is the component or subcomponent of a pointer. */
3241 has_pointer = sym->attr.pointer;
3242 for (ref = lvalue->ref; ref; ref = ref->next)
3243 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3245 has_pointer = 1;
3246 break;
3249 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3250 variable local to a function subprogram. Its existence begins when
3251 execution of the function is initiated and ends when execution of the
3252 function is terminated...
3253 Therefore, the left hand side is no longer a variable, when it is: */
3254 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3255 && !sym->attr.external)
3257 bool bad_proc;
3258 bad_proc = false;
3260 /* (i) Use associated; */
3261 if (sym->attr.use_assoc)
3262 bad_proc = true;
3264 /* (ii) The assignment is in the main program; or */
3265 if (gfc_current_ns->proc_name
3266 && gfc_current_ns->proc_name->attr.is_main_program)
3267 bad_proc = true;
3269 /* (iii) A module or internal procedure... */
3270 if (gfc_current_ns->proc_name
3271 && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3272 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3273 && gfc_current_ns->parent
3274 && (!(gfc_current_ns->parent->proc_name->attr.function
3275 || gfc_current_ns->parent->proc_name->attr.subroutine)
3276 || gfc_current_ns->parent->proc_name->attr.is_main_program))
3278 /* ... that is not a function... */
3279 if (gfc_current_ns->proc_name
3280 && !gfc_current_ns->proc_name->attr.function)
3281 bad_proc = true;
3283 /* ... or is not an entry and has a different name. */
3284 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3285 bad_proc = true;
3288 /* (iv) Host associated and not the function symbol or the
3289 parent result. This picks up sibling references, which
3290 cannot be entries. */
3291 if (!sym->attr.entry
3292 && sym->ns == gfc_current_ns->parent
3293 && sym != gfc_current_ns->proc_name
3294 && sym != gfc_current_ns->parent->proc_name->result)
3295 bad_proc = true;
3297 if (bad_proc)
3299 gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
3300 return false;
3304 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3306 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3307 lvalue->rank, rvalue->rank, &lvalue->where);
3308 return false;
3311 if (lvalue->ts.type == BT_UNKNOWN)
3313 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3314 &lvalue->where);
3315 return false;
3318 if (rvalue->expr_type == EXPR_NULL)
3320 if (has_pointer && (ref == NULL || ref->next == NULL)
3321 && lvalue->symtree->n.sym->attr.data)
3322 return true;
3323 else
3325 gfc_error ("NULL appears on right-hand side in assignment at %L",
3326 &rvalue->where);
3327 return false;
3331 /* This is possibly a typo: x = f() instead of x => f(). */
3332 if (warn_surprising
3333 && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
3334 gfc_warning (OPT_Wsurprising,
3335 "POINTER-valued function appears on right-hand side of "
3336 "assignment at %L", &rvalue->where);
3338 /* Check size of array assignments. */
3339 if (lvalue->rank != 0 && rvalue->rank != 0
3340 && !gfc_check_conformance (lvalue, rvalue, "array assignment"))
3341 return false;
3343 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3344 && lvalue->symtree->n.sym->attr.data
3345 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
3346 "initialize non-integer variable %qs",
3347 &rvalue->where, lvalue->symtree->n.sym->name))
3348 return false;
3349 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3350 && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
3351 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3352 &rvalue->where))
3353 return false;
3355 /* Handle the case of a BOZ literal on the RHS. */
3356 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3358 int rc;
3359 if (warn_surprising)
3360 gfc_warning (OPT_Wsurprising,
3361 "BOZ literal at %L is bitwise transferred "
3362 "non-integer symbol %qs", &rvalue->where,
3363 lvalue->symtree->n.sym->name);
3364 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3365 return false;
3366 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3368 if (rc == ARITH_UNDERFLOW)
3369 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3370 ". This check can be disabled with the option "
3371 "%<-fno-range-check%>", &rvalue->where);
3372 else if (rc == ARITH_OVERFLOW)
3373 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3374 ". This check can be disabled with the option "
3375 "%<-fno-range-check%>", &rvalue->where);
3376 else if (rc == ARITH_NAN)
3377 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3378 ". This check can be disabled with the option "
3379 "%<-fno-range-check%>", &rvalue->where);
3380 return false;
3384 if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
3386 gfc_error ("The assignment to a KIND or LEN component of a "
3387 "parameterized type at %L is not allowed",
3388 &lvalue->where);
3389 return false;
3392 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3393 return true;
3395 /* Only DATA Statements come here. */
3396 if (!conform)
3398 /* Numeric can be converted to any other numeric. And Hollerith can be
3399 converted to any other type. */
3400 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3401 || rvalue->ts.type == BT_HOLLERITH)
3402 return true;
3404 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3405 return true;
3407 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3408 "conversion of %s to %s", &lvalue->where,
3409 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3411 return false;
3414 /* Assignment is the only case where character variables of different
3415 kind values can be converted into one another. */
3416 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3418 if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
3419 return gfc_convert_chartype (rvalue, &lvalue->ts);
3420 else
3421 return true;
3424 if (!allow_convert)
3425 return true;
3427 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3431 /* Check that a pointer assignment is OK. We first check lvalue, and
3432 we only check rvalue if it's not an assignment to NULL() or a
3433 NULLIFY statement. */
3435 bool
3436 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3438 symbol_attribute attr, lhs_attr;
3439 gfc_ref *ref;
3440 bool is_pure, is_implicit_pure, rank_remap;
3441 int proc_pointer;
3443 lhs_attr = gfc_expr_attr (lvalue);
3444 if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
3446 gfc_error ("Pointer assignment target is not a POINTER at %L",
3447 &lvalue->where);
3448 return false;
3451 if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
3452 && !lhs_attr.proc_pointer)
3454 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3455 "l-value since it is a procedure",
3456 lvalue->symtree->n.sym->name, &lvalue->where);
3457 return false;
3460 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3462 rank_remap = false;
3463 for (ref = lvalue->ref; ref; ref = ref->next)
3465 if (ref->type == REF_COMPONENT)
3466 proc_pointer = ref->u.c.component->attr.proc_pointer;
3468 if (ref->type == REF_ARRAY && ref->next == NULL)
3470 int dim;
3472 if (ref->u.ar.type == AR_FULL)
3473 break;
3475 if (ref->u.ar.type != AR_SECTION)
3477 gfc_error ("Expected bounds specification for %qs at %L",
3478 lvalue->symtree->n.sym->name, &lvalue->where);
3479 return false;
3482 if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
3483 "for %qs in pointer assignment at %L",
3484 lvalue->symtree->n.sym->name, &lvalue->where))
3485 return false;
3487 /* When bounds are given, all lbounds are necessary and either all
3488 or none of the upper bounds; no strides are allowed. If the
3489 upper bounds are present, we may do rank remapping. */
3490 for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3492 if (!ref->u.ar.start[dim]
3493 || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3495 gfc_error ("Lower bound has to be present at %L",
3496 &lvalue->where);
3497 return false;
3499 if (ref->u.ar.stride[dim])
3501 gfc_error ("Stride must not be present at %L",
3502 &lvalue->where);
3503 return false;
3506 if (dim == 0)
3507 rank_remap = (ref->u.ar.end[dim] != NULL);
3508 else
3510 if ((rank_remap && !ref->u.ar.end[dim])
3511 || (!rank_remap && ref->u.ar.end[dim]))
3513 gfc_error ("Either all or none of the upper bounds"
3514 " must be specified at %L", &lvalue->where);
3515 return false;
3522 is_pure = gfc_pure (NULL);
3523 is_implicit_pure = gfc_implicit_pure (NULL);
3525 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3526 kind, etc for lvalue and rvalue must match, and rvalue must be a
3527 pure variable if we're in a pure function. */
3528 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3529 return true;
3531 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3532 if (lvalue->expr_type == EXPR_VARIABLE
3533 && gfc_is_coindexed (lvalue))
3535 gfc_ref *ref;
3536 for (ref = lvalue->ref; ref; ref = ref->next)
3537 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3539 gfc_error ("Pointer object at %L shall not have a coindex",
3540 &lvalue->where);
3541 return false;
3545 /* Checks on rvalue for procedure pointer assignments. */
3546 if (proc_pointer)
3548 char err[200];
3549 gfc_symbol *s1,*s2;
3550 gfc_component *comp1, *comp2;
3551 const char *name;
3553 attr = gfc_expr_attr (rvalue);
3554 if (!((rvalue->expr_type == EXPR_NULL)
3555 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3556 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3557 || (rvalue->expr_type == EXPR_VARIABLE
3558 && attr.flavor == FL_PROCEDURE)))
3560 gfc_error ("Invalid procedure pointer assignment at %L",
3561 &rvalue->where);
3562 return false;
3564 if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
3566 /* Check for intrinsics. */
3567 gfc_symbol *sym = rvalue->symtree->n.sym;
3568 if (!sym->attr.intrinsic
3569 && (gfc_is_intrinsic (sym, 0, sym->declared_at)
3570 || gfc_is_intrinsic (sym, 1, sym->declared_at)))
3572 sym->attr.intrinsic = 1;
3573 gfc_resolve_intrinsic (sym, &rvalue->where);
3574 attr = gfc_expr_attr (rvalue);
3576 /* Check for result of embracing function. */
3577 if (sym->attr.function && sym->result == sym)
3579 gfc_namespace *ns;
3581 for (ns = gfc_current_ns; ns; ns = ns->parent)
3582 if (sym == ns->proc_name)
3584 gfc_error ("Function result %qs is invalid as proc-target "
3585 "in procedure pointer assignment at %L",
3586 sym->name, &rvalue->where);
3587 return false;
3591 if (attr.abstract)
3593 gfc_error ("Abstract interface %qs is invalid "
3594 "in procedure pointer assignment at %L",
3595 rvalue->symtree->name, &rvalue->where);
3596 return false;
3598 /* Check for F08:C729. */
3599 if (attr.flavor == FL_PROCEDURE)
3601 if (attr.proc == PROC_ST_FUNCTION)
3603 gfc_error ("Statement function %qs is invalid "
3604 "in procedure pointer assignment at %L",
3605 rvalue->symtree->name, &rvalue->where);
3606 return false;
3608 if (attr.proc == PROC_INTERNAL &&
3609 !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs "
3610 "is invalid in procedure pointer assignment "
3611 "at %L", rvalue->symtree->name, &rvalue->where))
3612 return false;
3613 if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
3614 attr.subroutine) == 0)
3616 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3617 "assignment", rvalue->symtree->name, &rvalue->where);
3618 return false;
3621 /* Check for F08:C730. */
3622 if (attr.elemental && !attr.intrinsic)
3624 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3625 "in procedure pointer assignment at %L",
3626 rvalue->symtree->name, &rvalue->where);
3627 return false;
3630 /* Ensure that the calling convention is the same. As other attributes
3631 such as DLLEXPORT may differ, one explicitly only tests for the
3632 calling conventions. */
3633 if (rvalue->expr_type == EXPR_VARIABLE
3634 && lvalue->symtree->n.sym->attr.ext_attr
3635 != rvalue->symtree->n.sym->attr.ext_attr)
3637 symbol_attribute calls;
3639 calls.ext_attr = 0;
3640 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3641 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3642 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3644 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3645 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3647 gfc_error ("Mismatch in the procedure pointer assignment "
3648 "at %L: mismatch in the calling convention",
3649 &rvalue->where);
3650 return false;
3654 comp1 = gfc_get_proc_ptr_comp (lvalue);
3655 if (comp1)
3656 s1 = comp1->ts.interface;
3657 else
3659 s1 = lvalue->symtree->n.sym;
3660 if (s1->ts.interface)
3661 s1 = s1->ts.interface;
3664 comp2 = gfc_get_proc_ptr_comp (rvalue);
3665 if (comp2)
3667 if (rvalue->expr_type == EXPR_FUNCTION)
3669 s2 = comp2->ts.interface->result;
3670 name = s2->name;
3672 else
3674 s2 = comp2->ts.interface;
3675 name = comp2->name;
3678 else if (rvalue->expr_type == EXPR_FUNCTION)
3680 if (rvalue->value.function.esym)
3681 s2 = rvalue->value.function.esym->result;
3682 else
3683 s2 = rvalue->symtree->n.sym->result;
3685 name = s2->name;
3687 else
3689 s2 = rvalue->symtree->n.sym;
3690 name = s2->name;
3693 if (s2 && s2->attr.proc_pointer && s2->ts.interface)
3694 s2 = s2->ts.interface;
3696 /* Special check for the case of absent interface on the lvalue.
3697 * All other interface checks are done below. */
3698 if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
3700 gfc_error ("Interface mismatch in procedure pointer assignment "
3701 "at %L: %qs is not a subroutine", &rvalue->where, name);
3702 return false;
3705 /* F08:7.2.2.4 (4) */
3706 if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err)))
3708 if (comp1 && !s1)
3710 gfc_error ("Explicit interface required for component %qs at %L: %s",
3711 comp1->name, &lvalue->where, err);
3712 return false;
3714 else if (s1->attr.if_source == IFSRC_UNKNOWN)
3716 gfc_error ("Explicit interface required for %qs at %L: %s",
3717 s1->name, &lvalue->where, err);
3718 return false;
3721 if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err)))
3723 if (comp2 && !s2)
3725 gfc_error ("Explicit interface required for component %qs at %L: %s",
3726 comp2->name, &rvalue->where, err);
3727 return false;
3729 else if (s2->attr.if_source == IFSRC_UNKNOWN)
3731 gfc_error ("Explicit interface required for %qs at %L: %s",
3732 s2->name, &rvalue->where, err);
3733 return false;
3737 if (s1 == s2 || !s1 || !s2)
3738 return true;
3740 if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
3741 err, sizeof(err), NULL, NULL))
3743 gfc_error ("Interface mismatch in procedure pointer assignment "
3744 "at %L: %s", &rvalue->where, err);
3745 return false;
3748 /* Check F2008Cor2, C729. */
3749 if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
3750 && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
3752 gfc_error ("Procedure pointer target %qs at %L must be either an "
3753 "intrinsic, host or use associated, referenced or have "
3754 "the EXTERNAL attribute", s2->name, &rvalue->where);
3755 return false;
3758 return true;
3761 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3763 /* Check for F03:C717. */
3764 if (UNLIMITED_POLY (rvalue)
3765 && !(UNLIMITED_POLY (lvalue)
3766 || (lvalue->ts.type == BT_DERIVED
3767 && (lvalue->ts.u.derived->attr.is_bind_c
3768 || lvalue->ts.u.derived->attr.sequence))))
3769 gfc_error ("Data-pointer-object at %L must be unlimited "
3770 "polymorphic, or of a type with the BIND or SEQUENCE "
3771 "attribute, to be compatible with an unlimited "
3772 "polymorphic target", &lvalue->where);
3773 else
3774 gfc_error ("Different types in pointer assignment at %L; "
3775 "attempted assignment of %s to %s", &lvalue->where,
3776 gfc_typename (&rvalue->ts),
3777 gfc_typename (&lvalue->ts));
3778 return false;
3781 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3783 gfc_error ("Different kind type parameters in pointer "
3784 "assignment at %L", &lvalue->where);
3785 return false;
3788 if (lvalue->rank != rvalue->rank && !rank_remap)
3790 gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
3791 return false;
3794 /* Make sure the vtab is present. */
3795 if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
3796 gfc_find_vtab (&rvalue->ts);
3798 /* Check rank remapping. */
3799 if (rank_remap)
3801 mpz_t lsize, rsize;
3803 /* If this can be determined, check that the target must be at least as
3804 large as the pointer assigned to it is. */
3805 if (gfc_array_size (lvalue, &lsize)
3806 && gfc_array_size (rvalue, &rsize)
3807 && mpz_cmp (rsize, lsize) < 0)
3809 gfc_error ("Rank remapping target is smaller than size of the"
3810 " pointer (%ld < %ld) at %L",
3811 mpz_get_si (rsize), mpz_get_si (lsize),
3812 &lvalue->where);
3813 return false;
3816 /* The target must be either rank one or it must be simply contiguous
3817 and F2008 must be allowed. */
3818 if (rvalue->rank != 1)
3820 if (!gfc_is_simply_contiguous (rvalue, true, false))
3822 gfc_error ("Rank remapping target must be rank 1 or"
3823 " simply contiguous at %L", &rvalue->where);
3824 return false;
3826 if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not "
3827 "rank 1 at %L", &rvalue->where))
3828 return false;
3832 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3833 if (rvalue->expr_type == EXPR_NULL)
3834 return true;
3836 if (lvalue->ts.type == BT_CHARACTER)
3838 bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3839 if (!t)
3840 return false;
3843 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3844 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3846 attr = gfc_expr_attr (rvalue);
3848 if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
3850 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
3851 to caf_get. Map this to the same error message as below when it is
3852 still a variable expression. */
3853 if (rvalue->value.function.isym
3854 && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET)
3855 /* The test above might need to be extend when F08, Note 5.4 has to be
3856 interpreted in the way that target and pointer with the same coindex
3857 are allowed. */
3858 gfc_error ("Data target at %L shall not have a coindex",
3859 &rvalue->where);
3860 else
3861 gfc_error ("Target expression in pointer assignment "
3862 "at %L must deliver a pointer result",
3863 &rvalue->where);
3864 return false;
3867 if (!attr.target && !attr.pointer)
3869 gfc_error ("Pointer assignment target is neither TARGET "
3870 "nor POINTER at %L", &rvalue->where);
3871 return false;
3874 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3876 gfc_error ("Bad target in pointer assignment in PURE "
3877 "procedure at %L", &rvalue->where);
3880 if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3881 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3883 if (gfc_has_vector_index (rvalue))
3885 gfc_error ("Pointer assignment with vector subscript "
3886 "on rhs at %L", &rvalue->where);
3887 return false;
3890 if (attr.is_protected && attr.use_assoc
3891 && !(attr.pointer || attr.proc_pointer))
3893 gfc_error ("Pointer assignment target has PROTECTED "
3894 "attribute at %L", &rvalue->where);
3895 return false;
3898 /* F2008, C725. For PURE also C1283. */
3899 if (rvalue->expr_type == EXPR_VARIABLE
3900 && gfc_is_coindexed (rvalue))
3902 gfc_ref *ref;
3903 for (ref = rvalue->ref; ref; ref = ref->next)
3904 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3906 gfc_error ("Data target at %L shall not have a coindex",
3907 &rvalue->where);
3908 return false;
3912 /* Error for assignments of contiguous pointers to targets which is not
3913 contiguous. Be lenient in the definition of what counts as
3914 contiguous. */
3916 if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true))
3917 gfc_error ("Assignment to contiguous pointer from non-contiguous "
3918 "target at %L", &rvalue->where);
3920 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3921 if (warn_target_lifetime
3922 && rvalue->expr_type == EXPR_VARIABLE
3923 && !rvalue->symtree->n.sym->attr.save
3924 && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer
3925 && !rvalue->symtree->n.sym->attr.host_assoc
3926 && !rvalue->symtree->n.sym->attr.in_common
3927 && !rvalue->symtree->n.sym->attr.use_assoc
3928 && !rvalue->symtree->n.sym->attr.dummy)
3930 bool warn;
3931 gfc_namespace *ns;
3933 warn = lvalue->symtree->n.sym->attr.dummy
3934 || lvalue->symtree->n.sym->attr.result
3935 || lvalue->symtree->n.sym->attr.function
3936 || (lvalue->symtree->n.sym->attr.host_assoc
3937 && lvalue->symtree->n.sym->ns
3938 != rvalue->symtree->n.sym->ns)
3939 || lvalue->symtree->n.sym->attr.use_assoc
3940 || lvalue->symtree->n.sym->attr.in_common;
3942 if (rvalue->symtree->n.sym->ns->proc_name
3943 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE
3944 && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM)
3945 for (ns = rvalue->symtree->n.sym->ns;
3946 ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE;
3947 ns = ns->parent)
3948 if (ns->parent == lvalue->symtree->n.sym->ns)
3950 warn = true;
3951 break;
3954 if (warn)
3955 gfc_warning (OPT_Wtarget_lifetime,
3956 "Pointer at %L in pointer assignment might outlive the "
3957 "pointer target", &lvalue->where);
3960 return true;
3964 /* Relative of gfc_check_assign() except that the lvalue is a single
3965 symbol. Used for initialization assignments. */
3967 bool
3968 gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
3970 gfc_expr lvalue;
3971 bool r;
3972 bool pointer, proc_pointer;
3974 memset (&lvalue, '\0', sizeof (gfc_expr));
3976 lvalue.expr_type = EXPR_VARIABLE;
3977 lvalue.ts = sym->ts;
3978 if (sym->as)
3979 lvalue.rank = sym->as->rank;
3980 lvalue.symtree = XCNEW (gfc_symtree);
3981 lvalue.symtree->n.sym = sym;
3982 lvalue.where = sym->declared_at;
3984 if (comp)
3986 lvalue.ref = gfc_get_ref ();
3987 lvalue.ref->type = REF_COMPONENT;
3988 lvalue.ref->u.c.component = comp;
3989 lvalue.ref->u.c.sym = sym;
3990 lvalue.ts = comp->ts;
3991 lvalue.rank = comp->as ? comp->as->rank : 0;
3992 lvalue.where = comp->loc;
3993 pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp)
3994 ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer;
3995 proc_pointer = comp->attr.proc_pointer;
3997 else
3999 pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym)
4000 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
4001 proc_pointer = sym->attr.proc_pointer;
4004 if (pointer || proc_pointer)
4005 r = gfc_check_pointer_assign (&lvalue, rvalue);
4006 else
4008 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4009 into an array constructor, we should check if it can be reduced
4010 as an initialization expression. */
4011 if (rvalue->expr_type == EXPR_FUNCTION
4012 && rvalue->value.function.isym
4013 && (rvalue->value.function.isym->conversion == 1))
4014 gfc_check_init_expr (rvalue);
4016 r = gfc_check_assign (&lvalue, rvalue, 1);
4019 free (lvalue.symtree);
4020 free (lvalue.ref);
4022 if (!r)
4023 return r;
4025 if (pointer && rvalue->expr_type != EXPR_NULL)
4027 /* F08:C461. Additional checks for pointer initialization. */
4028 symbol_attribute attr;
4029 attr = gfc_expr_attr (rvalue);
4030 if (attr.allocatable)
4032 gfc_error ("Pointer initialization target at %L "
4033 "must not be ALLOCATABLE", &rvalue->where);
4034 return false;
4036 if (!attr.target || attr.pointer)
4038 gfc_error ("Pointer initialization target at %L "
4039 "must have the TARGET attribute", &rvalue->where);
4040 return false;
4043 if (!attr.save && rvalue->expr_type == EXPR_VARIABLE
4044 && rvalue->symtree->n.sym->ns->proc_name
4045 && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program)
4047 rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT;
4048 attr.save = SAVE_IMPLICIT;
4051 if (!attr.save)
4053 gfc_error ("Pointer initialization target at %L "
4054 "must have the SAVE attribute", &rvalue->where);
4055 return false;
4059 if (proc_pointer && rvalue->expr_type != EXPR_NULL)
4061 /* F08:C1220. Additional checks for procedure pointer initialization. */
4062 symbol_attribute attr = gfc_expr_attr (rvalue);
4063 if (attr.proc_pointer)
4065 gfc_error ("Procedure pointer initialization target at %L "
4066 "may not be a procedure pointer", &rvalue->where);
4067 return false;
4071 return true;
4074 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4075 * require that an expression be built. */
4077 gfc_expr *
4078 gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
4080 return gfc_build_init_expr (ts, where, false);
4083 /* Build an initializer for a local integer, real, complex, logical, or
4084 character variable, based on the command line flags finit-local-zero,
4085 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4086 With force, an initializer is ALWAYS generated. */
4088 gfc_expr *
4089 gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force)
4091 int char_len;
4092 gfc_expr *init_expr;
4093 int i;
4095 /* Try to build an initializer expression. */
4096 init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
4098 /* If we want to force generation, make sure we default to zero. */
4099 gfc_init_local_real init_real = flag_init_real;
4100 int init_logical = gfc_option.flag_init_logical;
4101 if (force)
4103 if (init_real == GFC_INIT_REAL_OFF)
4104 init_real = GFC_INIT_REAL_ZERO;
4105 if (init_logical == GFC_INIT_LOGICAL_OFF)
4106 init_logical = GFC_INIT_LOGICAL_FALSE;
4109 /* We will only initialize integers, reals, complex, logicals, and
4110 characters, and only if the corresponding command-line flags
4111 were set. Otherwise, we free init_expr and return null. */
4112 switch (ts->type)
4114 case BT_INTEGER:
4115 if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
4116 mpz_set_si (init_expr->value.integer,
4117 gfc_option.flag_init_integer_value);
4118 else
4120 gfc_free_expr (init_expr);
4121 init_expr = NULL;
4123 break;
4125 case BT_REAL:
4126 switch (init_real)
4128 case GFC_INIT_REAL_SNAN:
4129 init_expr->is_snan = 1;
4130 /* Fall through. */
4131 case GFC_INIT_REAL_NAN:
4132 mpfr_set_nan (init_expr->value.real);
4133 break;
4135 case GFC_INIT_REAL_INF:
4136 mpfr_set_inf (init_expr->value.real, 1);
4137 break;
4139 case GFC_INIT_REAL_NEG_INF:
4140 mpfr_set_inf (init_expr->value.real, -1);
4141 break;
4143 case GFC_INIT_REAL_ZERO:
4144 mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE);
4145 break;
4147 default:
4148 gfc_free_expr (init_expr);
4149 init_expr = NULL;
4150 break;
4152 break;
4154 case BT_COMPLEX:
4155 switch (init_real)
4157 case GFC_INIT_REAL_SNAN:
4158 init_expr->is_snan = 1;
4159 /* Fall through. */
4160 case GFC_INIT_REAL_NAN:
4161 mpfr_set_nan (mpc_realref (init_expr->value.complex));
4162 mpfr_set_nan (mpc_imagref (init_expr->value.complex));
4163 break;
4165 case GFC_INIT_REAL_INF:
4166 mpfr_set_inf (mpc_realref (init_expr->value.complex), 1);
4167 mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1);
4168 break;
4170 case GFC_INIT_REAL_NEG_INF:
4171 mpfr_set_inf (mpc_realref (init_expr->value.complex), -1);
4172 mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1);
4173 break;
4175 case GFC_INIT_REAL_ZERO:
4176 mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE);
4177 break;
4179 default:
4180 gfc_free_expr (init_expr);
4181 init_expr = NULL;
4182 break;
4184 break;
4186 case BT_LOGICAL:
4187 if (init_logical == GFC_INIT_LOGICAL_FALSE)
4188 init_expr->value.logical = 0;
4189 else if (init_logical == GFC_INIT_LOGICAL_TRUE)
4190 init_expr->value.logical = 1;
4191 else
4193 gfc_free_expr (init_expr);
4194 init_expr = NULL;
4196 break;
4198 case BT_CHARACTER:
4199 /* For characters, the length must be constant in order to
4200 create a default initializer. */
4201 if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
4202 && ts->u.cl->length
4203 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
4205 char_len = mpz_get_si (ts->u.cl->length->value.integer);
4206 init_expr->value.character.length = char_len;
4207 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
4208 for (i = 0; i < char_len; i++)
4209 init_expr->value.character.string[i]
4210 = (unsigned char) gfc_option.flag_init_character_value;
4212 else
4214 gfc_free_expr (init_expr);
4215 init_expr = NULL;
4217 if (!init_expr
4218 && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
4219 && ts->u.cl->length && flag_max_stack_var_size != 0)
4221 gfc_actual_arglist *arg;
4222 init_expr = gfc_get_expr ();
4223 init_expr->where = *where;
4224 init_expr->ts = *ts;
4225 init_expr->expr_type = EXPR_FUNCTION;
4226 init_expr->value.function.isym =
4227 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT);
4228 init_expr->value.function.name = "repeat";
4229 arg = gfc_get_actual_arglist ();
4230 arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1);
4231 arg->expr->value.character.string[0] =
4232 gfc_option.flag_init_character_value;
4233 arg->next = gfc_get_actual_arglist ();
4234 arg->next->expr = gfc_copy_expr (ts->u.cl->length);
4235 init_expr->value.function.actual = arg;
4237 break;
4239 default:
4240 gfc_free_expr (init_expr);
4241 init_expr = NULL;
4244 return init_expr;
4247 /* Apply an initialization expression to a typespec. Can be used for symbols or
4248 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4249 combined with some effort. */
4251 void
4252 gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
4254 if (ts->type == BT_CHARACTER && !attr->pointer && init
4255 && ts->u.cl
4256 && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT)
4258 int len;
4260 gcc_assert (ts->u.cl && ts->u.cl->length);
4261 gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT);
4262 gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER);
4264 len = mpz_get_si (ts->u.cl->length->value.integer);
4266 if (init->expr_type == EXPR_CONSTANT)
4267 gfc_set_constant_character_len (len, init, -1);
4268 else if (init
4269 && init->ts.type == BT_CHARACTER
4270 && init->ts.u.cl
4271 && mpz_cmp (ts->u.cl->length->value.integer,
4272 init->ts.u.cl->length->value.integer))
4274 gfc_constructor *ctor;
4275 ctor = gfc_constructor_first (init->value.constructor);
4277 if (ctor)
4279 int first_len;
4280 bool has_ts = (init->ts.u.cl
4281 && init->ts.u.cl->length_from_typespec);
4283 /* Remember the length of the first element for checking
4284 that all elements *in the constructor* have the same
4285 length. This need not be the length of the LHS! */
4286 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
4287 gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
4288 first_len = ctor->expr->value.character.length;
4290 for ( ; ctor; ctor = gfc_constructor_next (ctor))
4291 if (ctor->expr->expr_type == EXPR_CONSTANT)
4293 gfc_set_constant_character_len (len, ctor->expr,
4294 has_ts ? -1 : first_len);
4295 if (!ctor->expr->ts.u.cl)
4296 ctor->expr->ts.u.cl
4297 = gfc_new_charlen (gfc_current_ns, ts->u.cl);
4298 else
4299 ctor->expr->ts.u.cl->length
4300 = gfc_copy_expr (ts->u.cl->length);
4308 /* Check whether an expression is a structure constructor and whether it has
4309 other values than NULL. */
4311 bool
4312 is_non_empty_structure_constructor (gfc_expr * e)
4314 if (e->expr_type != EXPR_STRUCTURE)
4315 return false;
4317 gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
4318 while (cons)
4320 if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
4321 return true;
4322 cons = gfc_constructor_next (cons);
4324 return false;
4328 /* Check for default initializer; sym->value is not enough
4329 as it is also set for EXPR_NULL of allocatables. */
4331 bool
4332 gfc_has_default_initializer (gfc_symbol *der)
4334 gfc_component *c;
4336 gcc_assert (gfc_fl_struct (der->attr.flavor));
4337 for (c = der->components; c; c = c->next)
4338 if (gfc_bt_struct (c->ts.type))
4340 if (!c->attr.pointer && !c->attr.proc_pointer
4341 && !(c->attr.allocatable && der == c->ts.u.derived)
4342 && ((c->initializer
4343 && is_non_empty_structure_constructor (c->initializer))
4344 || gfc_has_default_initializer (c->ts.u.derived)))
4345 return true;
4346 if (c->attr.pointer && c->initializer)
4347 return true;
4349 else
4351 if (c->initializer)
4352 return true;
4355 return false;
4360 Generate an initializer expression which initializes the entirety of a union.
4361 A normal structure constructor is insufficient without undue effort, because
4362 components of maps may be oddly aligned/overlapped. (For example if a
4363 character is initialized from one map overtop a real from the other, only one
4364 byte of the real is actually initialized.) Unfortunately we don't know the
4365 size of the union right now, so we can't generate a proper initializer, but
4366 we use a NULL expr as a placeholder and do the right thing later in
4367 gfc_trans_subcomponent_assign.
4369 static gfc_expr *
4370 generate_union_initializer (gfc_component *un)
4372 if (un == NULL || un->ts.type != BT_UNION)
4373 return NULL;
4375 gfc_expr *placeholder = gfc_get_null_expr (&un->loc);
4376 placeholder->ts = un->ts;
4377 return placeholder;
4381 /* Get the user-specified initializer for a union, if any. This means the user
4382 has said to initialize component(s) of a map. For simplicity's sake we
4383 only allow the user to initialize the first map. We don't have to worry
4384 about overlapping initializers as they are released early in resolution (see
4385 resolve_fl_struct). */
4387 static gfc_expr *
4388 get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
4390 gfc_component *map;
4391 gfc_expr *init=NULL;
4393 if (!union_type || union_type->attr.flavor != FL_UNION)
4394 return NULL;
4396 for (map = union_type->components; map; map = map->next)
4398 if (gfc_has_default_initializer (map->ts.u.derived))
4400 init = gfc_default_initializer (&map->ts);
4401 if (map_p)
4402 *map_p = map;
4403 break;
4407 if (map_p && !init)
4408 *map_p = NULL;
4410 return init;
4413 /* Fetch or generate an initializer for the given component.
4414 Only generate an initializer if generate is true. */
4416 static gfc_expr *
4417 component_initializer (gfc_typespec *ts, gfc_component *c, bool generate)
4419 gfc_expr *init = NULL;
4421 /* See if we can find the initializer immediately.
4422 Some components should never get initializers. */
4423 if (c->initializer || !generate
4424 || (ts->type == BT_CLASS && !c->attr.allocatable)
4425 || c->attr.pointer
4426 || c->attr.class_pointer
4427 || c->attr.proc_pointer)
4428 return c->initializer;
4430 /* Recursively handle derived type components. */
4431 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
4432 init = gfc_generate_initializer (&c->ts, true);
4434 else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
4436 gfc_component *map = NULL;
4437 gfc_constructor *ctor;
4438 gfc_expr *user_init;
4440 /* If we don't have a user initializer and we aren't generating one, this
4441 union has no initializer. */
4442 user_init = get_union_initializer (c->ts.u.derived, &map);
4443 if (!user_init && !generate)
4444 return NULL;
4446 /* Otherwise use a structure constructor. */
4447 init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind,
4448 &c->loc);
4449 init->ts = c->ts;
4451 /* If we are to generate an initializer for the union, add a constructor
4452 which initializes the whole union first. */
4453 if (generate)
4455 ctor = gfc_constructor_get ();
4456 ctor->expr = generate_union_initializer (c);
4457 gfc_constructor_append (&init->value.constructor, ctor);
4460 /* If we found an initializer in one of our maps, apply it. Note this
4461 is applied _after_ the entire-union initializer above if any. */
4462 if (user_init)
4464 ctor = gfc_constructor_get ();
4465 ctor->expr = user_init;
4466 ctor->n.component = map;
4467 gfc_constructor_append (&init->value.constructor, ctor);
4471 /* Treat simple components like locals. */
4472 else
4474 /* We MUST give an initializer, so force generation. */
4475 init = gfc_build_init_expr (&c->ts, &c->loc, true);
4476 gfc_apply_init (&c->ts, &c->attr, init);
4479 return init;
4483 /* Get an expression for a default initializer of a derived type. */
4485 gfc_expr *
4486 gfc_default_initializer (gfc_typespec *ts)
4488 return gfc_generate_initializer (ts, false);
4492 /* Get or generate an expression for a default initializer of a derived type.
4493 If -finit-derived is specified, generate default initialization expressions
4494 for components that lack them when generate is set. */
4496 gfc_expr *
4497 gfc_generate_initializer (gfc_typespec *ts, bool generate)
4499 gfc_expr *init, *tmp;
4500 gfc_component *comp;
4501 generate = flag_init_derived && generate;
4503 /* See if we have a default initializer in this, but not in nested
4504 types (otherwise we could use gfc_has_default_initializer()).
4505 We don't need to check if we are going to generate them. */
4506 comp = ts->u.derived->components;
4507 if (!generate)
4509 for (; comp; comp = comp->next)
4510 if (comp->initializer || comp->attr.allocatable
4511 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
4512 && CLASS_DATA (comp)->attr.allocatable))
4513 break;
4516 if (!comp)
4517 return NULL;
4519 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
4520 &ts->u.derived->declared_at);
4521 init->ts = *ts;
4523 for (comp = ts->u.derived->components; comp; comp = comp->next)
4525 gfc_constructor *ctor = gfc_constructor_get();
4527 /* Fetch or generate an initializer for the component. */
4528 tmp = component_initializer (ts, comp, generate);
4529 if (tmp)
4531 /* Save the component ref for STRUCTUREs and UNIONs. */
4532 if (ts->u.derived->attr.flavor == FL_STRUCT
4533 || ts->u.derived->attr.flavor == FL_UNION)
4534 ctor->n.component = comp;
4536 /* If the initializer was not generated, we need a copy. */
4537 ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
4538 if ((comp->ts.type != tmp->ts.type
4539 || comp->ts.kind != tmp->ts.kind)
4540 && !comp->attr.pointer && !comp->attr.proc_pointer)
4542 bool val;
4543 val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false);
4544 if (val == false)
4545 return NULL;
4549 if (comp->attr.allocatable
4550 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
4552 ctor->expr = gfc_get_expr ();
4553 ctor->expr->expr_type = EXPR_NULL;
4554 ctor->expr->where = init->where;
4555 ctor->expr->ts = comp->ts;
4558 gfc_constructor_append (&init->value.constructor, ctor);
4561 return init;
4565 /* Given a symbol, create an expression node with that symbol as a
4566 variable. If the symbol is array valued, setup a reference of the
4567 whole array. */
4569 gfc_expr *
4570 gfc_get_variable_expr (gfc_symtree *var)
4572 gfc_expr *e;
4574 e = gfc_get_expr ();
4575 e->expr_type = EXPR_VARIABLE;
4576 e->symtree = var;
4577 e->ts = var->n.sym->ts;
4579 if (var->n.sym->attr.flavor != FL_PROCEDURE
4580 && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
4581 || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
4582 && CLASS_DATA (var->n.sym)->as)))
4584 e->rank = var->n.sym->ts.type == BT_CLASS
4585 ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
4586 e->ref = gfc_get_ref ();
4587 e->ref->type = REF_ARRAY;
4588 e->ref->u.ar.type = AR_FULL;
4589 e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS
4590 ? CLASS_DATA (var->n.sym)->as
4591 : var->n.sym->as);
4594 return e;
4598 /* Adds a full array reference to an expression, as needed. */
4600 void
4601 gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as)
4603 gfc_ref *ref;
4604 for (ref = e->ref; ref; ref = ref->next)
4605 if (!ref->next)
4606 break;
4607 if (ref)
4609 ref->next = gfc_get_ref ();
4610 ref = ref->next;
4612 else
4614 e->ref = gfc_get_ref ();
4615 ref = e->ref;
4617 ref->type = REF_ARRAY;
4618 ref->u.ar.type = AR_FULL;
4619 ref->u.ar.dimen = e->rank;
4620 ref->u.ar.where = e->where;
4621 ref->u.ar.as = as;
4625 gfc_expr *
4626 gfc_lval_expr_from_sym (gfc_symbol *sym)
4628 gfc_expr *lval;
4629 gfc_array_spec *as;
4630 lval = gfc_get_expr ();
4631 lval->expr_type = EXPR_VARIABLE;
4632 lval->where = sym->declared_at;
4633 lval->ts = sym->ts;
4634 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
4636 /* It will always be a full array. */
4637 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
4638 lval->rank = as ? as->rank : 0;
4639 if (lval->rank)
4640 gfc_add_full_array_ref (lval, as);
4641 return lval;
4645 /* Returns the array_spec of a full array expression. A NULL is
4646 returned otherwise. */
4647 gfc_array_spec *
4648 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
4650 gfc_array_spec *as;
4651 gfc_ref *ref;
4653 if (expr->rank == 0)
4654 return NULL;
4656 /* Follow any component references. */
4657 if (expr->expr_type == EXPR_VARIABLE
4658 || expr->expr_type == EXPR_CONSTANT)
4660 if (expr->symtree)
4661 as = expr->symtree->n.sym->as;
4662 else
4663 as = NULL;
4665 for (ref = expr->ref; ref; ref = ref->next)
4667 switch (ref->type)
4669 case REF_COMPONENT:
4670 as = ref->u.c.component->as;
4671 continue;
4673 case REF_SUBSTRING:
4674 continue;
4676 case REF_ARRAY:
4678 switch (ref->u.ar.type)
4680 case AR_ELEMENT:
4681 case AR_SECTION:
4682 case AR_UNKNOWN:
4683 as = NULL;
4684 continue;
4686 case AR_FULL:
4687 break;
4689 break;
4694 else
4695 as = NULL;
4697 return as;
4701 /* General expression traversal function. */
4703 bool
4704 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
4705 bool (*func)(gfc_expr *, gfc_symbol *, int*),
4706 int f)
4708 gfc_array_ref ar;
4709 gfc_ref *ref;
4710 gfc_actual_arglist *args;
4711 gfc_constructor *c;
4712 int i;
4714 if (!expr)
4715 return false;
4717 if ((*func) (expr, sym, &f))
4718 return true;
4720 if (expr->ts.type == BT_CHARACTER
4721 && expr->ts.u.cl
4722 && expr->ts.u.cl->length
4723 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
4724 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
4725 return true;
4727 switch (expr->expr_type)
4729 case EXPR_PPC:
4730 case EXPR_COMPCALL:
4731 case EXPR_FUNCTION:
4732 for (args = expr->value.function.actual; args; args = args->next)
4734 if (gfc_traverse_expr (args->expr, sym, func, f))
4735 return true;
4737 break;
4739 case EXPR_VARIABLE:
4740 case EXPR_CONSTANT:
4741 case EXPR_NULL:
4742 case EXPR_SUBSTRING:
4743 break;
4745 case EXPR_STRUCTURE:
4746 case EXPR_ARRAY:
4747 for (c = gfc_constructor_first (expr->value.constructor);
4748 c; c = gfc_constructor_next (c))
4750 if (gfc_traverse_expr (c->expr, sym, func, f))
4751 return true;
4752 if (c->iterator)
4754 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
4755 return true;
4756 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
4757 return true;
4758 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
4759 return true;
4760 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
4761 return true;
4764 break;
4766 case EXPR_OP:
4767 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
4768 return true;
4769 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
4770 return true;
4771 break;
4773 default:
4774 gcc_unreachable ();
4775 break;
4778 ref = expr->ref;
4779 while (ref != NULL)
4781 switch (ref->type)
4783 case REF_ARRAY:
4784 ar = ref->u.ar;
4785 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4787 if (gfc_traverse_expr (ar.start[i], sym, func, f))
4788 return true;
4789 if (gfc_traverse_expr (ar.end[i], sym, func, f))
4790 return true;
4791 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
4792 return true;
4794 break;
4796 case REF_SUBSTRING:
4797 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
4798 return true;
4799 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
4800 return true;
4801 break;
4803 case REF_COMPONENT:
4804 if (ref->u.c.component->ts.type == BT_CHARACTER
4805 && ref->u.c.component->ts.u.cl
4806 && ref->u.c.component->ts.u.cl->length
4807 && ref->u.c.component->ts.u.cl->length->expr_type
4808 != EXPR_CONSTANT
4809 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
4810 sym, func, f))
4811 return true;
4813 if (ref->u.c.component->as)
4814 for (i = 0; i < ref->u.c.component->as->rank
4815 + ref->u.c.component->as->corank; i++)
4817 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
4818 sym, func, f))
4819 return true;
4820 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
4821 sym, func, f))
4822 return true;
4824 break;
4826 default:
4827 gcc_unreachable ();
4829 ref = ref->next;
4831 return false;
4834 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4836 static bool
4837 expr_set_symbols_referenced (gfc_expr *expr,
4838 gfc_symbol *sym ATTRIBUTE_UNUSED,
4839 int *f ATTRIBUTE_UNUSED)
4841 if (expr->expr_type != EXPR_VARIABLE)
4842 return false;
4843 gfc_set_sym_referenced (expr->symtree->n.sym);
4844 return false;
4847 void
4848 gfc_expr_set_symbols_referenced (gfc_expr *expr)
4850 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
4854 /* Determine if an expression is a procedure pointer component and return
4855 the component in that case. Otherwise return NULL. */
4857 gfc_component *
4858 gfc_get_proc_ptr_comp (gfc_expr *expr)
4860 gfc_ref *ref;
4862 if (!expr || !expr->ref)
4863 return NULL;
4865 ref = expr->ref;
4866 while (ref->next)
4867 ref = ref->next;
4869 if (ref->type == REF_COMPONENT
4870 && ref->u.c.component->attr.proc_pointer)
4871 return ref->u.c.component;
4873 return NULL;
4877 /* Determine if an expression is a procedure pointer component. */
4879 bool
4880 gfc_is_proc_ptr_comp (gfc_expr *expr)
4882 return (gfc_get_proc_ptr_comp (expr) != NULL);
4886 /* Determine if an expression is a function with an allocatable class scalar
4887 result. */
4888 bool
4889 gfc_is_alloc_class_scalar_function (gfc_expr *expr)
4891 if (expr->expr_type == EXPR_FUNCTION
4892 && expr->value.function.esym
4893 && expr->value.function.esym->result
4894 && expr->value.function.esym->result->ts.type == BT_CLASS
4895 && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
4896 && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
4897 return true;
4899 return false;
4903 /* Determine if an expression is a function with an allocatable class array
4904 result. */
4905 bool
4906 gfc_is_class_array_function (gfc_expr *expr)
4908 if (expr->expr_type == EXPR_FUNCTION
4909 && expr->value.function.esym
4910 && expr->value.function.esym->result
4911 && expr->value.function.esym->result->ts.type == BT_CLASS
4912 && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
4913 && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable
4914 || CLASS_DATA (expr->value.function.esym->result)->attr.pointer))
4915 return true;
4917 return false;
4921 /* Walk an expression tree and check each variable encountered for being typed.
4922 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4923 mode as is a basic arithmetic expression using those; this is for things in
4924 legacy-code like:
4926 INTEGER :: arr(n), n
4927 INTEGER :: arr(n + 1), n
4929 The namespace is needed for IMPLICIT typing. */
4931 static gfc_namespace* check_typed_ns;
4933 static bool
4934 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4935 int* f ATTRIBUTE_UNUSED)
4937 bool t;
4939 if (e->expr_type != EXPR_VARIABLE)
4940 return false;
4942 gcc_assert (e->symtree);
4943 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
4944 true, e->where);
4946 return (!t);
4949 bool
4950 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
4952 bool error_found;
4954 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4955 to us. */
4956 if (!strict)
4958 if (e->expr_type == EXPR_VARIABLE && !e->ref)
4959 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
4961 if (e->expr_type == EXPR_OP)
4963 bool t = true;
4965 gcc_assert (e->value.op.op1);
4966 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
4968 if (t && e->value.op.op2)
4969 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
4971 return t;
4975 /* Otherwise, walk the expression and do it strictly. */
4976 check_typed_ns = ns;
4977 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
4979 return error_found ? false : true;
4983 /* This function returns true if it contains any references to PDT KIND
4984 or LEN parameters. */
4986 static bool
4987 derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4988 int* f ATTRIBUTE_UNUSED)
4990 if (e->expr_type != EXPR_VARIABLE)
4991 return false;
4993 gcc_assert (e->symtree);
4994 if (e->symtree->n.sym->attr.pdt_kind
4995 || e->symtree->n.sym->attr.pdt_len)
4996 return true;
4998 return false;
5002 bool
5003 gfc_derived_parameter_expr (gfc_expr *e)
5005 return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0);
5009 /* This function returns the overall type of a type parameter spec list.
5010 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5011 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5012 unless derived is not NULL. In this latter case, all the LEN parameters
5013 must be either assumed or deferred for the return argument to be set to
5014 anything other than SPEC_EXPLICIT. */
5016 gfc_param_spec_type
5017 gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
5019 gfc_param_spec_type res = SPEC_EXPLICIT;
5020 gfc_component *c;
5021 bool seen_assumed = false;
5022 bool seen_deferred = false;
5024 if (derived == NULL)
5026 for (; param_list; param_list = param_list->next)
5027 if (param_list->spec_type == SPEC_ASSUMED
5028 || param_list->spec_type == SPEC_DEFERRED)
5029 return param_list->spec_type;
5031 else
5033 for (; param_list; param_list = param_list->next)
5035 c = gfc_find_component (derived, param_list->name,
5036 true, true, NULL);
5037 gcc_assert (c != NULL);
5038 if (c->attr.pdt_kind)
5039 continue;
5040 else if (param_list->spec_type == SPEC_EXPLICIT)
5041 return SPEC_EXPLICIT;
5042 seen_assumed = param_list->spec_type == SPEC_ASSUMED;
5043 seen_deferred = param_list->spec_type == SPEC_DEFERRED;
5044 if (seen_assumed && seen_deferred)
5045 return SPEC_EXPLICIT;
5047 res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
5049 return res;
5053 bool
5054 gfc_ref_this_image (gfc_ref *ref)
5056 int n;
5058 gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
5060 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
5061 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
5062 return false;
5064 return true;
5067 gfc_expr *
5068 gfc_find_stat_co(gfc_expr *e)
5070 gfc_ref *ref;
5072 for (ref = e->ref; ref; ref = ref->next)
5073 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5074 return ref->u.ar.stat;
5076 if (e->value.function.actual->expr)
5077 for (ref = e->value.function.actual->expr->ref; ref;
5078 ref = ref->next)
5079 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5080 return ref->u.ar.stat;
5082 return NULL;
5085 bool
5086 gfc_is_coindexed (gfc_expr *e)
5088 gfc_ref *ref;
5090 for (ref = e->ref; ref; ref = ref->next)
5091 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
5092 return !gfc_ref_this_image (ref);
5094 return false;
5098 /* Coarrays are variables with a corank but not being coindexed. However, also
5099 the following is a coarray: A subobject of a coarray is a coarray if it does
5100 not have any cosubscripts, vector subscripts, allocatable component
5101 selection, or pointer component selection. (F2008, 2.4.7) */
5103 bool
5104 gfc_is_coarray (gfc_expr *e)
5106 gfc_ref *ref;
5107 gfc_symbol *sym;
5108 gfc_component *comp;
5109 bool coindexed;
5110 bool coarray;
5111 int i;
5113 if (e->expr_type != EXPR_VARIABLE)
5114 return false;
5116 coindexed = false;
5117 sym = e->symtree->n.sym;
5119 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
5120 coarray = CLASS_DATA (sym)->attr.codimension;
5121 else
5122 coarray = sym->attr.codimension;
5124 for (ref = e->ref; ref; ref = ref->next)
5125 switch (ref->type)
5127 case REF_COMPONENT:
5128 comp = ref->u.c.component;
5129 if (comp->ts.type == BT_CLASS && comp->attr.class_ok
5130 && (CLASS_DATA (comp)->attr.class_pointer
5131 || CLASS_DATA (comp)->attr.allocatable))
5133 coindexed = false;
5134 coarray = CLASS_DATA (comp)->attr.codimension;
5136 else if (comp->attr.pointer || comp->attr.allocatable)
5138 coindexed = false;
5139 coarray = comp->attr.codimension;
5141 break;
5143 case REF_ARRAY:
5144 if (!coarray)
5145 break;
5147 if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
5149 coindexed = true;
5150 break;
5153 for (i = 0; i < ref->u.ar.dimen; i++)
5154 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5156 coarray = false;
5157 break;
5159 break;
5161 case REF_SUBSTRING:
5162 break;
5165 return coarray && !coindexed;
5170 gfc_get_corank (gfc_expr *e)
5172 int corank;
5173 gfc_ref *ref;
5175 if (!gfc_is_coarray (e))
5176 return 0;
5178 if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
5179 corank = e->ts.u.derived->components->as
5180 ? e->ts.u.derived->components->as->corank : 0;
5181 else
5182 corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
5184 for (ref = e->ref; ref; ref = ref->next)
5186 if (ref->type == REF_ARRAY)
5187 corank = ref->u.ar.as->corank;
5188 gcc_assert (ref->type != REF_SUBSTRING);
5191 return corank;
5195 /* Check whether the expression has an ultimate allocatable component.
5196 Being itself allocatable does not count. */
5197 bool
5198 gfc_has_ultimate_allocatable (gfc_expr *e)
5200 gfc_ref *ref, *last = NULL;
5202 if (e->expr_type != EXPR_VARIABLE)
5203 return false;
5205 for (ref = e->ref; ref; ref = ref->next)
5206 if (ref->type == REF_COMPONENT)
5207 last = ref;
5209 if (last && last->u.c.component->ts.type == BT_CLASS)
5210 return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
5211 else if (last && last->u.c.component->ts.type == BT_DERIVED)
5212 return last->u.c.component->ts.u.derived->attr.alloc_comp;
5213 else if (last)
5214 return false;
5216 if (e->ts.type == BT_CLASS)
5217 return CLASS_DATA (e)->attr.alloc_comp;
5218 else if (e->ts.type == BT_DERIVED)
5219 return e->ts.u.derived->attr.alloc_comp;
5220 else
5221 return false;
5225 /* Check whether the expression has an pointer component.
5226 Being itself a pointer does not count. */
5227 bool
5228 gfc_has_ultimate_pointer (gfc_expr *e)
5230 gfc_ref *ref, *last = NULL;
5232 if (e->expr_type != EXPR_VARIABLE)
5233 return false;
5235 for (ref = e->ref; ref; ref = ref->next)
5236 if (ref->type == REF_COMPONENT)
5237 last = ref;
5239 if (last && last->u.c.component->ts.type == BT_CLASS)
5240 return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
5241 else if (last && last->u.c.component->ts.type == BT_DERIVED)
5242 return last->u.c.component->ts.u.derived->attr.pointer_comp;
5243 else if (last)
5244 return false;
5246 if (e->ts.type == BT_CLASS)
5247 return CLASS_DATA (e)->attr.pointer_comp;
5248 else if (e->ts.type == BT_DERIVED)
5249 return e->ts.u.derived->attr.pointer_comp;
5250 else
5251 return false;
5255 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5256 Note: A scalar is not regarded as "simply contiguous" by the standard.
5257 if bool is not strict, some further checks are done - for instance,
5258 a "(::1)" is accepted. */
5260 bool
5261 gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
5263 bool colon;
5264 int i;
5265 gfc_array_ref *ar = NULL;
5266 gfc_ref *ref, *part_ref = NULL;
5267 gfc_symbol *sym;
5269 if (expr->expr_type == EXPR_FUNCTION)
5271 if (expr->value.function.esym)
5272 return expr->value.function.esym->result->attr.contiguous;
5273 else
5275 /* We have to jump through some hoops if this is a vtab entry. */
5276 gfc_symbol *s;
5277 gfc_ref *r, *rc;
5279 s = expr->symtree->n.sym;
5280 if (s->ts.type != BT_CLASS)
5281 return false;
5283 rc = NULL;
5284 for (r = expr->ref; r; r = r->next)
5285 if (r->type == REF_COMPONENT)
5286 rc = r;
5288 if (rc == NULL || rc->u.c.component == NULL
5289 || rc->u.c.component->ts.interface == NULL)
5290 return false;
5292 return rc->u.c.component->ts.interface->attr.contiguous;
5295 else if (expr->expr_type != EXPR_VARIABLE)
5296 return false;
5298 if (!permit_element && expr->rank == 0)
5299 return false;
5301 for (ref = expr->ref; ref; ref = ref->next)
5303 if (ar)
5304 return false; /* Array shall be last part-ref. */
5306 if (ref->type == REF_COMPONENT)
5307 part_ref = ref;
5308 else if (ref->type == REF_SUBSTRING)
5309 return false;
5310 else if (ref->u.ar.type != AR_ELEMENT)
5311 ar = &ref->u.ar;
5314 sym = expr->symtree->n.sym;
5315 if (expr->ts.type != BT_CLASS
5316 && ((part_ref
5317 && !part_ref->u.c.component->attr.contiguous
5318 && part_ref->u.c.component->attr.pointer)
5319 || (!part_ref
5320 && !sym->attr.contiguous
5321 && (sym->attr.pointer
5322 || (sym->as && sym->as->type == AS_ASSUMED_RANK)
5323 || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))))
5324 return false;
5326 if (!ar || ar->type == AR_FULL)
5327 return true;
5329 gcc_assert (ar->type == AR_SECTION);
5331 /* Check for simply contiguous array */
5332 colon = true;
5333 for (i = 0; i < ar->dimen; i++)
5335 if (ar->dimen_type[i] == DIMEN_VECTOR)
5336 return false;
5338 if (ar->dimen_type[i] == DIMEN_ELEMENT)
5340 colon = false;
5341 continue;
5344 gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
5347 /* If the previous section was not contiguous, that's an error,
5348 unless we have effective only one element and checking is not
5349 strict. */
5350 if (!colon && (strict || !ar->start[i] || !ar->end[i]
5351 || ar->start[i]->expr_type != EXPR_CONSTANT
5352 || ar->end[i]->expr_type != EXPR_CONSTANT
5353 || mpz_cmp (ar->start[i]->value.integer,
5354 ar->end[i]->value.integer) != 0))
5355 return false;
5357 /* Following the standard, "(::1)" or - if known at compile time -
5358 "(lbound:ubound)" are not simply contiguous; if strict
5359 is false, they are regarded as simply contiguous. */
5360 if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
5361 || ar->stride[i]->ts.type != BT_INTEGER
5362 || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
5363 return false;
5365 if (ar->start[i]
5366 && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
5367 || !ar->as->lower[i]
5368 || ar->as->lower[i]->expr_type != EXPR_CONSTANT
5369 || mpz_cmp (ar->start[i]->value.integer,
5370 ar->as->lower[i]->value.integer) != 0))
5371 colon = false;
5373 if (ar->end[i]
5374 && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
5375 || !ar->as->upper[i]
5376 || ar->as->upper[i]->expr_type != EXPR_CONSTANT
5377 || mpz_cmp (ar->end[i]->value.integer,
5378 ar->as->upper[i]->value.integer) != 0))
5379 colon = false;
5382 return true;
5386 /* Build call to an intrinsic procedure. The number of arguments has to be
5387 passed (rather than ending the list with a NULL value) because we may
5388 want to add arguments but with a NULL-expression. */
5390 gfc_expr*
5391 gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
5392 locus where, unsigned numarg, ...)
5394 gfc_expr* result;
5395 gfc_actual_arglist* atail;
5396 gfc_intrinsic_sym* isym;
5397 va_list ap;
5398 unsigned i;
5399 const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
5401 isym = gfc_intrinsic_function_by_id (id);
5402 gcc_assert (isym);
5404 result = gfc_get_expr ();
5405 result->expr_type = EXPR_FUNCTION;
5406 result->ts = isym->ts;
5407 result->where = where;
5408 result->value.function.name = mangled_name;
5409 result->value.function.isym = isym;
5411 gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
5412 gfc_commit_symbol (result->symtree->n.sym);
5413 gcc_assert (result->symtree
5414 && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
5415 || result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
5416 result->symtree->n.sym->intmod_sym_id = id;
5417 result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5418 result->symtree->n.sym->attr.intrinsic = 1;
5419 result->symtree->n.sym->attr.artificial = 1;
5421 va_start (ap, numarg);
5422 atail = NULL;
5423 for (i = 0; i < numarg; ++i)
5425 if (atail)
5427 atail->next = gfc_get_actual_arglist ();
5428 atail = atail->next;
5430 else
5431 atail = result->value.function.actual = gfc_get_actual_arglist ();
5433 atail->expr = va_arg (ap, gfc_expr*);
5435 va_end (ap);
5437 return result;
5441 /* Check if an expression may appear in a variable definition context
5442 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5443 This is called from the various places when resolving
5444 the pieces that make up such a context.
5445 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5446 variables), some checks are not performed.
5448 Optionally, a possible error message can be suppressed if context is NULL
5449 and just the return status (true / false) be requested. */
5451 bool
5452 gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
5453 bool own_scope, const char* context)
5455 gfc_symbol* sym = NULL;
5456 bool is_pointer;
5457 bool check_intentin;
5458 bool ptr_component;
5459 symbol_attribute attr;
5460 gfc_ref* ref;
5461 int i;
5463 if (e->expr_type == EXPR_VARIABLE)
5465 gcc_assert (e->symtree);
5466 sym = e->symtree->n.sym;
5468 else if (e->expr_type == EXPR_FUNCTION)
5470 gcc_assert (e->symtree);
5471 sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
5474 attr = gfc_expr_attr (e);
5475 if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
5477 if (!(gfc_option.allow_std & GFC_STD_F2008))
5479 if (context)
5480 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5481 " context (%s) at %L", context, &e->where);
5482 return false;
5485 else if (e->expr_type != EXPR_VARIABLE)
5487 if (context)
5488 gfc_error ("Non-variable expression in variable definition context (%s)"
5489 " at %L", context, &e->where);
5490 return false;
5493 if (!pointer && sym->attr.flavor == FL_PARAMETER)
5495 if (context)
5496 gfc_error ("Named constant %qs in variable definition context (%s)"
5497 " at %L", sym->name, context, &e->where);
5498 return false;
5500 if (!pointer && sym->attr.flavor != FL_VARIABLE
5501 && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
5502 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
5504 if (context)
5505 gfc_error ("%qs in variable definition context (%s) at %L is not"
5506 " a variable", sym->name, context, &e->where);
5507 return false;
5510 /* Find out whether the expr is a pointer; this also means following
5511 component references to the last one. */
5512 is_pointer = (attr.pointer || attr.proc_pointer);
5513 if (pointer && !is_pointer)
5515 if (context)
5516 gfc_error ("Non-POINTER in pointer association context (%s)"
5517 " at %L", context, &e->where);
5518 return false;
5521 if (e->ts.type == BT_DERIVED
5522 && e->ts.u.derived == NULL)
5524 if (context)
5525 gfc_error ("Type inaccessible in variable definition context (%s) "
5526 "at %L", context, &e->where);
5527 return false;
5530 /* F2008, C1303. */
5531 if (!alloc_obj
5532 && (attr.lock_comp
5533 || (e->ts.type == BT_DERIVED
5534 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5535 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
5537 if (context)
5538 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5539 context, &e->where);
5540 return false;
5543 /* TS18508, C702/C203. */
5544 if (!alloc_obj
5545 && (attr.lock_comp
5546 || (e->ts.type == BT_DERIVED
5547 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5548 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
5550 if (context)
5551 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5552 context, &e->where);
5553 return false;
5556 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5557 component of sub-component of a pointer; we need to distinguish
5558 assignment to a pointer component from pointer-assignment to a pointer
5559 component. Note that (normal) assignment to procedure pointers is not
5560 possible. */
5561 check_intentin = !own_scope;
5562 ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived
5563 && CLASS_DATA (sym))
5564 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
5565 for (ref = e->ref; ref && check_intentin; ref = ref->next)
5567 if (ptr_component && ref->type == REF_COMPONENT)
5568 check_intentin = false;
5569 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
5571 ptr_component = true;
5572 if (!pointer)
5573 check_intentin = false;
5576 if (check_intentin && sym->attr.intent == INTENT_IN)
5578 if (pointer && is_pointer)
5580 if (context)
5581 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5582 " association context (%s) at %L",
5583 sym->name, context, &e->where);
5584 return false;
5586 if (!pointer && !is_pointer && !sym->attr.pointer)
5588 if (context)
5589 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5590 " definition context (%s) at %L",
5591 sym->name, context, &e->where);
5592 return false;
5596 /* PROTECTED and use-associated. */
5597 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
5599 if (pointer && is_pointer)
5601 if (context)
5602 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5603 " pointer association context (%s) at %L",
5604 sym->name, context, &e->where);
5605 return false;
5607 if (!pointer && !is_pointer)
5609 if (context)
5610 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5611 " variable definition context (%s) at %L",
5612 sym->name, context, &e->where);
5613 return false;
5617 /* Variable not assignable from a PURE procedure but appears in
5618 variable definition context. */
5619 if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
5621 if (context)
5622 gfc_error ("Variable %qs can not appear in a variable definition"
5623 " context (%s) at %L in PURE procedure",
5624 sym->name, context, &e->where);
5625 return false;
5628 if (!pointer && context && gfc_implicit_pure (NULL)
5629 && gfc_impure_variable (sym))
5631 gfc_namespace *ns;
5632 gfc_symbol *sym;
5634 for (ns = gfc_current_ns; ns; ns = ns->parent)
5636 sym = ns->proc_name;
5637 if (sym == NULL)
5638 break;
5639 if (sym->attr.flavor == FL_PROCEDURE)
5641 sym->attr.implicit_pure = 0;
5642 break;
5646 /* Check variable definition context for associate-names. */
5647 if (!pointer && sym->assoc)
5649 const char* name;
5650 gfc_association_list* assoc;
5652 gcc_assert (sym->assoc->target);
5654 /* If this is a SELECT TYPE temporary (the association is used internally
5655 for SELECT TYPE), silently go over to the target. */
5656 if (sym->attr.select_type_temporary)
5658 gfc_expr* t = sym->assoc->target;
5660 gcc_assert (t->expr_type == EXPR_VARIABLE);
5661 name = t->symtree->name;
5663 if (t->symtree->n.sym->assoc)
5664 assoc = t->symtree->n.sym->assoc;
5665 else
5666 assoc = sym->assoc;
5668 else
5670 name = sym->name;
5671 assoc = sym->assoc;
5673 gcc_assert (name && assoc);
5675 /* Is association to a valid variable? */
5676 if (!assoc->variable)
5678 if (context)
5680 if (assoc->target->expr_type == EXPR_VARIABLE)
5681 gfc_error ("%qs at %L associated to vector-indexed target can"
5682 " not be used in a variable definition context (%s)",
5683 name, &e->where, context);
5684 else
5685 gfc_error ("%qs at %L associated to expression can"
5686 " not be used in a variable definition context (%s)",
5687 name, &e->where, context);
5689 return false;
5692 /* Target must be allowed to appear in a variable definition context. */
5693 if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
5695 if (context)
5696 gfc_error ("Associate-name %qs can not appear in a variable"
5697 " definition context (%s) at %L because its target"
5698 " at %L can not, either",
5699 name, context, &e->where,
5700 &assoc->target->where);
5701 return false;
5705 /* Check for same value in vector expression subscript. */
5707 if (e->rank > 0)
5708 for (ref = e->ref; ref != NULL; ref = ref->next)
5709 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
5710 for (i = 0; i < GFC_MAX_DIMENSIONS
5711 && ref->u.ar.dimen_type[i] != 0; i++)
5712 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
5714 gfc_expr *arr = ref->u.ar.start[i];
5715 if (arr->expr_type == EXPR_ARRAY)
5717 gfc_constructor *c, *n;
5718 gfc_expr *ec, *en;
5720 for (c = gfc_constructor_first (arr->value.constructor);
5721 c != NULL; c = gfc_constructor_next (c))
5723 if (c == NULL || c->iterator != NULL)
5724 continue;
5726 ec = c->expr;
5728 for (n = gfc_constructor_next (c); n != NULL;
5729 n = gfc_constructor_next (n))
5731 if (n->iterator != NULL)
5732 continue;
5734 en = n->expr;
5735 if (gfc_dep_compare_expr (ec, en) == 0)
5737 if (context)
5738 gfc_error_now ("Elements with the same value "
5739 "at %L and %L in vector "
5740 "subscript in a variable "
5741 "definition context (%s)",
5742 &(ec->where), &(en->where),
5743 context);
5744 return false;
5751 return true;