1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
27 #include "target-memory.h" /* for gfc_convert_boz */
29 /* Get a new expr node. */
37 gfc_clear_ts (&e->ts);
41 e->con_by_offset = NULL;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist *a1)
51 gfc_actual_arglist *a2;
56 gfc_free_expr (a1->expr);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist *p)
68 gfc_actual_arglist *head, *tail, *new_arg;
72 for (; p; p = p->next)
74 new_arg = gfc_get_actual_arglist ();
77 new_arg->expr = gfc_copy_expr (p->expr);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref *p)
107 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
109 gfc_free_expr (p->u.ar.start[i]);
110 gfc_free_expr (p->u.ar.end[i]);
111 gfc_free_expr (p->u.ar.stride[i]);
117 gfc_free_expr (p->u.ss.start);
118 gfc_free_expr (p->u.ss.end);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr *e)
140 switch (e->expr_type)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e->value.integer);
151 mpfr_clear (e->value.real);
155 gfc_free (e->value.character.string);
159 mpfr_clear (e->value.complex.r);
160 mpfr_clear (e->value.complex.i);
167 /* Free the representation. */
168 if (e->representation.string)
169 gfc_free (e->representation.string);
174 if (e->value.op.op1 != NULL)
175 gfc_free_expr (e->value.op.op1);
176 if (e->value.op.op2 != NULL)
177 gfc_free_expr (e->value.op.op2);
181 gfc_free_actual_arglist (e->value.function.actual);
185 gfc_free_actual_arglist (e->value.compcall.actual);
193 gfc_free_constructor (e->value.constructor);
197 gfc_free (e->value.character.string);
204 gfc_internal_error ("free_expr0(): Bad expr type");
207 /* Free a shape array. */
208 if (e->shape != NULL)
210 for (n = 0; n < e->rank; n++)
211 mpz_clear (e->shape[n]);
216 gfc_free_ref_list (e->ref);
218 memset (e, '\0', sizeof (gfc_expr));
222 /* Free an expression node and everything beneath it. */
225 gfc_free_expr (gfc_expr *e)
229 if (e->con_by_offset)
230 splay_tree_delete (e->con_by_offset);
236 /* Graft the *src expression onto the *dest subexpression. */
239 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
247 /* Try to extract an integer constant from the passed expression node.
248 Returns an error message or NULL if the result is set. It is
249 tempting to generate an error and return SUCCESS or FAILURE, but
250 failure is OK for some callers. */
253 gfc_extract_int (gfc_expr *expr, int *result)
255 if (expr->expr_type != EXPR_CONSTANT)
256 return _("Constant expression required at %C");
258 if (expr->ts.type != BT_INTEGER)
259 return _("Integer expression required at %C");
261 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
262 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
264 return _("Integer value too large in expression at %C");
267 *result = (int) mpz_get_si (expr->value.integer);
273 /* Recursively copy a list of reference structures. */
276 gfc_copy_ref (gfc_ref *src)
284 dest = gfc_get_ref ();
285 dest->type = src->type;
290 ar = gfc_copy_array_ref (&src->u.ar);
296 dest->u.c = src->u.c;
300 dest->u.ss = src->u.ss;
301 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
302 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
306 dest->next = gfc_copy_ref (src->next);
312 /* Detect whether an expression has any vector index array references. */
315 gfc_has_vector_index (gfc_expr *e)
319 for (ref = e->ref; ref; ref = ref->next)
320 if (ref->type == REF_ARRAY)
321 for (i = 0; i < ref->u.ar.dimen; i++)
322 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
328 /* Copy a shape array. */
331 gfc_copy_shape (mpz_t *shape, int rank)
339 new_shape = gfc_get_shape (rank);
341 for (n = 0; n < rank; n++)
342 mpz_init_set (new_shape[n], shape[n]);
348 /* Copy a shape array excluding dimension N, where N is an integer
349 constant expression. Dimensions are numbered in fortran style --
352 So, if the original shape array contains R elements
353 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
354 the result contains R-1 elements:
355 { s1 ... sN-1 sN+1 ... sR-1}
357 If anything goes wrong -- N is not a constant, its value is out
358 of range -- or anything else, just returns NULL. */
361 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
363 mpz_t *new_shape, *s;
369 || dim->expr_type != EXPR_CONSTANT
370 || dim->ts.type != BT_INTEGER)
373 n = mpz_get_si (dim->value.integer);
374 n--; /* Convert to zero based index. */
375 if (n < 0 || n >= rank)
378 s = new_shape = gfc_get_shape (rank - 1);
380 for (i = 0; i < rank; i++)
384 mpz_init_set (*s, shape[i]);
392 /* Given an expression pointer, return a copy of the expression. This
393 subroutine is recursive. */
396 gfc_copy_expr (gfc_expr *p)
408 switch (q->expr_type)
411 s = gfc_get_wide_string (p->value.character.length + 1);
412 q->value.character.string = s;
413 memcpy (s, p->value.character.string,
414 (p->value.character.length + 1) * sizeof (gfc_char_t));
418 /* Copy target representation, if it exists. */
419 if (p->representation.string)
421 c = XCNEWVEC (char, p->representation.length + 1);
422 q->representation.string = c;
423 memcpy (c, p->representation.string, (p->representation.length + 1));
426 /* Copy the values of any pointer components of p->value. */
430 mpz_init_set (q->value.integer, p->value.integer);
434 gfc_set_model_kind (q->ts.kind);
435 mpfr_init (q->value.real);
436 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
440 gfc_set_model_kind (q->ts.kind);
441 mpfr_init (q->value.complex.r);
442 mpfr_init (q->value.complex.i);
443 mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
444 mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
448 if (p->representation.string)
449 q->value.character.string
450 = gfc_char_to_widechar (q->representation.string);
453 s = gfc_get_wide_string (p->value.character.length + 1);
454 q->value.character.string = s;
456 /* This is the case for the C_NULL_CHAR named constant. */
457 if (p->value.character.length == 0
458 && (p->ts.is_c_interop || p->ts.is_iso_c))
461 /* Need to set the length to 1 to make sure the NUL
462 terminator is copied. */
463 q->value.character.length = 1;
466 memcpy (s, p->value.character.string,
467 (p->value.character.length + 1) * sizeof (gfc_char_t));
474 break; /* Already done. */
478 /* Should never be reached. */
480 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
487 switch (q->value.op.op)
490 case INTRINSIC_PARENTHESES:
491 case INTRINSIC_UPLUS:
492 case INTRINSIC_UMINUS:
493 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
496 default: /* Binary operators. */
497 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
498 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
505 q->value.function.actual =
506 gfc_copy_actual_arglist (p->value.function.actual);
510 q->value.compcall.actual =
511 gfc_copy_actual_arglist (p->value.compcall.actual);
512 q->value.compcall.tbp = p->value.compcall.tbp;
517 q->value.constructor = gfc_copy_constructor (p->value.constructor);
525 q->shape = gfc_copy_shape (p->shape, p->rank);
527 q->ref = gfc_copy_ref (p->ref);
533 /* Return the maximum kind of two expressions. In general, higher
534 kind numbers mean more precision for numeric types. */
537 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
539 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
543 /* Returns nonzero if the type is numeric, zero otherwise. */
546 numeric_type (bt type)
548 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
552 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
555 gfc_numeric_ts (gfc_typespec *ts)
557 return numeric_type (ts->type);
561 /* Returns an expression node that is an integer constant. */
570 p->expr_type = EXPR_CONSTANT;
571 p->ts.type = BT_INTEGER;
572 p->ts.kind = gfc_default_integer_kind;
574 p->where = gfc_current_locus;
575 mpz_init_set_si (p->value.integer, i);
581 /* Returns an expression node that is a logical constant. */
584 gfc_logical_expr (int i, locus *where)
590 p->expr_type = EXPR_CONSTANT;
591 p->ts.type = BT_LOGICAL;
592 p->ts.kind = gfc_default_logical_kind;
595 where = &gfc_current_locus;
597 p->value.logical = i;
603 /* Return an expression node with an optional argument list attached.
604 A variable number of gfc_expr pointers are strung together in an
605 argument list with a NULL pointer terminating the list. */
608 gfc_build_conversion (gfc_expr *e)
613 p->expr_type = EXPR_FUNCTION;
615 p->value.function.actual = NULL;
617 p->value.function.actual = gfc_get_actual_arglist ();
618 p->value.function.actual->expr = e;
624 /* Given an expression node with some sort of numeric binary
625 expression, insert type conversions required to make the operands
628 The exception is that the operands of an exponential don't have to
629 have the same type. If possible, the base is promoted to the type
630 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
631 1.0**2 stays as it is. */
634 gfc_type_convert_binary (gfc_expr *e)
638 op1 = e->value.op.op1;
639 op2 = e->value.op.op2;
641 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
643 gfc_clear_ts (&e->ts);
647 /* Kind conversions of same type. */
648 if (op1->ts.type == op2->ts.type)
650 if (op1->ts.kind == op2->ts.kind)
652 /* No type conversions. */
657 if (op1->ts.kind > op2->ts.kind)
658 gfc_convert_type (op2, &op1->ts, 2);
660 gfc_convert_type (op1, &op2->ts, 2);
666 /* Integer combined with real or complex. */
667 if (op2->ts.type == BT_INTEGER)
671 /* Special case for ** operator. */
672 if (e->value.op.op == INTRINSIC_POWER)
675 gfc_convert_type (e->value.op.op2, &e->ts, 2);
679 if (op1->ts.type == BT_INTEGER)
682 gfc_convert_type (e->value.op.op1, &e->ts, 2);
686 /* Real combined with complex. */
687 e->ts.type = BT_COMPLEX;
688 if (op1->ts.kind > op2->ts.kind)
689 e->ts.kind = op1->ts.kind;
691 e->ts.kind = op2->ts.kind;
692 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
693 gfc_convert_type (e->value.op.op1, &e->ts, 2);
694 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
695 gfc_convert_type (e->value.op.op2, &e->ts, 2);
703 check_specification_function (gfc_expr *e)
710 sym = e->symtree->n.sym;
712 /* F95, 7.1.6.2; F2003, 7.1.7 */
714 && sym->attr.function
716 && !sym->attr.intrinsic
717 && !sym->attr.recursive
718 && sym->attr.proc != PROC_INTERNAL
719 && sym->attr.proc != PROC_ST_FUNCTION
720 && sym->attr.proc != PROC_UNKNOWN
721 && sym->formal == NULL)
727 /* Function to determine if an expression is constant or not. This
728 function expects that the expression has already been simplified. */
731 gfc_is_constant_expr (gfc_expr *e)
734 gfc_actual_arglist *arg;
740 switch (e->expr_type)
743 rv = (gfc_is_constant_expr (e->value.op.op1)
744 && (e->value.op.op2 == NULL
745 || gfc_is_constant_expr (e->value.op.op2)));
753 /* Specification functions are constant. */
754 if (check_specification_function (e) == MATCH_YES)
760 /* Call to intrinsic with at least one argument. */
762 if (e->value.function.isym && e->value.function.actual)
764 for (arg = e->value.function.actual; arg; arg = arg->next)
766 if (!gfc_is_constant_expr (arg->expr))
780 rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
781 && gfc_is_constant_expr (e->ref->u.ss.end));
786 for (c = e->value.constructor; c; c = c->next)
787 if (!gfc_is_constant_expr (c->expr))
795 rv = gfc_constant_ac (e);
799 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
806 /* Is true if an array reference is followed by a component or substring
809 is_subref_array (gfc_expr * e)
814 if (e->expr_type != EXPR_VARIABLE)
817 if (e->symtree->n.sym->attr.subref_array_pointer)
821 for (ref = e->ref; ref; ref = ref->next)
823 if (ref->type == REF_ARRAY
824 && ref->u.ar.type != AR_ELEMENT)
828 && ref->type != REF_ARRAY)
835 /* Try to collapse intrinsic expressions. */
838 simplify_intrinsic_op (gfc_expr *p, int type)
841 gfc_expr *op1, *op2, *result;
843 if (p->value.op.op == INTRINSIC_USER)
846 op1 = p->value.op.op1;
847 op2 = p->value.op.op2;
850 if (gfc_simplify_expr (op1, type) == FAILURE)
852 if (gfc_simplify_expr (op2, type) == FAILURE)
855 if (!gfc_is_constant_expr (op1)
856 || (op2 != NULL && !gfc_is_constant_expr (op2)))
860 p->value.op.op1 = NULL;
861 p->value.op.op2 = NULL;
865 case INTRINSIC_PARENTHESES:
866 result = gfc_parentheses (op1);
869 case INTRINSIC_UPLUS:
870 result = gfc_uplus (op1);
873 case INTRINSIC_UMINUS:
874 result = gfc_uminus (op1);
878 result = gfc_add (op1, op2);
881 case INTRINSIC_MINUS:
882 result = gfc_subtract (op1, op2);
885 case INTRINSIC_TIMES:
886 result = gfc_multiply (op1, op2);
889 case INTRINSIC_DIVIDE:
890 result = gfc_divide (op1, op2);
893 case INTRINSIC_POWER:
894 result = gfc_power (op1, op2);
897 case INTRINSIC_CONCAT:
898 result = gfc_concat (op1, op2);
902 case INTRINSIC_EQ_OS:
903 result = gfc_eq (op1, op2, op);
907 case INTRINSIC_NE_OS:
908 result = gfc_ne (op1, op2, op);
912 case INTRINSIC_GT_OS:
913 result = gfc_gt (op1, op2, op);
917 case INTRINSIC_GE_OS:
918 result = gfc_ge (op1, op2, op);
922 case INTRINSIC_LT_OS:
923 result = gfc_lt (op1, op2, op);
927 case INTRINSIC_LE_OS:
928 result = gfc_le (op1, op2, op);
932 result = gfc_not (op1);
936 result = gfc_and (op1, op2);
940 result = gfc_or (op1, op2);
944 result = gfc_eqv (op1, op2);
948 result = gfc_neqv (op1, op2);
952 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
962 result->rank = p->rank;
963 result->where = p->where;
964 gfc_replace_expr (p, result);
970 /* Subroutine to simplify constructor expressions. Mutually recursive
971 with gfc_simplify_expr(). */
974 simplify_constructor (gfc_constructor *c, int type)
978 for (; c; c = c->next)
981 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
982 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
983 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
988 /* Try and simplify a copy. Replace the original if successful
989 but keep going through the constructor at all costs. Not
990 doing so can make a dog's dinner of complicated things. */
991 p = gfc_copy_expr (c->expr);
993 if (gfc_simplify_expr (p, type) == FAILURE)
999 gfc_replace_expr (c->expr, p);
1007 /* Pull a single array element out of an array constructor. */
1010 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
1011 gfc_constructor **rval)
1013 unsigned long nelemen;
1025 mpz_init_set_ui (offset, 0);
1028 mpz_init_set_ui (span, 1);
1029 for (i = 0; i < ar->dimen; i++)
1031 if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1032 || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1039 e = gfc_copy_expr (ar->start[i]);
1040 if (e->expr_type != EXPR_CONSTANT)
1046 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1047 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1049 /* Check the bounds. */
1050 if ((ar->as->upper[i]
1051 && mpz_cmp (e->value.integer,
1052 ar->as->upper[i]->value.integer) > 0)
1053 || (mpz_cmp (e->value.integer,
1054 ar->as->lower[i]->value.integer) < 0))
1056 gfc_error ("Index in dimension %d is out of bounds "
1057 "at %L", i + 1, &ar->c_where[i]);
1063 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1064 mpz_mul (delta, delta, span);
1065 mpz_add (offset, offset, delta);
1067 mpz_set_ui (tmp, 1);
1068 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1069 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1070 mpz_mul (span, span, tmp);
1073 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1098 /* Find a component of a structure constructor. */
1100 static gfc_constructor *
1101 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1103 gfc_component *comp;
1104 gfc_component *pick;
1106 comp = ref->u.c.sym->components;
1107 pick = ref->u.c.component;
1108 while (comp != pick)
1118 /* Replace an expression with the contents of a constructor, removing
1119 the subobject reference in the process. */
1122 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1128 e->ref = p->ref->next;
1129 p->ref->next = NULL;
1130 gfc_replace_expr (p, e);
1134 /* Pull an array section out of an array constructor. */
1137 find_array_section (gfc_expr *expr, gfc_ref *ref)
1143 long unsigned one = 1;
1145 mpz_t start[GFC_MAX_DIMENSIONS];
1146 mpz_t end[GFC_MAX_DIMENSIONS];
1147 mpz_t stride[GFC_MAX_DIMENSIONS];
1148 mpz_t delta[GFC_MAX_DIMENSIONS];
1149 mpz_t ctr[GFC_MAX_DIMENSIONS];
1155 gfc_constructor *cons;
1156 gfc_constructor *base;
1162 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1167 base = expr->value.constructor;
1168 expr->value.constructor = NULL;
1170 rank = ref->u.ar.as->rank;
1172 if (expr->shape == NULL)
1173 expr->shape = gfc_get_shape (rank);
1175 mpz_init_set_ui (delta_mpz, one);
1176 mpz_init_set_ui (nelts, one);
1179 /* Do the initialization now, so that we can cleanup without
1180 keeping track of where we were. */
1181 for (d = 0; d < rank; d++)
1183 mpz_init (delta[d]);
1184 mpz_init (start[d]);
1187 mpz_init (stride[d]);
1191 /* Build the counters to clock through the array reference. */
1193 for (d = 0; d < rank; d++)
1195 /* Make this stretch of code easier on the eye! */
1196 begin = ref->u.ar.start[d];
1197 finish = ref->u.ar.end[d];
1198 step = ref->u.ar.stride[d];
1199 lower = ref->u.ar.as->lower[d];
1200 upper = ref->u.ar.as->upper[d];
1202 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1206 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1212 gcc_assert (begin->rank == 1);
1213 gcc_assert (begin->shape);
1215 vecsub[d] = begin->value.constructor;
1216 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1217 mpz_mul (nelts, nelts, begin->shape[0]);
1218 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1221 for (c = vecsub[d]; c; c = c->next)
1223 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1224 || mpz_cmp (c->expr->value.integer,
1225 lower->value.integer) < 0)
1227 gfc_error ("index in dimension %d is out of bounds "
1228 "at %L", d + 1, &ref->u.ar.c_where[d]);
1236 if ((begin && begin->expr_type != EXPR_CONSTANT)
1237 || (finish && finish->expr_type != EXPR_CONSTANT)
1238 || (step && step->expr_type != EXPR_CONSTANT))
1244 /* Obtain the stride. */
1246 mpz_set (stride[d], step->value.integer);
1248 mpz_set_ui (stride[d], one);
1250 if (mpz_cmp_ui (stride[d], 0) == 0)
1251 mpz_set_ui (stride[d], one);
1253 /* Obtain the start value for the index. */
1255 mpz_set (start[d], begin->value.integer);
1257 mpz_set (start[d], lower->value.integer);
1259 mpz_set (ctr[d], start[d]);
1261 /* Obtain the end value for the index. */
1263 mpz_set (end[d], finish->value.integer);
1265 mpz_set (end[d], upper->value.integer);
1267 /* Separate 'if' because elements sometimes arrive with
1269 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1270 mpz_set (end [d], begin->value.integer);
1272 /* Check the bounds. */
1273 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1274 || mpz_cmp (end[d], upper->value.integer) > 0
1275 || mpz_cmp (ctr[d], lower->value.integer) < 0
1276 || mpz_cmp (end[d], lower->value.integer) < 0)
1278 gfc_error ("index in dimension %d is out of bounds "
1279 "at %L", d + 1, &ref->u.ar.c_where[d]);
1284 /* Calculate the number of elements and the shape. */
1285 mpz_set (tmp_mpz, stride[d]);
1286 mpz_add (tmp_mpz, end[d], tmp_mpz);
1287 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1288 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1289 mpz_mul (nelts, nelts, tmp_mpz);
1291 /* An element reference reduces the rank of the expression; don't
1292 add anything to the shape array. */
1293 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1294 mpz_set (expr->shape[shape_i++], tmp_mpz);
1297 /* Calculate the 'stride' (=delta) for conversion of the
1298 counter values into the index along the constructor. */
1299 mpz_set (delta[d], delta_mpz);
1300 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1301 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1302 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1309 /* Now clock through the array reference, calculating the index in
1310 the source constructor and transferring the elements to the new
1312 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1314 if (ref->u.ar.offset)
1315 mpz_set (ptr, ref->u.ar.offset->value.integer);
1317 mpz_init_set_ui (ptr, 0);
1320 for (d = 0; d < rank; d++)
1322 mpz_set (tmp_mpz, ctr[d]);
1323 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1324 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1325 mpz_add (ptr, ptr, tmp_mpz);
1327 if (!incr_ctr) continue;
1329 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1331 gcc_assert(vecsub[d]);
1333 if (!vecsub[d]->next)
1334 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1337 vecsub[d] = vecsub[d]->next;
1340 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1344 mpz_add (ctr[d], ctr[d], stride[d]);
1346 if (mpz_cmp_ui (stride[d], 0) > 0
1347 ? mpz_cmp (ctr[d], end[d]) > 0
1348 : mpz_cmp (ctr[d], end[d]) < 0)
1349 mpz_set (ctr[d], start[d]);
1355 /* There must be a better way of dealing with negative strides
1356 than resetting the index and the constructor pointer! */
1357 if (mpz_cmp (ptr, index) < 0)
1359 mpz_set_ui (index, 0);
1363 while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1365 mpz_add_ui (index, index, one);
1369 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1377 mpz_clear (delta_mpz);
1378 mpz_clear (tmp_mpz);
1380 for (d = 0; d < rank; d++)
1382 mpz_clear (delta[d]);
1383 mpz_clear (start[d]);
1386 mpz_clear (stride[d]);
1388 gfc_free_constructor (base);
1392 /* Pull a substring out of an expression. */
1395 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1402 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1403 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1406 *newp = gfc_copy_expr (p);
1407 gfc_free ((*newp)->value.character.string);
1409 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1410 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1411 length = end - start + 1;
1413 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1414 (*newp)->value.character.length = length;
1415 memcpy (chr, &p->value.character.string[start - 1],
1416 length * sizeof (gfc_char_t));
1423 /* Simplify a subobject reference of a constructor. This occurs when
1424 parameter variable values are substituted. */
1427 simplify_const_ref (gfc_expr *p)
1429 gfc_constructor *cons;
1434 switch (p->ref->type)
1437 switch (p->ref->u.ar.type)
1440 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1447 remove_subobject_ref (p, cons);
1451 if (find_array_section (p, p->ref) == FAILURE)
1453 p->ref->u.ar.type = AR_FULL;
1458 if (p->ref->next != NULL
1459 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1461 cons = p->value.constructor;
1462 for (; cons; cons = cons->next)
1464 cons->expr->ref = gfc_copy_ref (p->ref->next);
1465 if (simplify_const_ref (cons->expr) == FAILURE)
1469 /* If this is a CHARACTER array and we possibly took a
1470 substring out of it, update the type-spec's character
1471 length according to the first element (as all should have
1472 the same length). */
1473 if (p->ts.type == BT_CHARACTER)
1477 gcc_assert (p->ref->next);
1478 gcc_assert (!p->ref->next->next);
1479 gcc_assert (p->ref->next->type == REF_SUBSTRING);
1481 if (p->value.constructor)
1483 const gfc_expr* first = p->value.constructor->expr;
1484 gcc_assert (first->expr_type == EXPR_CONSTANT);
1485 gcc_assert (first->ts.type == BT_CHARACTER);
1486 string_len = first->value.character.length;
1493 p->ts.cl = gfc_get_charlen ();
1494 p->ts.cl->next = NULL;
1495 p->ts.cl->length = NULL;
1497 gfc_free_expr (p->ts.cl->length);
1498 p->ts.cl->length = gfc_int_expr (string_len);
1501 gfc_free_ref_list (p->ref);
1512 cons = find_component_ref (p->value.constructor, p->ref);
1513 remove_subobject_ref (p, cons);
1517 if (find_substring_ref (p, &newp) == FAILURE)
1520 gfc_replace_expr (p, newp);
1521 gfc_free_ref_list (p->ref);
1531 /* Simplify a chain of references. */
1534 simplify_ref_chain (gfc_ref *ref, int type)
1538 for (; ref; ref = ref->next)
1543 for (n = 0; n < ref->u.ar.dimen; n++)
1545 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1547 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1549 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1555 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1557 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1569 /* Try to substitute the value of a parameter variable. */
1572 simplify_parameter_variable (gfc_expr *p, int type)
1577 e = gfc_copy_expr (p->symtree->n.sym->value);
1583 /* Do not copy subobject refs for constant. */
1584 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1585 e->ref = gfc_copy_ref (p->ref);
1586 t = gfc_simplify_expr (e, type);
1588 /* Only use the simplification if it eliminated all subobject references. */
1589 if (t == SUCCESS && !e->ref)
1590 gfc_replace_expr (p, e);
1597 /* Given an expression, simplify it by collapsing constant
1598 expressions. Most simplification takes place when the expression
1599 tree is being constructed. If an intrinsic function is simplified
1600 at some point, we get called again to collapse the result against
1603 We work by recursively simplifying expression nodes, simplifying
1604 intrinsic functions where possible, which can lead to further
1605 constant collapsing. If an operator has constant operand(s), we
1606 rip the expression apart, and rebuild it, hoping that it becomes
1609 The expression type is defined for:
1610 0 Basic expression parsing
1611 1 Simplifying array constructors -- will substitute
1613 Returns FAILURE on error, SUCCESS otherwise.
1614 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1617 gfc_simplify_expr (gfc_expr *p, int type)
1619 gfc_actual_arglist *ap;
1624 switch (p->expr_type)
1631 for (ap = p->value.function.actual; ap; ap = ap->next)
1632 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1635 if (p->value.function.isym != NULL
1636 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1641 case EXPR_SUBSTRING:
1642 if (simplify_ref_chain (p->ref, type) == FAILURE)
1645 if (gfc_is_constant_expr (p))
1650 if (p->ref && p->ref->u.ss.start)
1652 gfc_extract_int (p->ref->u.ss.start, &start);
1653 start--; /* Convert from one-based to zero-based. */
1658 if (p->ref && p->ref->u.ss.end)
1659 gfc_extract_int (p->ref->u.ss.end, &end);
1661 end = p->value.character.length;
1663 s = gfc_get_wide_string (end - start + 2);
1664 memcpy (s, p->value.character.string + start,
1665 (end - start) * sizeof (gfc_char_t));
1666 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1667 gfc_free (p->value.character.string);
1668 p->value.character.string = s;
1669 p->value.character.length = end - start;
1670 p->ts.cl = gfc_get_charlen ();
1671 p->ts.cl->next = gfc_current_ns->cl_list;
1672 gfc_current_ns->cl_list = p->ts.cl;
1673 p->ts.cl->length = gfc_int_expr (p->value.character.length);
1674 gfc_free_ref_list (p->ref);
1676 p->expr_type = EXPR_CONSTANT;
1681 if (simplify_intrinsic_op (p, type) == FAILURE)
1686 /* Only substitute array parameter variables if we are in an
1687 initialization expression, or we want a subsection. */
1688 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1689 && (gfc_init_expr || p->ref
1690 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1692 if (simplify_parameter_variable (p, type) == FAILURE)
1699 gfc_simplify_iterator_var (p);
1702 /* Simplify subcomponent references. */
1703 if (simplify_ref_chain (p->ref, type) == FAILURE)
1708 case EXPR_STRUCTURE:
1710 if (simplify_ref_chain (p->ref, type) == FAILURE)
1713 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1716 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1717 && p->ref->u.ar.type == AR_FULL)
1718 gfc_expand_constructor (p);
1720 if (simplify_const_ref (p) == FAILURE)
1734 /* Returns the type of an expression with the exception that iterator
1735 variables are automatically integers no matter what else they may
1741 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1748 /* Check an intrinsic arithmetic operation to see if it is consistent
1749 with some type of expression. */
1751 static gfc_try check_init_expr (gfc_expr *);
1754 /* Scalarize an expression for an elemental intrinsic call. */
1757 scalarize_intrinsic_call (gfc_expr *e)
1759 gfc_actual_arglist *a, *b;
1760 gfc_constructor *args[5], *ctor, *new_ctor;
1761 gfc_expr *expr, *old;
1762 int n, i, rank[5], array_arg;
1764 /* Find which, if any, arguments are arrays. Assume that the old
1765 expression carries the type information and that the first arg
1766 that is an array expression carries all the shape information.*/
1768 a = e->value.function.actual;
1769 for (; a; a = a->next)
1772 if (a->expr->expr_type != EXPR_ARRAY)
1775 expr = gfc_copy_expr (a->expr);
1782 old = gfc_copy_expr (e);
1784 gfc_free_constructor (expr->value.constructor);
1785 expr->value.constructor = NULL;
1788 expr->where = old->where;
1789 expr->expr_type = EXPR_ARRAY;
1791 /* Copy the array argument constructors into an array, with nulls
1794 a = old->value.function.actual;
1795 for (; a; a = a->next)
1797 /* Check that this is OK for an initialization expression. */
1798 if (a->expr && check_init_expr (a->expr) == FAILURE)
1802 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1804 rank[n] = a->expr->rank;
1805 ctor = a->expr->symtree->n.sym->value->value.constructor;
1806 args[n] = gfc_copy_constructor (ctor);
1808 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1811 rank[n] = a->expr->rank;
1814 args[n] = gfc_copy_constructor (a->expr->value.constructor);
1822 /* Using the array argument as the master, step through the array
1823 calling the function for each element and advancing the array
1824 constructors together. */
1825 ctor = args[array_arg - 1];
1827 for (; ctor; ctor = ctor->next)
1829 if (expr->value.constructor == NULL)
1830 expr->value.constructor
1831 = new_ctor = gfc_get_constructor ();
1834 new_ctor->next = gfc_get_constructor ();
1835 new_ctor = new_ctor->next;
1837 new_ctor->expr = gfc_copy_expr (old);
1838 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1840 b = old->value.function.actual;
1841 for (i = 0; i < n; i++)
1844 new_ctor->expr->value.function.actual
1845 = a = gfc_get_actual_arglist ();
1848 a->next = gfc_get_actual_arglist ();
1852 a->expr = gfc_copy_expr (args[i]->expr);
1854 a->expr = gfc_copy_expr (b->expr);
1859 /* Simplify the function calls. If the simplification fails, the
1860 error will be flagged up down-stream or the library will deal
1862 gfc_simplify_expr (new_ctor->expr, 0);
1864 for (i = 0; i < n; i++)
1866 args[i] = args[i]->next;
1868 for (i = 1; i < n; i++)
1869 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1870 || (args[i] == NULL && args[array_arg - 1] != NULL)))
1876 gfc_free_expr (old);
1880 gfc_error_now ("elemental function arguments at %C are not compliant");
1883 gfc_free_expr (expr);
1884 gfc_free_expr (old);
1890 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1892 gfc_expr *op1 = e->value.op.op1;
1893 gfc_expr *op2 = e->value.op.op2;
1895 if ((*check_function) (op1) == FAILURE)
1898 switch (e->value.op.op)
1900 case INTRINSIC_UPLUS:
1901 case INTRINSIC_UMINUS:
1902 if (!numeric_type (et0 (op1)))
1907 case INTRINSIC_EQ_OS:
1909 case INTRINSIC_NE_OS:
1911 case INTRINSIC_GT_OS:
1913 case INTRINSIC_GE_OS:
1915 case INTRINSIC_LT_OS:
1917 case INTRINSIC_LE_OS:
1918 if ((*check_function) (op2) == FAILURE)
1921 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1922 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1924 gfc_error ("Numeric or CHARACTER operands are required in "
1925 "expression at %L", &e->where);
1930 case INTRINSIC_PLUS:
1931 case INTRINSIC_MINUS:
1932 case INTRINSIC_TIMES:
1933 case INTRINSIC_DIVIDE:
1934 case INTRINSIC_POWER:
1935 if ((*check_function) (op2) == FAILURE)
1938 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1941 if (e->value.op.op == INTRINSIC_POWER
1942 && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1944 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
1945 "exponent in an initialization "
1946 "expression at %L", &op2->where)
1953 case INTRINSIC_CONCAT:
1954 if ((*check_function) (op2) == FAILURE)
1957 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1959 gfc_error ("Concatenation operator in expression at %L "
1960 "must have two CHARACTER operands", &op1->where);
1964 if (op1->ts.kind != op2->ts.kind)
1966 gfc_error ("Concat operator at %L must concatenate strings of the "
1967 "same kind", &e->where);
1974 if (et0 (op1) != BT_LOGICAL)
1976 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1977 "operand", &op1->where);
1986 case INTRINSIC_NEQV:
1987 if ((*check_function) (op2) == FAILURE)
1990 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1992 gfc_error ("LOGICAL operands are required in expression at %L",
1999 case INTRINSIC_PARENTHESES:
2003 gfc_error ("Only intrinsic operators can be used in expression at %L",
2011 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2018 check_init_expr_arguments (gfc_expr *e)
2020 gfc_actual_arglist *ap;
2022 for (ap = e->value.function.actual; ap; ap = ap->next)
2023 if (check_init_expr (ap->expr) == FAILURE)
2029 static gfc_try check_restricted (gfc_expr *);
2031 /* F95, 7.1.6.1, Initialization expressions, (7)
2032 F2003, 7.1.7 Initialization expression, (8) */
2035 check_inquiry (gfc_expr *e, int not_restricted)
2038 const char *const *functions;
2040 static const char *const inquiry_func_f95[] = {
2041 "lbound", "shape", "size", "ubound",
2042 "bit_size", "len", "kind",
2043 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2044 "precision", "radix", "range", "tiny",
2048 static const char *const inquiry_func_f2003[] = {
2049 "lbound", "shape", "size", "ubound",
2050 "bit_size", "len", "kind",
2051 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2052 "precision", "radix", "range", "tiny",
2057 gfc_actual_arglist *ap;
2059 if (!e->value.function.isym
2060 || !e->value.function.isym->inquiry)
2063 /* An undeclared parameter will get us here (PR25018). */
2064 if (e->symtree == NULL)
2067 name = e->symtree->n.sym->name;
2069 functions = (gfc_option.warn_std & GFC_STD_F2003)
2070 ? inquiry_func_f2003 : inquiry_func_f95;
2072 for (i = 0; functions[i]; i++)
2073 if (strcmp (functions[i], name) == 0)
2076 if (functions[i] == NULL)
2079 /* At this point we have an inquiry function with a variable argument. The
2080 type of the variable might be undefined, but we need it now, because the
2081 arguments of these functions are not allowed to be undefined. */
2083 for (ap = e->value.function.actual; ap; ap = ap->next)
2088 if (ap->expr->ts.type == BT_UNKNOWN)
2090 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2091 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2095 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2098 /* Assumed character length will not reduce to a constant expression
2099 with LEN, as required by the standard. */
2100 if (i == 5 && not_restricted
2101 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2102 && ap->expr->symtree->n.sym->ts.cl->length == NULL)
2104 gfc_error ("Assumed character length variable '%s' in constant "
2105 "expression at %L", e->symtree->n.sym->name, &e->where);
2108 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2111 if (not_restricted == 0
2112 && ap->expr->expr_type != EXPR_VARIABLE
2113 && check_restricted (ap->expr) == FAILURE)
2121 /* F95, 7.1.6.1, Initialization expressions, (5)
2122 F2003, 7.1.7 Initialization expression, (5) */
2125 check_transformational (gfc_expr *e)
2127 static const char * const trans_func_f95[] = {
2128 "repeat", "reshape", "selected_int_kind",
2129 "selected_real_kind", "transfer", "trim", NULL
2135 if (!e->value.function.isym
2136 || !e->value.function.isym->transformational)
2139 name = e->symtree->n.sym->name;
2141 /* NULL() is dealt with below. */
2142 if (strcmp ("null", name) == 0)
2145 for (i = 0; trans_func_f95[i]; i++)
2146 if (strcmp (trans_func_f95[i], name) == 0)
2149 /* FIXME, F2003: implement translation of initialization
2150 expressions before enabling this check. For F95, error
2151 out if the transformational function is not in the list. */
2153 if (trans_func_f95[i] == NULL
2154 && gfc_notify_std (GFC_STD_F2003,
2155 "transformational intrinsic '%s' at %L is not permitted "
2156 "in an initialization expression", name, &e->where) == FAILURE)
2159 if (trans_func_f95[i] == NULL)
2161 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2162 "in an initialization expression", name, &e->where);
2167 return check_init_expr_arguments (e);
2171 /* F95, 7.1.6.1, Initialization expressions, (6)
2172 F2003, 7.1.7 Initialization expression, (6) */
2175 check_null (gfc_expr *e)
2177 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2180 return check_init_expr_arguments (e);
2185 check_elemental (gfc_expr *e)
2187 if (!e->value.function.isym
2188 || !e->value.function.isym->elemental)
2191 if (e->ts.type != BT_INTEGER
2192 && e->ts.type != BT_CHARACTER
2193 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2194 "nonstandard initialization expression at %L",
2195 &e->where) == FAILURE)
2198 return check_init_expr_arguments (e);
2203 check_conversion (gfc_expr *e)
2205 if (!e->value.function.isym
2206 || !e->value.function.isym->conversion)
2209 return check_init_expr_arguments (e);
2213 /* Verify that an expression is an initialization expression. A side
2214 effect is that the expression tree is reduced to a single constant
2215 node if all goes well. This would normally happen when the
2216 expression is constructed but function references are assumed to be
2217 intrinsics in the context of initialization expressions. If
2218 FAILURE is returned an error message has been generated. */
2221 check_init_expr (gfc_expr *e)
2229 switch (e->expr_type)
2232 t = check_intrinsic_op (e, check_init_expr);
2234 t = gfc_simplify_expr (e, 0);
2241 if ((m = check_specification_function (e)) != MATCH_YES)
2243 gfc_intrinsic_sym* isym;
2246 sym = e->symtree->n.sym;
2247 if (!gfc_is_intrinsic (sym, 0, e->where)
2248 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2250 gfc_error ("Function '%s' in initialization expression at %L "
2251 "must be an intrinsic or a specification function",
2252 e->symtree->n.sym->name, &e->where);
2256 if ((m = check_conversion (e)) == MATCH_NO
2257 && (m = check_inquiry (e, 1)) == MATCH_NO
2258 && (m = check_null (e)) == MATCH_NO
2259 && (m = check_transformational (e)) == MATCH_NO
2260 && (m = check_elemental (e)) == MATCH_NO)
2262 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2263 "in an initialization expression",
2264 e->symtree->n.sym->name, &e->where);
2268 /* Try to scalarize an elemental intrinsic function that has an
2270 isym = gfc_find_function (e->symtree->n.sym->name);
2271 if (isym && isym->elemental
2272 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2277 t = gfc_simplify_expr (e, 0);
2284 if (gfc_check_iter_variable (e) == SUCCESS)
2287 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2289 /* A PARAMETER shall not be used to define itself, i.e.
2290 REAL, PARAMETER :: x = transfer(0, x)
2292 if (!e->symtree->n.sym->value)
2294 gfc_error("PARAMETER '%s' is used at %L before its definition "
2295 "is complete", e->symtree->n.sym->name, &e->where);
2299 t = simplify_parameter_variable (e, 0);
2304 if (gfc_in_match_data ())
2309 if (e->symtree->n.sym->as)
2311 switch (e->symtree->n.sym->as->type)
2313 case AS_ASSUMED_SIZE:
2314 gfc_error ("Assumed size array '%s' at %L is not permitted "
2315 "in an initialization expression",
2316 e->symtree->n.sym->name, &e->where);
2319 case AS_ASSUMED_SHAPE:
2320 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2321 "in an initialization expression",
2322 e->symtree->n.sym->name, &e->where);
2326 gfc_error ("Deferred array '%s' at %L is not permitted "
2327 "in an initialization expression",
2328 e->symtree->n.sym->name, &e->where);
2332 gfc_error ("Array '%s' at %L is a variable, which does "
2333 "not reduce to a constant expression",
2334 e->symtree->n.sym->name, &e->where);
2342 gfc_error ("Parameter '%s' at %L has not been declared or is "
2343 "a variable, which does not reduce to a constant "
2344 "expression", e->symtree->n.sym->name, &e->where);
2353 case EXPR_SUBSTRING:
2354 t = check_init_expr (e->ref->u.ss.start);
2358 t = check_init_expr (e->ref->u.ss.end);
2360 t = gfc_simplify_expr (e, 0);
2364 case EXPR_STRUCTURE:
2368 t = gfc_check_constructor (e, check_init_expr);
2372 t = gfc_check_constructor (e, check_init_expr);
2376 t = gfc_expand_constructor (e);
2380 t = gfc_check_constructor_type (e);
2384 gfc_internal_error ("check_init_expr(): Unknown expression type");
2390 /* Reduces a general expression to an initialization expression (a constant).
2391 This used to be part of gfc_match_init_expr.
2392 Note that this function doesn't free the given expression on FAILURE. */
2395 gfc_reduce_init_expr (gfc_expr *expr)
2400 t = gfc_resolve_expr (expr);
2402 t = check_init_expr (expr);
2408 if (expr->expr_type == EXPR_ARRAY
2409 && (gfc_check_constructor_type (expr) == FAILURE
2410 || gfc_expand_constructor (expr) == FAILURE))
2413 /* Not all inquiry functions are simplified to constant expressions
2414 so it is necessary to call check_inquiry again. */
2415 if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2416 && !gfc_in_match_data ())
2418 gfc_error ("Initialization expression didn't reduce %C");
2426 /* Match an initialization expression. We work by first matching an
2427 expression, then reducing it to a constant. */
2430 gfc_match_init_expr (gfc_expr **result)
2438 m = gfc_match_expr (&expr);
2442 t = gfc_reduce_init_expr (expr);
2445 gfc_free_expr (expr);
2455 /* Given an actual argument list, test to see that each argument is a
2456 restricted expression and optionally if the expression type is
2457 integer or character. */
2460 restricted_args (gfc_actual_arglist *a)
2462 for (; a; a = a->next)
2464 if (check_restricted (a->expr) == FAILURE)
2472 /************* Restricted/specification expressions *************/
2475 /* Make sure a non-intrinsic function is a specification function. */
2478 external_spec_function (gfc_expr *e)
2482 f = e->value.function.esym;
2484 if (f->attr.proc == PROC_ST_FUNCTION)
2486 gfc_error ("Specification function '%s' at %L cannot be a statement "
2487 "function", f->name, &e->where);
2491 if (f->attr.proc == PROC_INTERNAL)
2493 gfc_error ("Specification function '%s' at %L cannot be an internal "
2494 "function", f->name, &e->where);
2498 if (!f->attr.pure && !f->attr.elemental)
2500 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2505 if (f->attr.recursive)
2507 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2508 f->name, &e->where);
2512 return restricted_args (e->value.function.actual);
2516 /* Check to see that a function reference to an intrinsic is a
2517 restricted expression. */
2520 restricted_intrinsic (gfc_expr *e)
2522 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2523 if (check_inquiry (e, 0) == MATCH_YES)
2526 return restricted_args (e->value.function.actual);
2530 /* Check the expressions of an actual arglist. Used by check_restricted. */
2533 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2535 for (; arg; arg = arg->next)
2536 if (checker (arg->expr) == FAILURE)
2543 /* Check the subscription expressions of a reference chain with a checking
2544 function; used by check_restricted. */
2547 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2557 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2559 if (checker (ref->u.ar.start[dim]) == FAILURE)
2561 if (checker (ref->u.ar.end[dim]) == FAILURE)
2563 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2569 /* Nothing needed, just proceed to next reference. */
2573 if (checker (ref->u.ss.start) == FAILURE)
2575 if (checker (ref->u.ss.end) == FAILURE)
2584 return check_references (ref->next, checker);
2588 /* Verify that an expression is a restricted expression. Like its
2589 cousin check_init_expr(), an error message is generated if we
2593 check_restricted (gfc_expr *e)
2601 switch (e->expr_type)
2604 t = check_intrinsic_op (e, check_restricted);
2606 t = gfc_simplify_expr (e, 0);
2611 if (e->value.function.esym)
2613 t = check_arglist (e->value.function.actual, &check_restricted);
2615 t = external_spec_function (e);
2619 if (e->value.function.isym && e->value.function.isym->inquiry)
2622 t = check_arglist (e->value.function.actual, &check_restricted);
2625 t = restricted_intrinsic (e);
2630 sym = e->symtree->n.sym;
2633 /* If a dummy argument appears in a context that is valid for a
2634 restricted expression in an elemental procedure, it will have
2635 already been simplified away once we get here. Therefore we
2636 don't need to jump through hoops to distinguish valid from
2638 if (sym->attr.dummy && sym->ns == gfc_current_ns
2639 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2641 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2642 sym->name, &e->where);
2646 if (sym->attr.optional)
2648 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2649 sym->name, &e->where);
2653 if (sym->attr.intent == INTENT_OUT)
2655 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2656 sym->name, &e->where);
2660 /* Check reference chain if any. */
2661 if (check_references (e->ref, &check_restricted) == FAILURE)
2664 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2665 processed in resolve.c(resolve_formal_arglist). This is done so
2666 that host associated dummy array indices are accepted (PR23446).
2667 This mechanism also does the same for the specification expressions
2668 of array-valued functions. */
2670 || sym->attr.in_common
2671 || sym->attr.use_assoc
2673 || sym->attr.implied_index
2674 || sym->attr.flavor == FL_PARAMETER
2675 || (sym->ns && sym->ns == gfc_current_ns->parent)
2676 || (sym->ns && gfc_current_ns->parent
2677 && sym->ns == gfc_current_ns->parent->parent)
2678 || (sym->ns->proc_name != NULL
2679 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2680 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2686 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2687 sym->name, &e->where);
2688 /* Prevent a repetition of the error. */
2697 case EXPR_SUBSTRING:
2698 t = gfc_specification_expr (e->ref->u.ss.start);
2702 t = gfc_specification_expr (e->ref->u.ss.end);
2704 t = gfc_simplify_expr (e, 0);
2708 case EXPR_STRUCTURE:
2709 t = gfc_check_constructor (e, check_restricted);
2713 t = gfc_check_constructor (e, check_restricted);
2717 gfc_internal_error ("check_restricted(): Unknown expression type");
2724 /* Check to see that an expression is a specification expression. If
2725 we return FAILURE, an error has been generated. */
2728 gfc_specification_expr (gfc_expr *e)
2734 if (e->ts.type != BT_INTEGER)
2736 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2737 &e->where, gfc_basic_typename (e->ts.type));
2741 if (e->expr_type == EXPR_FUNCTION
2742 && !e->value.function.isym
2743 && !e->value.function.esym
2744 && !gfc_pure (e->symtree->n.sym))
2746 gfc_error ("Function '%s' at %L must be PURE",
2747 e->symtree->n.sym->name, &e->where);
2748 /* Prevent repeat error messages. */
2749 e->symtree->n.sym->attr.pure = 1;
2755 gfc_error ("Expression at %L must be scalar", &e->where);
2759 if (gfc_simplify_expr (e, 0) == FAILURE)
2762 return check_restricted (e);
2766 /************** Expression conformance checks. *************/
2768 /* Given two expressions, make sure that the arrays are conformable. */
2771 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2773 int op1_flag, op2_flag, d;
2774 mpz_t op1_size, op2_size;
2777 if (op1->rank == 0 || op2->rank == 0)
2780 if (op1->rank != op2->rank)
2782 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
2783 op1->rank, op2->rank, &op1->where);
2789 for (d = 0; d < op1->rank; d++)
2791 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2792 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2794 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2796 gfc_error ("Different shape for %s at %L on dimension %d "
2797 "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
2798 (int) mpz_get_si (op1_size),
2799 (int) mpz_get_si (op2_size));
2805 mpz_clear (op1_size);
2807 mpz_clear (op2_size);
2817 /* Given an assignable expression and an arbitrary expression, make
2818 sure that the assignment can take place. */
2821 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2827 sym = lvalue->symtree->n.sym;
2829 /* Check INTENT(IN), unless the object itself is the component or
2830 sub-component of a pointer. */
2831 has_pointer = sym->attr.pointer;
2833 for (ref = lvalue->ref; ref; ref = ref->next)
2834 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2840 if (!has_pointer && sym->attr.intent == INTENT_IN)
2842 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2843 sym->name, &lvalue->where);
2847 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2848 variable local to a function subprogram. Its existence begins when
2849 execution of the function is initiated and ends when execution of the
2850 function is terminated...
2851 Therefore, the left hand side is no longer a variable, when it is: */
2852 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2853 && !sym->attr.external)
2858 /* (i) Use associated; */
2859 if (sym->attr.use_assoc)
2862 /* (ii) The assignment is in the main program; or */
2863 if (gfc_current_ns->proc_name->attr.is_main_program)
2866 /* (iii) A module or internal procedure... */
2867 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2868 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2869 && gfc_current_ns->parent
2870 && (!(gfc_current_ns->parent->proc_name->attr.function
2871 || gfc_current_ns->parent->proc_name->attr.subroutine)
2872 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2874 /* ... that is not a function... */
2875 if (!gfc_current_ns->proc_name->attr.function)
2878 /* ... or is not an entry and has a different name. */
2879 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2883 /* (iv) Host associated and not the function symbol or the
2884 parent result. This picks up sibling references, which
2885 cannot be entries. */
2886 if (!sym->attr.entry
2887 && sym->ns == gfc_current_ns->parent
2888 && sym != gfc_current_ns->proc_name
2889 && sym != gfc_current_ns->parent->proc_name->result)
2894 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2899 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2901 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2902 lvalue->rank, rvalue->rank, &lvalue->where);
2906 if (lvalue->ts.type == BT_UNKNOWN)
2908 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2913 if (rvalue->expr_type == EXPR_NULL)
2915 if (lvalue->symtree->n.sym->attr.pointer
2916 && lvalue->symtree->n.sym->attr.data)
2920 gfc_error ("NULL appears on right-hand side in assignment at %L",
2926 if (sym->attr.cray_pointee
2927 && lvalue->ref != NULL
2928 && lvalue->ref->u.ar.type == AR_FULL
2929 && lvalue->ref->u.ar.as->cp_was_assumed)
2931 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2932 "is illegal", &lvalue->where);
2936 /* This is possibly a typo: x = f() instead of x => f(). */
2937 if (gfc_option.warn_surprising
2938 && rvalue->expr_type == EXPR_FUNCTION
2939 && rvalue->symtree->n.sym->attr.pointer)
2940 gfc_warning ("POINTER valued function appears on right-hand side of "
2941 "assignment at %L", &rvalue->where);
2943 /* Check size of array assignments. */
2944 if (lvalue->rank != 0 && rvalue->rank != 0
2945 && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
2948 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
2949 && lvalue->symtree->n.sym->attr.data
2950 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
2951 "initialize non-integer variable '%s'",
2952 &rvalue->where, lvalue->symtree->n.sym->name)
2955 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
2956 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
2957 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2958 &rvalue->where) == FAILURE)
2961 /* Handle the case of a BOZ literal on the RHS. */
2962 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
2965 if (gfc_option.warn_surprising)
2966 gfc_warning ("BOZ literal at %L is bitwise transferred "
2967 "non-integer symbol '%s'", &rvalue->where,
2968 lvalue->symtree->n.sym->name);
2969 if (!gfc_convert_boz (rvalue, &lvalue->ts))
2971 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
2973 if (rc == ARITH_UNDERFLOW)
2974 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2975 ". This check can be disabled with the option "
2976 "-fno-range-check", &rvalue->where);
2977 else if (rc == ARITH_OVERFLOW)
2978 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2979 ". This check can be disabled with the option "
2980 "-fno-range-check", &rvalue->where);
2981 else if (rc == ARITH_NAN)
2982 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2983 ". This check can be disabled with the option "
2984 "-fno-range-check", &rvalue->where);
2989 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2992 /* Only DATA Statements come here. */
2995 /* Numeric can be converted to any other numeric. And Hollerith can be
2996 converted to any other type. */
2997 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2998 || rvalue->ts.type == BT_HOLLERITH)
3001 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3004 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3005 "conversion of %s to %s", &lvalue->where,
3006 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3011 /* Assignment is the only case where character variables of different
3012 kind values can be converted into one another. */
3013 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3015 if (lvalue->ts.kind != rvalue->ts.kind)
3016 gfc_convert_chartype (rvalue, &lvalue->ts);
3021 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3025 /* Check that a pointer assignment is OK. We first check lvalue, and
3026 we only check rvalue if it's not an assignment to NULL() or a
3027 NULLIFY statement. */
3030 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3032 symbol_attribute attr;
3035 int pointer, check_intent_in;
3037 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3038 && !lvalue->symtree->n.sym->attr.proc_pointer)
3040 gfc_error ("Pointer assignment target is not a POINTER at %L",
3045 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3046 && lvalue->symtree->n.sym->attr.use_assoc
3047 && !lvalue->symtree->n.sym->attr.proc_pointer)
3049 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3050 "l-value since it is a procedure",
3051 lvalue->symtree->n.sym->name, &lvalue->where);
3056 /* Check INTENT(IN), unless the object itself is the component or
3057 sub-component of a pointer. */
3058 check_intent_in = 1;
3059 pointer = lvalue->symtree->n.sym->attr.pointer
3060 | lvalue->symtree->n.sym->attr.proc_pointer;
3062 for (ref = lvalue->ref; ref; ref = ref->next)
3065 check_intent_in = 0;
3067 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3070 if (ref->type == REF_ARRAY && ref->next == NULL)
3072 if (ref->u.ar.type == AR_FULL)
3075 if (ref->u.ar.type != AR_SECTION)
3077 gfc_error ("Expected bounds specification for '%s' at %L",
3078 lvalue->symtree->n.sym->name, &lvalue->where);
3082 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3083 "specification for '%s' in pointer assignment "
3084 "at %L", lvalue->symtree->n.sym->name,
3085 &lvalue->where) == FAILURE)
3088 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3089 "in gfortran", &lvalue->where);
3090 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3091 either never or always the upper-bound; strides shall not be
3097 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3099 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3100 lvalue->symtree->n.sym->name, &lvalue->where);
3106 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3110 is_pure = gfc_pure (NULL);
3112 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3113 && lvalue->symtree->n.sym->value != rvalue)
3115 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3119 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3120 kind, etc for lvalue and rvalue must match, and rvalue must be a
3121 pure variable if we're in a pure function. */
3122 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3125 /* Checks on rvalue for procedure pointer assignments. */
3126 if (lvalue->symtree->n.sym->attr.proc_pointer)
3128 attr = gfc_expr_attr (rvalue);
3129 if (!((rvalue->expr_type == EXPR_NULL)
3130 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3131 || (rvalue->expr_type == EXPR_VARIABLE
3132 && attr.flavor == FL_PROCEDURE)))
3134 gfc_error ("Invalid procedure pointer assignment at %L",
3140 gfc_error ("Abstract interface '%s' is invalid "
3141 "in procedure pointer assignment at %L",
3142 rvalue->symtree->name, &rvalue->where);
3144 /* TODO. See PR 38290.
3145 if (rvalue->expr_type == EXPR_VARIABLE
3146 && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
3147 && !gfc_compare_interfaces (lvalue->symtree->n.sym,
3148 rvalue->symtree->n.sym, 0))
3150 gfc_error ("Interfaces don't match "
3151 "in procedure pointer assignment at %L", &rvalue->where);
3157 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3159 gfc_error ("Different types in pointer assignment at %L; attempted "
3160 "assignment of %s to %s", &lvalue->where,
3161 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3165 if (lvalue->ts.kind != rvalue->ts.kind)
3167 gfc_error ("Different kind type parameters in pointer "
3168 "assignment at %L", &lvalue->where);
3172 if (lvalue->rank != rvalue->rank)
3174 gfc_error ("Different ranks in pointer assignment at %L",
3179 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3180 if (rvalue->expr_type == EXPR_NULL)
3183 if (lvalue->ts.type == BT_CHARACTER)
3185 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3190 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3191 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3193 attr = gfc_expr_attr (rvalue);
3194 if (!attr.target && !attr.pointer)
3196 gfc_error ("Pointer assignment target is neither TARGET "
3197 "nor POINTER at %L", &rvalue->where);
3201 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3203 gfc_error ("Bad target in pointer assignment in PURE "
3204 "procedure at %L", &rvalue->where);
3207 if (gfc_has_vector_index (rvalue))
3209 gfc_error ("Pointer assignment with vector subscript "
3210 "on rhs at %L", &rvalue->where);
3214 if (attr.is_protected && attr.use_assoc
3215 && !(attr.pointer || attr.proc_pointer))
3217 gfc_error ("Pointer assignment target has PROTECTED "
3218 "attribute at %L", &rvalue->where);
3226 /* Relative of gfc_check_assign() except that the lvalue is a single
3227 symbol. Used for initialization assignments. */
3230 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3235 memset (&lvalue, '\0', sizeof (gfc_expr));
3237 lvalue.expr_type = EXPR_VARIABLE;
3238 lvalue.ts = sym->ts;
3240 lvalue.rank = sym->as->rank;
3241 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3242 lvalue.symtree->n.sym = sym;
3243 lvalue.where = sym->declared_at;
3245 if (sym->attr.pointer || sym->attr.proc_pointer)
3246 r = gfc_check_pointer_assign (&lvalue, rvalue);
3248 r = gfc_check_assign (&lvalue, rvalue, 1);
3250 gfc_free (lvalue.symtree);
3256 /* Get an expression for a default initializer. */
3259 gfc_default_initializer (gfc_typespec *ts)
3261 gfc_constructor *tail;
3265 /* See if we have a default initializer. */
3266 for (c = ts->derived->components; c; c = c->next)
3267 if (c->initializer || c->attr.allocatable)
3273 /* Build the constructor. */
3274 init = gfc_get_expr ();
3275 init->expr_type = EXPR_STRUCTURE;
3277 init->where = ts->derived->declared_at;
3280 for (c = ts->derived->components; c; c = c->next)
3283 init->value.constructor = tail = gfc_get_constructor ();
3286 tail->next = gfc_get_constructor ();
3291 tail->expr = gfc_copy_expr (c->initializer);
3293 if (c->attr.allocatable)
3295 tail->expr = gfc_get_expr ();
3296 tail->expr->expr_type = EXPR_NULL;
3297 tail->expr->ts = c->ts;
3304 /* Given a symbol, create an expression node with that symbol as a
3305 variable. If the symbol is array valued, setup a reference of the
3309 gfc_get_variable_expr (gfc_symtree *var)
3313 e = gfc_get_expr ();
3314 e->expr_type = EXPR_VARIABLE;
3316 e->ts = var->n.sym->ts;
3318 if (var->n.sym->as != NULL)
3320 e->rank = var->n.sym->as->rank;
3321 e->ref = gfc_get_ref ();
3322 e->ref->type = REF_ARRAY;
3323 e->ref->u.ar.type = AR_FULL;
3330 /* General expression traversal function. */
3333 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3334 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3339 gfc_actual_arglist *args;
3346 if ((*func) (expr, sym, &f))
3349 if (expr->ts.type == BT_CHARACTER
3351 && expr->ts.cl->length
3352 && expr->ts.cl->length->expr_type != EXPR_CONSTANT
3353 && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
3356 switch (expr->expr_type)
3359 for (args = expr->value.function.actual; args; args = args->next)
3361 if (gfc_traverse_expr (args->expr, sym, func, f))
3369 case EXPR_SUBSTRING:
3372 case EXPR_STRUCTURE:
3374 for (c = expr->value.constructor; c; c = c->next)
3376 if (gfc_traverse_expr (c->expr, sym, func, f))
3380 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3382 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3384 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3386 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3393 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3395 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3411 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3413 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3415 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3417 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3423 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3425 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3430 if (ref->u.c.component->ts.type == BT_CHARACTER
3431 && ref->u.c.component->ts.cl
3432 && ref->u.c.component->ts.cl->length
3433 && ref->u.c.component->ts.cl->length->expr_type
3435 && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
3439 if (ref->u.c.component->as)
3440 for (i = 0; i < ref->u.c.component->as->rank; i++)
3442 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3445 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3459 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3462 expr_set_symbols_referenced (gfc_expr *expr,
3463 gfc_symbol *sym ATTRIBUTE_UNUSED,
3464 int *f ATTRIBUTE_UNUSED)
3466 if (expr->expr_type != EXPR_VARIABLE)
3468 gfc_set_sym_referenced (expr->symtree->n.sym);
3473 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3475 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3479 /* Walk an expression tree and check each variable encountered for being typed.
3480 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3481 mode as is a basic arithmetic expression using those; this is for things in
3484 INTEGER :: arr(n), n
3485 INTEGER :: arr(n + 1), n
3487 The namespace is needed for IMPLICIT typing. */
3489 static gfc_namespace* check_typed_ns;
3492 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3493 int* f ATTRIBUTE_UNUSED)
3497 if (e->expr_type != EXPR_VARIABLE)
3500 gcc_assert (e->symtree);
3501 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3504 return (t == FAILURE);
3508 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3512 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3516 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3517 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3519 if (e->expr_type == EXPR_OP)
3521 gfc_try t = SUCCESS;
3523 gcc_assert (e->value.op.op1);
3524 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3526 if (t == SUCCESS && e->value.op.op2)
3527 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3533 /* Otherwise, walk the expression and do it strictly. */
3534 check_typed_ns = ns;
3535 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3537 return error_found ? FAILURE : SUCCESS;
3540 /* Walk an expression tree and replace all symbols with a corresponding symbol
3541 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3542 statements. The boolean return value is required by gfc_traverse_expr. */
3545 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3547 if ((expr->expr_type == EXPR_VARIABLE
3548 || (expr->expr_type == EXPR_FUNCTION
3549 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3550 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3553 gfc_namespace *ns = sym->formal_ns;
3554 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3555 the symtree rather than create a new one (and probably fail later). */
3556 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3557 expr->symtree->n.sym->name);
3559 stree->n.sym->attr = expr->symtree->n.sym->attr;
3560 expr->symtree = stree;
3566 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3568 gfc_traverse_expr (expr, dest, &replace_symbol, 0);