1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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);
189 gfc_free_constructor (e->value.constructor);
193 gfc_free (e->value.character.string);
200 gfc_internal_error ("free_expr0(): Bad expr type");
203 /* Free a shape array. */
204 if (e->shape != NULL)
206 for (n = 0; n < e->rank; n++)
207 mpz_clear (e->shape[n]);
212 gfc_free_ref_list (e->ref);
214 memset (e, '\0', sizeof (gfc_expr));
218 /* Free an expression node and everything beneath it. */
221 gfc_free_expr (gfc_expr *e)
225 if (e->con_by_offset)
226 splay_tree_delete (e->con_by_offset);
232 /* Graft the *src expression onto the *dest subexpression. */
235 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
243 /* Try to extract an integer constant from the passed expression node.
244 Returns an error message or NULL if the result is set. It is
245 tempting to generate an error and return SUCCESS or FAILURE, but
246 failure is OK for some callers. */
249 gfc_extract_int (gfc_expr *expr, int *result)
251 if (expr->expr_type != EXPR_CONSTANT)
252 return _("Constant expression required at %C");
254 if (expr->ts.type != BT_INTEGER)
255 return _("Integer expression required at %C");
257 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
258 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
260 return _("Integer value too large in expression at %C");
263 *result = (int) mpz_get_si (expr->value.integer);
269 /* Recursively copy a list of reference structures. */
272 copy_ref (gfc_ref *src)
280 dest = gfc_get_ref ();
281 dest->type = src->type;
286 ar = gfc_copy_array_ref (&src->u.ar);
292 dest->u.c = src->u.c;
296 dest->u.ss = src->u.ss;
297 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
298 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
302 dest->next = copy_ref (src->next);
308 /* Detect whether an expression has any vector index array references. */
311 gfc_has_vector_index (gfc_expr *e)
315 for (ref = e->ref; ref; ref = ref->next)
316 if (ref->type == REF_ARRAY)
317 for (i = 0; i < ref->u.ar.dimen; i++)
318 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
324 /* Copy a shape array. */
327 gfc_copy_shape (mpz_t *shape, int rank)
335 new_shape = gfc_get_shape (rank);
337 for (n = 0; n < rank; n++)
338 mpz_init_set (new_shape[n], shape[n]);
344 /* Copy a shape array excluding dimension N, where N is an integer
345 constant expression. Dimensions are numbered in fortran style --
348 So, if the original shape array contains R elements
349 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
350 the result contains R-1 elements:
351 { s1 ... sN-1 sN+1 ... sR-1}
353 If anything goes wrong -- N is not a constant, its value is out
354 of range -- or anything else, just returns NULL. */
357 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
359 mpz_t *new_shape, *s;
365 || dim->expr_type != EXPR_CONSTANT
366 || dim->ts.type != BT_INTEGER)
369 n = mpz_get_si (dim->value.integer);
370 n--; /* Convert to zero based index. */
371 if (n < 0 || n >= rank)
374 s = new_shape = gfc_get_shape (rank - 1);
376 for (i = 0; i < rank; i++)
380 mpz_init_set (*s, shape[i]);
388 /* Given an expression pointer, return a copy of the expression. This
389 subroutine is recursive. */
392 gfc_copy_expr (gfc_expr *p)
404 switch (q->expr_type)
407 s = gfc_get_wide_string (p->value.character.length + 1);
408 q->value.character.string = s;
409 memcpy (s, p->value.character.string,
410 (p->value.character.length + 1) * sizeof (gfc_char_t));
414 /* Copy target representation, if it exists. */
415 if (p->representation.string)
417 c = XCNEWVEC (char, p->representation.length + 1);
418 q->representation.string = c;
419 memcpy (c, p->representation.string, (p->representation.length + 1));
422 /* Copy the values of any pointer components of p->value. */
426 mpz_init_set (q->value.integer, p->value.integer);
430 gfc_set_model_kind (q->ts.kind);
431 mpfr_init (q->value.real);
432 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
436 gfc_set_model_kind (q->ts.kind);
437 mpfr_init (q->value.complex.r);
438 mpfr_init (q->value.complex.i);
439 mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
440 mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
444 if (p->representation.string)
445 q->value.character.string
446 = gfc_char_to_widechar (q->representation.string);
449 s = gfc_get_wide_string (p->value.character.length + 1);
450 q->value.character.string = s;
452 /* This is the case for the C_NULL_CHAR named constant. */
453 if (p->value.character.length == 0
454 && (p->ts.is_c_interop || p->ts.is_iso_c))
457 /* Need to set the length to 1 to make sure the NUL
458 terminator is copied. */
459 q->value.character.length = 1;
462 memcpy (s, p->value.character.string,
463 (p->value.character.length + 1) * sizeof (gfc_char_t));
470 break; /* Already done. */
474 /* Should never be reached. */
476 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
483 switch (q->value.op.op)
486 case INTRINSIC_PARENTHESES:
487 case INTRINSIC_UPLUS:
488 case INTRINSIC_UMINUS:
489 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
492 default: /* Binary operators. */
493 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
494 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
501 q->value.function.actual =
502 gfc_copy_actual_arglist (p->value.function.actual);
507 q->value.constructor = gfc_copy_constructor (p->value.constructor);
515 q->shape = gfc_copy_shape (p->shape, p->rank);
517 q->ref = copy_ref (p->ref);
523 /* Return the maximum kind of two expressions. In general, higher
524 kind numbers mean more precision for numeric types. */
527 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
529 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
533 /* Returns nonzero if the type is numeric, zero otherwise. */
536 numeric_type (bt type)
538 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
542 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
545 gfc_numeric_ts (gfc_typespec *ts)
547 return numeric_type (ts->type);
551 /* Returns an expression node that is an integer constant. */
560 p->expr_type = EXPR_CONSTANT;
561 p->ts.type = BT_INTEGER;
562 p->ts.kind = gfc_default_integer_kind;
564 p->where = gfc_current_locus;
565 mpz_init_set_si (p->value.integer, i);
571 /* Returns an expression node that is a logical constant. */
574 gfc_logical_expr (int i, locus *where)
580 p->expr_type = EXPR_CONSTANT;
581 p->ts.type = BT_LOGICAL;
582 p->ts.kind = gfc_default_logical_kind;
585 where = &gfc_current_locus;
587 p->value.logical = i;
593 /* Return an expression node with an optional argument list attached.
594 A variable number of gfc_expr pointers are strung together in an
595 argument list with a NULL pointer terminating the list. */
598 gfc_build_conversion (gfc_expr *e)
603 p->expr_type = EXPR_FUNCTION;
605 p->value.function.actual = NULL;
607 p->value.function.actual = gfc_get_actual_arglist ();
608 p->value.function.actual->expr = e;
614 /* Given an expression node with some sort of numeric binary
615 expression, insert type conversions required to make the operands
618 The exception is that the operands of an exponential don't have to
619 have the same type. If possible, the base is promoted to the type
620 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
621 1.0**2 stays as it is. */
624 gfc_type_convert_binary (gfc_expr *e)
628 op1 = e->value.op.op1;
629 op2 = e->value.op.op2;
631 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
633 gfc_clear_ts (&e->ts);
637 /* Kind conversions of same type. */
638 if (op1->ts.type == op2->ts.type)
640 if (op1->ts.kind == op2->ts.kind)
642 /* No type conversions. */
647 if (op1->ts.kind > op2->ts.kind)
648 gfc_convert_type (op2, &op1->ts, 2);
650 gfc_convert_type (op1, &op2->ts, 2);
656 /* Integer combined with real or complex. */
657 if (op2->ts.type == BT_INTEGER)
661 /* Special case for ** operator. */
662 if (e->value.op.op == INTRINSIC_POWER)
665 gfc_convert_type (e->value.op.op2, &e->ts, 2);
669 if (op1->ts.type == BT_INTEGER)
672 gfc_convert_type (e->value.op.op1, &e->ts, 2);
676 /* Real combined with complex. */
677 e->ts.type = BT_COMPLEX;
678 if (op1->ts.kind > op2->ts.kind)
679 e->ts.kind = op1->ts.kind;
681 e->ts.kind = op2->ts.kind;
682 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
683 gfc_convert_type (e->value.op.op1, &e->ts, 2);
684 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
685 gfc_convert_type (e->value.op.op2, &e->ts, 2);
693 check_specification_function (gfc_expr *e)
700 sym = e->symtree->n.sym;
702 /* F95, 7.1.6.2; F2003, 7.1.7 */
704 && sym->attr.function
706 && !sym->attr.intrinsic
707 && !sym->attr.recursive
708 && sym->attr.proc != PROC_INTERNAL
709 && sym->attr.proc != PROC_ST_FUNCTION
710 && sym->attr.proc != PROC_UNKNOWN
711 && sym->formal == NULL)
717 /* Function to determine if an expression is constant or not. This
718 function expects that the expression has already been simplified. */
721 gfc_is_constant_expr (gfc_expr *e)
724 gfc_actual_arglist *arg;
730 switch (e->expr_type)
733 rv = (gfc_is_constant_expr (e->value.op.op1)
734 && (e->value.op.op2 == NULL
735 || gfc_is_constant_expr (e->value.op.op2)));
743 /* Specification functions are constant. */
744 if (check_specification_function (e) == MATCH_YES)
750 /* Call to intrinsic with at least one argument. */
752 if (e->value.function.isym && e->value.function.actual)
754 for (arg = e->value.function.actual; arg; arg = arg->next)
756 if (!gfc_is_constant_expr (arg->expr))
770 rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
771 && gfc_is_constant_expr (e->ref->u.ss.end));
776 for (c = e->value.constructor; c; c = c->next)
777 if (!gfc_is_constant_expr (c->expr))
785 rv = gfc_constant_ac (e);
789 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
796 /* Is true if an array reference is followed by a component or substring
799 is_subref_array (gfc_expr * e)
804 if (e->expr_type != EXPR_VARIABLE)
807 if (e->symtree->n.sym->attr.subref_array_pointer)
811 for (ref = e->ref; ref; ref = ref->next)
813 if (ref->type == REF_ARRAY
814 && ref->u.ar.type != AR_ELEMENT)
818 && ref->type != REF_ARRAY)
825 /* Try to collapse intrinsic expressions. */
828 simplify_intrinsic_op (gfc_expr *p, int type)
831 gfc_expr *op1, *op2, *result;
833 if (p->value.op.op == INTRINSIC_USER)
836 op1 = p->value.op.op1;
837 op2 = p->value.op.op2;
840 if (gfc_simplify_expr (op1, type) == FAILURE)
842 if (gfc_simplify_expr (op2, type) == FAILURE)
845 if (!gfc_is_constant_expr (op1)
846 || (op2 != NULL && !gfc_is_constant_expr (op2)))
850 p->value.op.op1 = NULL;
851 p->value.op.op2 = NULL;
855 case INTRINSIC_PARENTHESES:
856 result = gfc_parentheses (op1);
859 case INTRINSIC_UPLUS:
860 result = gfc_uplus (op1);
863 case INTRINSIC_UMINUS:
864 result = gfc_uminus (op1);
868 result = gfc_add (op1, op2);
871 case INTRINSIC_MINUS:
872 result = gfc_subtract (op1, op2);
875 case INTRINSIC_TIMES:
876 result = gfc_multiply (op1, op2);
879 case INTRINSIC_DIVIDE:
880 result = gfc_divide (op1, op2);
883 case INTRINSIC_POWER:
884 result = gfc_power (op1, op2);
887 case INTRINSIC_CONCAT:
888 result = gfc_concat (op1, op2);
892 case INTRINSIC_EQ_OS:
893 result = gfc_eq (op1, op2, op);
897 case INTRINSIC_NE_OS:
898 result = gfc_ne (op1, op2, op);
902 case INTRINSIC_GT_OS:
903 result = gfc_gt (op1, op2, op);
907 case INTRINSIC_GE_OS:
908 result = gfc_ge (op1, op2, op);
912 case INTRINSIC_LT_OS:
913 result = gfc_lt (op1, op2, op);
917 case INTRINSIC_LE_OS:
918 result = gfc_le (op1, op2, op);
922 result = gfc_not (op1);
926 result = gfc_and (op1, op2);
930 result = gfc_or (op1, op2);
934 result = gfc_eqv (op1, op2);
938 result = gfc_neqv (op1, op2);
942 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
952 result->rank = p->rank;
953 result->where = p->where;
954 gfc_replace_expr (p, result);
960 /* Subroutine to simplify constructor expressions. Mutually recursive
961 with gfc_simplify_expr(). */
964 simplify_constructor (gfc_constructor *c, int type)
968 for (; c; c = c->next)
971 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
972 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
973 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
978 /* Try and simplify a copy. Replace the original if successful
979 but keep going through the constructor at all costs. Not
980 doing so can make a dog's dinner of complicated things. */
981 p = gfc_copy_expr (c->expr);
983 if (gfc_simplify_expr (p, type) == FAILURE)
989 gfc_replace_expr (c->expr, p);
997 /* Pull a single array element out of an array constructor. */
1000 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
1001 gfc_constructor **rval)
1003 unsigned long nelemen;
1015 mpz_init_set_ui (offset, 0);
1018 mpz_init_set_ui (span, 1);
1019 for (i = 0; i < ar->dimen; i++)
1021 e = gfc_copy_expr (ar->start[i]);
1022 if (e->expr_type != EXPR_CONSTANT)
1027 /* Check the bounds. */
1028 if ((ar->as->upper[i]
1029 && ar->as->upper[i]->expr_type == EXPR_CONSTANT
1030 && mpz_cmp (e->value.integer,
1031 ar->as->upper[i]->value.integer) > 0)
1033 (ar->as->lower[i]->expr_type == EXPR_CONSTANT
1034 && mpz_cmp (e->value.integer,
1035 ar->as->lower[i]->value.integer) < 0))
1037 gfc_error ("Index in dimension %d is out of bounds "
1038 "at %L", i + 1, &ar->c_where[i]);
1044 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1045 mpz_mul (delta, delta, span);
1046 mpz_add (offset, offset, delta);
1048 mpz_set_ui (tmp, 1);
1049 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1050 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1051 mpz_mul (span, span, tmp);
1054 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1080 /* Find a component of a structure constructor. */
1082 static gfc_constructor *
1083 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1085 gfc_component *comp;
1086 gfc_component *pick;
1088 comp = ref->u.c.sym->components;
1089 pick = ref->u.c.component;
1090 while (comp != pick)
1100 /* Replace an expression with the contents of a constructor, removing
1101 the subobject reference in the process. */
1104 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1110 e->ref = p->ref->next;
1111 p->ref->next = NULL;
1112 gfc_replace_expr (p, e);
1116 /* Pull an array section out of an array constructor. */
1119 find_array_section (gfc_expr *expr, gfc_ref *ref)
1125 long unsigned one = 1;
1127 mpz_t start[GFC_MAX_DIMENSIONS];
1128 mpz_t end[GFC_MAX_DIMENSIONS];
1129 mpz_t stride[GFC_MAX_DIMENSIONS];
1130 mpz_t delta[GFC_MAX_DIMENSIONS];
1131 mpz_t ctr[GFC_MAX_DIMENSIONS];
1137 gfc_constructor *cons;
1138 gfc_constructor *base;
1144 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1149 base = expr->value.constructor;
1150 expr->value.constructor = NULL;
1152 rank = ref->u.ar.as->rank;
1154 if (expr->shape == NULL)
1155 expr->shape = gfc_get_shape (rank);
1157 mpz_init_set_ui (delta_mpz, one);
1158 mpz_init_set_ui (nelts, one);
1161 /* Do the initialization now, so that we can cleanup without
1162 keeping track of where we were. */
1163 for (d = 0; d < rank; d++)
1165 mpz_init (delta[d]);
1166 mpz_init (start[d]);
1169 mpz_init (stride[d]);
1173 /* Build the counters to clock through the array reference. */
1175 for (d = 0; d < rank; d++)
1177 /* Make this stretch of code easier on the eye! */
1178 begin = ref->u.ar.start[d];
1179 finish = ref->u.ar.end[d];
1180 step = ref->u.ar.stride[d];
1181 lower = ref->u.ar.as->lower[d];
1182 upper = ref->u.ar.as->upper[d];
1184 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1188 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1194 gcc_assert (begin->rank == 1);
1195 gcc_assert (begin->shape);
1197 vecsub[d] = begin->value.constructor;
1198 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1199 mpz_mul (nelts, nelts, begin->shape[0]);
1200 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1203 for (c = vecsub[d]; c; c = c->next)
1205 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1206 || mpz_cmp (c->expr->value.integer,
1207 lower->value.integer) < 0)
1209 gfc_error ("index in dimension %d is out of bounds "
1210 "at %L", d + 1, &ref->u.ar.c_where[d]);
1218 if ((begin && begin->expr_type != EXPR_CONSTANT)
1219 || (finish && finish->expr_type != EXPR_CONSTANT)
1220 || (step && step->expr_type != EXPR_CONSTANT))
1226 /* Obtain the stride. */
1228 mpz_set (stride[d], step->value.integer);
1230 mpz_set_ui (stride[d], one);
1232 if (mpz_cmp_ui (stride[d], 0) == 0)
1233 mpz_set_ui (stride[d], one);
1235 /* Obtain the start value for the index. */
1237 mpz_set (start[d], begin->value.integer);
1239 mpz_set (start[d], lower->value.integer);
1241 mpz_set (ctr[d], start[d]);
1243 /* Obtain the end value for the index. */
1245 mpz_set (end[d], finish->value.integer);
1247 mpz_set (end[d], upper->value.integer);
1249 /* Separate 'if' because elements sometimes arrive with
1251 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1252 mpz_set (end [d], begin->value.integer);
1254 /* Check the bounds. */
1255 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1256 || mpz_cmp (end[d], upper->value.integer) > 0
1257 || mpz_cmp (ctr[d], lower->value.integer) < 0
1258 || mpz_cmp (end[d], lower->value.integer) < 0)
1260 gfc_error ("index in dimension %d is out of bounds "
1261 "at %L", d + 1, &ref->u.ar.c_where[d]);
1266 /* Calculate the number of elements and the shape. */
1267 mpz_set (tmp_mpz, stride[d]);
1268 mpz_add (tmp_mpz, end[d], tmp_mpz);
1269 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1270 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1271 mpz_mul (nelts, nelts, tmp_mpz);
1273 /* An element reference reduces the rank of the expression; don't
1274 add anything to the shape array. */
1275 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1276 mpz_set (expr->shape[shape_i++], tmp_mpz);
1279 /* Calculate the 'stride' (=delta) for conversion of the
1280 counter values into the index along the constructor. */
1281 mpz_set (delta[d], delta_mpz);
1282 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1283 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1284 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1291 /* Now clock through the array reference, calculating the index in
1292 the source constructor and transferring the elements to the new
1294 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1296 if (ref->u.ar.offset)
1297 mpz_set (ptr, ref->u.ar.offset->value.integer);
1299 mpz_init_set_ui (ptr, 0);
1302 for (d = 0; d < rank; d++)
1304 mpz_set (tmp_mpz, ctr[d]);
1305 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1306 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1307 mpz_add (ptr, ptr, tmp_mpz);
1309 if (!incr_ctr) continue;
1311 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1313 gcc_assert(vecsub[d]);
1315 if (!vecsub[d]->next)
1316 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1319 vecsub[d] = vecsub[d]->next;
1322 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1326 mpz_add (ctr[d], ctr[d], stride[d]);
1328 if (mpz_cmp_ui (stride[d], 0) > 0
1329 ? mpz_cmp (ctr[d], end[d]) > 0
1330 : mpz_cmp (ctr[d], end[d]) < 0)
1331 mpz_set (ctr[d], start[d]);
1337 /* There must be a better way of dealing with negative strides
1338 than resetting the index and the constructor pointer! */
1339 if (mpz_cmp (ptr, index) < 0)
1341 mpz_set_ui (index, 0);
1345 while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1347 mpz_add_ui (index, index, one);
1351 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1359 mpz_clear (delta_mpz);
1360 mpz_clear (tmp_mpz);
1362 for (d = 0; d < rank; d++)
1364 mpz_clear (delta[d]);
1365 mpz_clear (start[d]);
1368 mpz_clear (stride[d]);
1370 gfc_free_constructor (base);
1374 /* Pull a substring out of an expression. */
1377 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1384 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1385 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1388 *newp = gfc_copy_expr (p);
1389 gfc_free ((*newp)->value.character.string);
1391 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1392 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1393 length = end - start + 1;
1395 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1396 (*newp)->value.character.length = length;
1397 memcpy (chr, &p->value.character.string[start - 1],
1398 length * sizeof (gfc_char_t));
1405 /* Simplify a subobject reference of a constructor. This occurs when
1406 parameter variable values are substituted. */
1409 simplify_const_ref (gfc_expr *p)
1411 gfc_constructor *cons;
1416 switch (p->ref->type)
1419 switch (p->ref->u.ar.type)
1422 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1429 remove_subobject_ref (p, cons);
1433 if (find_array_section (p, p->ref) == FAILURE)
1435 p->ref->u.ar.type = AR_FULL;
1440 if (p->ref->next != NULL
1441 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1443 cons = p->value.constructor;
1444 for (; cons; cons = cons->next)
1446 cons->expr->ref = copy_ref (p->ref->next);
1447 simplify_const_ref (cons->expr);
1450 gfc_free_ref_list (p->ref);
1461 cons = find_component_ref (p->value.constructor, p->ref);
1462 remove_subobject_ref (p, cons);
1466 if (find_substring_ref (p, &newp) == FAILURE)
1469 gfc_replace_expr (p, newp);
1470 gfc_free_ref_list (p->ref);
1480 /* Simplify a chain of references. */
1483 simplify_ref_chain (gfc_ref *ref, int type)
1487 for (; ref; ref = ref->next)
1492 for (n = 0; n < ref->u.ar.dimen; n++)
1494 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1496 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1498 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1504 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1506 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1518 /* Try to substitute the value of a parameter variable. */
1521 simplify_parameter_variable (gfc_expr *p, int type)
1526 e = gfc_copy_expr (p->symtree->n.sym->value);
1532 /* Do not copy subobject refs for constant. */
1533 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1534 e->ref = copy_ref (p->ref);
1535 t = gfc_simplify_expr (e, type);
1537 /* Only use the simplification if it eliminated all subobject references. */
1538 if (t == SUCCESS && !e->ref)
1539 gfc_replace_expr (p, e);
1546 /* Given an expression, simplify it by collapsing constant
1547 expressions. Most simplification takes place when the expression
1548 tree is being constructed. If an intrinsic function is simplified
1549 at some point, we get called again to collapse the result against
1552 We work by recursively simplifying expression nodes, simplifying
1553 intrinsic functions where possible, which can lead to further
1554 constant collapsing. If an operator has constant operand(s), we
1555 rip the expression apart, and rebuild it, hoping that it becomes
1558 The expression type is defined for:
1559 0 Basic expression parsing
1560 1 Simplifying array constructors -- will substitute
1562 Returns FAILURE on error, SUCCESS otherwise.
1563 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1566 gfc_simplify_expr (gfc_expr *p, int type)
1568 gfc_actual_arglist *ap;
1573 switch (p->expr_type)
1580 for (ap = p->value.function.actual; ap; ap = ap->next)
1581 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1584 if (p->value.function.isym != NULL
1585 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1590 case EXPR_SUBSTRING:
1591 if (simplify_ref_chain (p->ref, type) == FAILURE)
1594 if (gfc_is_constant_expr (p))
1599 if (p->ref && p->ref->u.ss.start)
1601 gfc_extract_int (p->ref->u.ss.start, &start);
1602 start--; /* Convert from one-based to zero-based. */
1607 if (p->ref && p->ref->u.ss.end)
1608 gfc_extract_int (p->ref->u.ss.end, &end);
1610 end = p->value.character.length;
1612 s = gfc_get_wide_string (end - start + 2);
1613 memcpy (s, p->value.character.string + start,
1614 (end - start) * sizeof (gfc_char_t));
1615 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1616 gfc_free (p->value.character.string);
1617 p->value.character.string = s;
1618 p->value.character.length = end - start;
1619 p->ts.cl = gfc_get_charlen ();
1620 p->ts.cl->next = gfc_current_ns->cl_list;
1621 gfc_current_ns->cl_list = p->ts.cl;
1622 p->ts.cl->length = gfc_int_expr (p->value.character.length);
1623 gfc_free_ref_list (p->ref);
1625 p->expr_type = EXPR_CONSTANT;
1630 if (simplify_intrinsic_op (p, type) == FAILURE)
1635 /* Only substitute array parameter variables if we are in an
1636 initialization expression, or we want a subsection. */
1637 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1638 && (gfc_init_expr || p->ref
1639 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1641 if (simplify_parameter_variable (p, type) == FAILURE)
1648 gfc_simplify_iterator_var (p);
1651 /* Simplify subcomponent references. */
1652 if (simplify_ref_chain (p->ref, type) == FAILURE)
1657 case EXPR_STRUCTURE:
1659 if (simplify_ref_chain (p->ref, type) == FAILURE)
1662 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1665 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1666 && p->ref->u.ar.type == AR_FULL)
1667 gfc_expand_constructor (p);
1669 if (simplify_const_ref (p) == FAILURE)
1679 /* Returns the type of an expression with the exception that iterator
1680 variables are automatically integers no matter what else they may
1686 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1693 /* Check an intrinsic arithmetic operation to see if it is consistent
1694 with some type of expression. */
1696 static gfc_try check_init_expr (gfc_expr *);
1699 /* Scalarize an expression for an elemental intrinsic call. */
1702 scalarize_intrinsic_call (gfc_expr *e)
1704 gfc_actual_arglist *a, *b;
1705 gfc_constructor *args[5], *ctor, *new_ctor;
1706 gfc_expr *expr, *old;
1707 int n, i, rank[5], array_arg;
1709 /* Find which, if any, arguments are arrays. Assume that the old
1710 expression carries the type information and that the first arg
1711 that is an array expression carries all the shape information.*/
1713 a = e->value.function.actual;
1714 for (; a; a = a->next)
1717 if (a->expr->expr_type != EXPR_ARRAY)
1720 expr = gfc_copy_expr (a->expr);
1727 old = gfc_copy_expr (e);
1729 gfc_free_constructor (expr->value.constructor);
1730 expr->value.constructor = NULL;
1733 expr->where = old->where;
1734 expr->expr_type = EXPR_ARRAY;
1736 /* Copy the array argument constructors into an array, with nulls
1739 a = old->value.function.actual;
1740 for (; a; a = a->next)
1742 /* Check that this is OK for an initialization expression. */
1743 if (a->expr && check_init_expr (a->expr) == FAILURE)
1747 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1749 rank[n] = a->expr->rank;
1750 ctor = a->expr->symtree->n.sym->value->value.constructor;
1751 args[n] = gfc_copy_constructor (ctor);
1753 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1756 rank[n] = a->expr->rank;
1759 args[n] = gfc_copy_constructor (a->expr->value.constructor);
1767 /* Using the array argument as the master, step through the array
1768 calling the function for each element and advancing the array
1769 constructors together. */
1770 ctor = args[array_arg - 1];
1772 for (; ctor; ctor = ctor->next)
1774 if (expr->value.constructor == NULL)
1775 expr->value.constructor
1776 = new_ctor = gfc_get_constructor ();
1779 new_ctor->next = gfc_get_constructor ();
1780 new_ctor = new_ctor->next;
1782 new_ctor->expr = gfc_copy_expr (old);
1783 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1785 b = old->value.function.actual;
1786 for (i = 0; i < n; i++)
1789 new_ctor->expr->value.function.actual
1790 = a = gfc_get_actual_arglist ();
1793 a->next = gfc_get_actual_arglist ();
1797 a->expr = gfc_copy_expr (args[i]->expr);
1799 a->expr = gfc_copy_expr (b->expr);
1804 /* Simplify the function calls. If the simplification fails, the
1805 error will be flagged up down-stream or the library will deal
1807 gfc_simplify_expr (new_ctor->expr, 0);
1809 for (i = 0; i < n; i++)
1811 args[i] = args[i]->next;
1813 for (i = 1; i < n; i++)
1814 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1815 || (args[i] == NULL && args[array_arg - 1] != NULL)))
1821 gfc_free_expr (old);
1825 gfc_error_now ("elemental function arguments at %C are not compliant");
1828 gfc_free_expr (expr);
1829 gfc_free_expr (old);
1835 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1837 gfc_expr *op1 = e->value.op.op1;
1838 gfc_expr *op2 = e->value.op.op2;
1840 if ((*check_function) (op1) == FAILURE)
1843 switch (e->value.op.op)
1845 case INTRINSIC_UPLUS:
1846 case INTRINSIC_UMINUS:
1847 if (!numeric_type (et0 (op1)))
1852 case INTRINSIC_EQ_OS:
1854 case INTRINSIC_NE_OS:
1856 case INTRINSIC_GT_OS:
1858 case INTRINSIC_GE_OS:
1860 case INTRINSIC_LT_OS:
1862 case INTRINSIC_LE_OS:
1863 if ((*check_function) (op2) == FAILURE)
1866 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1867 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1869 gfc_error ("Numeric or CHARACTER operands are required in "
1870 "expression at %L", &e->where);
1875 case INTRINSIC_PLUS:
1876 case INTRINSIC_MINUS:
1877 case INTRINSIC_TIMES:
1878 case INTRINSIC_DIVIDE:
1879 case INTRINSIC_POWER:
1880 if ((*check_function) (op2) == FAILURE)
1883 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1886 if (e->value.op.op == INTRINSIC_POWER
1887 && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1889 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
1890 "exponent in an initialization "
1891 "expression at %L", &op2->where)
1898 case INTRINSIC_CONCAT:
1899 if ((*check_function) (op2) == FAILURE)
1902 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1904 gfc_error ("Concatenation operator in expression at %L "
1905 "must have two CHARACTER operands", &op1->where);
1909 if (op1->ts.kind != op2->ts.kind)
1911 gfc_error ("Concat operator at %L must concatenate strings of the "
1912 "same kind", &e->where);
1919 if (et0 (op1) != BT_LOGICAL)
1921 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1922 "operand", &op1->where);
1931 case INTRINSIC_NEQV:
1932 if ((*check_function) (op2) == FAILURE)
1935 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1937 gfc_error ("LOGICAL operands are required in expression at %L",
1944 case INTRINSIC_PARENTHESES:
1948 gfc_error ("Only intrinsic operators can be used in expression at %L",
1956 gfc_error ("Numeric operands are required in expression at %L", &e->where);
1963 check_init_expr_arguments (gfc_expr *e)
1965 gfc_actual_arglist *ap;
1967 for (ap = e->value.function.actual; ap; ap = ap->next)
1968 if (check_init_expr (ap->expr) == FAILURE)
1974 /* F95, 7.1.6.1, Initialization expressions, (7)
1975 F2003, 7.1.7 Initialization expression, (8) */
1978 check_inquiry (gfc_expr *e, int not_restricted)
1981 const char *const *functions;
1983 static const char *const inquiry_func_f95[] = {
1984 "lbound", "shape", "size", "ubound",
1985 "bit_size", "len", "kind",
1986 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1987 "precision", "radix", "range", "tiny",
1991 static const char *const inquiry_func_f2003[] = {
1992 "lbound", "shape", "size", "ubound",
1993 "bit_size", "len", "kind",
1994 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1995 "precision", "radix", "range", "tiny",
2000 gfc_actual_arglist *ap;
2002 if (!e->value.function.isym
2003 || !e->value.function.isym->inquiry)
2006 /* An undeclared parameter will get us here (PR25018). */
2007 if (e->symtree == NULL)
2010 name = e->symtree->n.sym->name;
2012 functions = (gfc_option.warn_std & GFC_STD_F2003)
2013 ? inquiry_func_f2003 : inquiry_func_f95;
2015 for (i = 0; functions[i]; i++)
2016 if (strcmp (functions[i], name) == 0)
2019 if (functions[i] == NULL)
2022 /* At this point we have an inquiry function with a variable argument. The
2023 type of the variable might be undefined, but we need it now, because the
2024 arguments of these functions are not allowed to be undefined. */
2026 for (ap = e->value.function.actual; ap; ap = ap->next)
2031 if (ap->expr->ts.type == BT_UNKNOWN)
2033 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2034 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2038 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2041 /* Assumed character length will not reduce to a constant expression
2042 with LEN, as required by the standard. */
2043 if (i == 5 && not_restricted
2044 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2045 && ap->expr->symtree->n.sym->ts.cl->length == NULL)
2047 gfc_error ("Assumed character length variable '%s' in constant "
2048 "expression at %L", e->symtree->n.sym->name, &e->where);
2051 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2059 /* F95, 7.1.6.1, Initialization expressions, (5)
2060 F2003, 7.1.7 Initialization expression, (5) */
2063 check_transformational (gfc_expr *e)
2065 static const char * const trans_func_f95[] = {
2066 "repeat", "reshape", "selected_int_kind",
2067 "selected_real_kind", "transfer", "trim", NULL
2073 if (!e->value.function.isym
2074 || !e->value.function.isym->transformational)
2077 name = e->symtree->n.sym->name;
2079 /* NULL() is dealt with below. */
2080 if (strcmp ("null", name) == 0)
2083 for (i = 0; trans_func_f95[i]; i++)
2084 if (strcmp (trans_func_f95[i], name) == 0)
2087 /* FIXME, F2003: implement translation of initialization
2088 expressions before enabling this check. For F95, error
2089 out if the transformational function is not in the list. */
2091 if (trans_func_f95[i] == NULL
2092 && gfc_notify_std (GFC_STD_F2003,
2093 "transformational intrinsic '%s' at %L is not permitted "
2094 "in an initialization expression", name, &e->where) == FAILURE)
2097 if (trans_func_f95[i] == NULL)
2099 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2100 "in an initialization expression", name, &e->where);
2105 return check_init_expr_arguments (e);
2109 /* F95, 7.1.6.1, Initialization expressions, (6)
2110 F2003, 7.1.7 Initialization expression, (6) */
2113 check_null (gfc_expr *e)
2115 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2118 return check_init_expr_arguments (e);
2123 check_elemental (gfc_expr *e)
2125 if (!e->value.function.isym
2126 || !e->value.function.isym->elemental)
2129 if (e->ts.type != BT_INTEGER
2130 && e->ts.type != BT_CHARACTER
2131 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2132 "nonstandard initialization expression at %L",
2133 &e->where) == FAILURE)
2136 return check_init_expr_arguments (e);
2141 check_conversion (gfc_expr *e)
2143 if (!e->value.function.isym
2144 || !e->value.function.isym->conversion)
2147 return check_init_expr_arguments (e);
2151 /* Verify that an expression is an initialization expression. A side
2152 effect is that the expression tree is reduced to a single constant
2153 node if all goes well. This would normally happen when the
2154 expression is constructed but function references are assumed to be
2155 intrinsics in the context of initialization expressions. If
2156 FAILURE is returned an error message has been generated. */
2159 check_init_expr (gfc_expr *e)
2167 switch (e->expr_type)
2170 t = check_intrinsic_op (e, check_init_expr);
2172 t = gfc_simplify_expr (e, 0);
2179 if ((m = check_specification_function (e)) != MATCH_YES)
2181 gfc_intrinsic_sym* isym;
2184 sym = e->symtree->n.sym;
2185 if (!gfc_is_intrinsic (sym, 0, e->where)
2186 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2188 gfc_error ("Function '%s' in initialization expression at %L "
2189 "must be an intrinsic or a specification function",
2190 e->symtree->n.sym->name, &e->where);
2194 if ((m = check_conversion (e)) == MATCH_NO
2195 && (m = check_inquiry (e, 1)) == MATCH_NO
2196 && (m = check_null (e)) == MATCH_NO
2197 && (m = check_transformational (e)) == MATCH_NO
2198 && (m = check_elemental (e)) == MATCH_NO)
2200 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2201 "in an initialization expression",
2202 e->symtree->n.sym->name, &e->where);
2206 /* Try to scalarize an elemental intrinsic function that has an
2208 isym = gfc_find_function (e->symtree->n.sym->name);
2209 if (isym && isym->elemental
2210 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2215 t = gfc_simplify_expr (e, 0);
2222 if (gfc_check_iter_variable (e) == SUCCESS)
2225 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2227 /* A PARAMETER shall not be used to define itself, i.e.
2228 REAL, PARAMETER :: x = transfer(0, x)
2230 if (!e->symtree->n.sym->value)
2232 gfc_error("PARAMETER '%s' is used at %L before its definition "
2233 "is complete", e->symtree->n.sym->name, &e->where);
2237 t = simplify_parameter_variable (e, 0);
2242 if (gfc_in_match_data ())
2247 if (e->symtree->n.sym->as)
2249 switch (e->symtree->n.sym->as->type)
2251 case AS_ASSUMED_SIZE:
2252 gfc_error ("Assumed size array '%s' at %L is not permitted "
2253 "in an initialization expression",
2254 e->symtree->n.sym->name, &e->where);
2257 case AS_ASSUMED_SHAPE:
2258 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2259 "in an initialization expression",
2260 e->symtree->n.sym->name, &e->where);
2264 gfc_error ("Deferred array '%s' at %L is not permitted "
2265 "in an initialization expression",
2266 e->symtree->n.sym->name, &e->where);
2270 gfc_error ("Array '%s' at %L is a variable, which does "
2271 "not reduce to a constant expression",
2272 e->symtree->n.sym->name, &e->where);
2280 gfc_error ("Parameter '%s' at %L has not been declared or is "
2281 "a variable, which does not reduce to a constant "
2282 "expression", e->symtree->n.sym->name, &e->where);
2291 case EXPR_SUBSTRING:
2292 t = check_init_expr (e->ref->u.ss.start);
2296 t = check_init_expr (e->ref->u.ss.end);
2298 t = gfc_simplify_expr (e, 0);
2302 case EXPR_STRUCTURE:
2306 t = gfc_check_constructor (e, check_init_expr);
2310 t = gfc_check_constructor (e, check_init_expr);
2314 t = gfc_expand_constructor (e);
2318 t = gfc_check_constructor_type (e);
2322 gfc_internal_error ("check_init_expr(): Unknown expression type");
2329 /* Match an initialization expression. We work by first matching an
2330 expression, then reducing it to a constant. */
2333 gfc_match_init_expr (gfc_expr **result)
2339 m = gfc_match_expr (&expr);
2344 t = gfc_resolve_expr (expr);
2346 t = check_init_expr (expr);
2351 gfc_free_expr (expr);
2355 if (expr->expr_type == EXPR_ARRAY
2356 && (gfc_check_constructor_type (expr) == FAILURE
2357 || gfc_expand_constructor (expr) == FAILURE))
2359 gfc_free_expr (expr);
2363 /* Not all inquiry functions are simplified to constant expressions
2364 so it is necessary to call check_inquiry again. */
2365 if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2366 && !gfc_in_match_data ())
2368 gfc_error ("Initialization expression didn't reduce %C");
2378 static gfc_try check_restricted (gfc_expr *);
2380 /* Given an actual argument list, test to see that each argument is a
2381 restricted expression and optionally if the expression type is
2382 integer or character. */
2385 restricted_args (gfc_actual_arglist *a)
2387 for (; a; a = a->next)
2389 if (check_restricted (a->expr) == FAILURE)
2397 /************* Restricted/specification expressions *************/
2400 /* Make sure a non-intrinsic function is a specification function. */
2403 external_spec_function (gfc_expr *e)
2407 f = e->value.function.esym;
2409 if (f->attr.proc == PROC_ST_FUNCTION)
2411 gfc_error ("Specification function '%s' at %L cannot be a statement "
2412 "function", f->name, &e->where);
2416 if (f->attr.proc == PROC_INTERNAL)
2418 gfc_error ("Specification function '%s' at %L cannot be an internal "
2419 "function", f->name, &e->where);
2423 if (!f->attr.pure && !f->attr.elemental)
2425 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2430 if (f->attr.recursive)
2432 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2433 f->name, &e->where);
2437 return restricted_args (e->value.function.actual);
2441 /* Check to see that a function reference to an intrinsic is a
2442 restricted expression. */
2445 restricted_intrinsic (gfc_expr *e)
2447 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2448 if (check_inquiry (e, 0) == MATCH_YES)
2451 return restricted_args (e->value.function.actual);
2455 /* Verify that an expression is a restricted expression. Like its
2456 cousin check_init_expr(), an error message is generated if we
2460 check_restricted (gfc_expr *e)
2468 switch (e->expr_type)
2471 t = check_intrinsic_op (e, check_restricted);
2473 t = gfc_simplify_expr (e, 0);
2478 t = e->value.function.esym ? external_spec_function (e)
2479 : restricted_intrinsic (e);
2483 sym = e->symtree->n.sym;
2486 /* If a dummy argument appears in a context that is valid for a
2487 restricted expression in an elemental procedure, it will have
2488 already been simplified away once we get here. Therefore we
2489 don't need to jump through hoops to distinguish valid from
2491 if (sym->attr.dummy && sym->ns == gfc_current_ns
2492 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2494 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2495 sym->name, &e->where);
2499 if (sym->attr.optional)
2501 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2502 sym->name, &e->where);
2506 if (sym->attr.intent == INTENT_OUT)
2508 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2509 sym->name, &e->where);
2513 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2514 processed in resolve.c(resolve_formal_arglist). This is done so
2515 that host associated dummy array indices are accepted (PR23446).
2516 This mechanism also does the same for the specification expressions
2517 of array-valued functions. */
2518 if (sym->attr.in_common
2519 || sym->attr.use_assoc
2521 || sym->attr.implied_index
2522 || sym->ns != gfc_current_ns
2523 || (sym->ns->proc_name != NULL
2524 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2525 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2531 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2532 sym->name, &e->where);
2541 case EXPR_SUBSTRING:
2542 t = gfc_specification_expr (e->ref->u.ss.start);
2546 t = gfc_specification_expr (e->ref->u.ss.end);
2548 t = gfc_simplify_expr (e, 0);
2552 case EXPR_STRUCTURE:
2553 t = gfc_check_constructor (e, check_restricted);
2557 t = gfc_check_constructor (e, check_restricted);
2561 gfc_internal_error ("check_restricted(): Unknown expression type");
2568 /* Check to see that an expression is a specification expression. If
2569 we return FAILURE, an error has been generated. */
2572 gfc_specification_expr (gfc_expr *e)
2578 if (e->ts.type != BT_INTEGER)
2580 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2581 &e->where, gfc_basic_typename (e->ts.type));
2585 if (e->expr_type == EXPR_FUNCTION
2586 && !e->value.function.isym
2587 && !e->value.function.esym
2588 && !gfc_pure (e->symtree->n.sym))
2590 gfc_error ("Function '%s' at %L must be PURE",
2591 e->symtree->n.sym->name, &e->where);
2592 /* Prevent repeat error messages. */
2593 e->symtree->n.sym->attr.pure = 1;
2599 gfc_error ("Expression at %L must be scalar", &e->where);
2603 if (gfc_simplify_expr (e, 0) == FAILURE)
2606 return check_restricted (e);
2610 /************** Expression conformance checks. *************/
2612 /* Given two expressions, make sure that the arrays are conformable. */
2615 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2617 int op1_flag, op2_flag, d;
2618 mpz_t op1_size, op2_size;
2621 if (op1->rank == 0 || op2->rank == 0)
2624 if (op1->rank != op2->rank)
2626 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
2627 op1->rank, op2->rank, &op1->where);
2633 for (d = 0; d < op1->rank; d++)
2635 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2636 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2638 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2640 gfc_error ("Different shape for %s at %L on dimension %d "
2641 "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
2642 (int) mpz_get_si (op1_size),
2643 (int) mpz_get_si (op2_size));
2649 mpz_clear (op1_size);
2651 mpz_clear (op2_size);
2661 /* Given an assignable expression and an arbitrary expression, make
2662 sure that the assignment can take place. */
2665 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2671 sym = lvalue->symtree->n.sym;
2673 /* Check INTENT(IN), unless the object itself is the component or
2674 sub-component of a pointer. */
2675 has_pointer = sym->attr.pointer;
2677 for (ref = lvalue->ref; ref; ref = ref->next)
2678 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2684 if (!has_pointer && sym->attr.intent == INTENT_IN)
2686 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2687 sym->name, &lvalue->where);
2691 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2692 variable local to a function subprogram. Its existence begins when
2693 execution of the function is initiated and ends when execution of the
2694 function is terminated...
2695 Therefore, the left hand side is no longer a variable, when it is: */
2696 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2697 && !sym->attr.external)
2702 /* (i) Use associated; */
2703 if (sym->attr.use_assoc)
2706 /* (ii) The assignment is in the main program; or */
2707 if (gfc_current_ns->proc_name->attr.is_main_program)
2710 /* (iii) A module or internal procedure... */
2711 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2712 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2713 && gfc_current_ns->parent
2714 && (!(gfc_current_ns->parent->proc_name->attr.function
2715 || gfc_current_ns->parent->proc_name->attr.subroutine)
2716 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2718 /* ... that is not a function... */
2719 if (!gfc_current_ns->proc_name->attr.function)
2722 /* ... or is not an entry and has a different name. */
2723 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2727 /* (iv) Host associated and not the function symbol or the
2728 parent result. This picks up sibling references, which
2729 cannot be entries. */
2730 if (!sym->attr.entry
2731 && sym->ns == gfc_current_ns->parent
2732 && sym != gfc_current_ns->proc_name
2733 && sym != gfc_current_ns->parent->proc_name->result)
2738 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2743 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2745 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2746 lvalue->rank, rvalue->rank, &lvalue->where);
2750 if (lvalue->ts.type == BT_UNKNOWN)
2752 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2757 if (rvalue->expr_type == EXPR_NULL)
2759 if (lvalue->symtree->n.sym->attr.pointer
2760 && lvalue->symtree->n.sym->attr.data)
2764 gfc_error ("NULL appears on right-hand side in assignment at %L",
2770 if (sym->attr.cray_pointee
2771 && lvalue->ref != NULL
2772 && lvalue->ref->u.ar.type == AR_FULL
2773 && lvalue->ref->u.ar.as->cp_was_assumed)
2775 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2776 "is illegal", &lvalue->where);
2780 /* This is possibly a typo: x = f() instead of x => f(). */
2781 if (gfc_option.warn_surprising
2782 && rvalue->expr_type == EXPR_FUNCTION
2783 && rvalue->symtree->n.sym->attr.pointer)
2784 gfc_warning ("POINTER valued function appears on right-hand side of "
2785 "assignment at %L", &rvalue->where);
2787 /* Check size of array assignments. */
2788 if (lvalue->rank != 0 && rvalue->rank != 0
2789 && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
2792 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
2793 && lvalue->symtree->n.sym->attr.data
2794 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
2795 "initialize non-integer variable '%s'",
2796 &rvalue->where, lvalue->symtree->n.sym->name)
2799 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
2800 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
2801 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2802 &rvalue->where) == FAILURE)
2805 /* Handle the case of a BOZ literal on the RHS. */
2806 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
2809 if (gfc_option.warn_surprising)
2810 gfc_warning ("BOZ literal at %L is bitwise transferred "
2811 "non-integer symbol '%s'", &rvalue->where,
2812 lvalue->symtree->n.sym->name);
2813 if (!gfc_convert_boz (rvalue, &lvalue->ts))
2815 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
2817 if (rc == ARITH_UNDERFLOW)
2818 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2819 ". This check can be disabled with the option "
2820 "-fno-range-check", &rvalue->where);
2821 else if (rc == ARITH_OVERFLOW)
2822 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2823 ". This check can be disabled with the option "
2824 "-fno-range-check", &rvalue->where);
2825 else if (rc == ARITH_NAN)
2826 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2827 ". This check can be disabled with the option "
2828 "-fno-range-check", &rvalue->where);
2833 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2836 /* Only DATA Statements come here. */
2839 /* Numeric can be converted to any other numeric. And Hollerith can be
2840 converted to any other type. */
2841 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2842 || rvalue->ts.type == BT_HOLLERITH)
2845 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
2848 gfc_error ("Incompatible types in DATA statement at %L; attempted "
2849 "conversion of %s to %s", &lvalue->where,
2850 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
2855 /* Assignment is the only case where character variables of different
2856 kind values can be converted into one another. */
2857 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
2859 if (lvalue->ts.kind != rvalue->ts.kind)
2860 gfc_convert_chartype (rvalue, &lvalue->ts);
2865 return gfc_convert_type (rvalue, &lvalue->ts, 1);
2869 /* Check that a pointer assignment is OK. We first check lvalue, and
2870 we only check rvalue if it's not an assignment to NULL() or a
2871 NULLIFY statement. */
2874 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
2876 symbol_attribute attr;
2879 int pointer, check_intent_in;
2881 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
2882 && !lvalue->symtree->n.sym->attr.proc_pointer)
2884 gfc_error ("Pointer assignment target is not a POINTER at %L",
2889 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
2890 && lvalue->symtree->n.sym->attr.use_assoc)
2892 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2893 "l-value since it is a procedure",
2894 lvalue->symtree->n.sym->name, &lvalue->where);
2899 /* Check INTENT(IN), unless the object itself is the component or
2900 sub-component of a pointer. */
2901 check_intent_in = 1;
2902 pointer = lvalue->symtree->n.sym->attr.pointer
2903 | lvalue->symtree->n.sym->attr.proc_pointer;
2905 for (ref = lvalue->ref; ref; ref = ref->next)
2908 check_intent_in = 0;
2910 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2914 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
2916 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2917 lvalue->symtree->n.sym->name, &lvalue->where);
2923 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
2927 is_pure = gfc_pure (NULL);
2929 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
2930 && lvalue->symtree->n.sym->value != rvalue)
2932 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
2936 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2937 kind, etc for lvalue and rvalue must match, and rvalue must be a
2938 pure variable if we're in a pure function. */
2939 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
2942 /* TODO checks on rvalue for a procedure pointer assignment. */
2943 if (lvalue->symtree->n.sym->attr.proc_pointer)
2946 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
2948 gfc_error ("Different types in pointer assignment at %L; attempted "
2949 "assignment of %s to %s", &lvalue->where,
2950 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
2954 if (lvalue->ts.kind != rvalue->ts.kind)
2956 gfc_error ("Different kind type parameters in pointer "
2957 "assignment at %L", &lvalue->where);
2961 if (lvalue->rank != rvalue->rank)
2963 gfc_error ("Different ranks in pointer assignment at %L",
2968 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2969 if (rvalue->expr_type == EXPR_NULL)
2972 if (lvalue->ts.type == BT_CHARACTER
2973 && lvalue->ts.cl && rvalue->ts.cl
2974 && lvalue->ts.cl->length && rvalue->ts.cl->length
2975 && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2976 rvalue->ts.cl->length)) == 1)
2978 gfc_error ("Different character lengths in pointer "
2979 "assignment at %L", &lvalue->where);
2983 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
2984 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
2986 attr = gfc_expr_attr (rvalue);
2987 if (!attr.target && !attr.pointer)
2989 gfc_error ("Pointer assignment target is neither TARGET "
2990 "nor POINTER at %L", &rvalue->where);
2994 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2996 gfc_error ("Bad target in pointer assignment in PURE "
2997 "procedure at %L", &rvalue->where);
3000 if (gfc_has_vector_index (rvalue))
3002 gfc_error ("Pointer assignment with vector subscript "
3003 "on rhs at %L", &rvalue->where);
3007 if (attr.is_protected && attr.use_assoc)
3009 gfc_error ("Pointer assignment target has PROTECTED "
3010 "attribute at %L", &rvalue->where);
3018 /* Relative of gfc_check_assign() except that the lvalue is a single
3019 symbol. Used for initialization assignments. */
3022 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3027 memset (&lvalue, '\0', sizeof (gfc_expr));
3029 lvalue.expr_type = EXPR_VARIABLE;
3030 lvalue.ts = sym->ts;
3032 lvalue.rank = sym->as->rank;
3033 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3034 lvalue.symtree->n.sym = sym;
3035 lvalue.where = sym->declared_at;
3037 if (sym->attr.pointer || sym->attr.proc_pointer)
3038 r = gfc_check_pointer_assign (&lvalue, rvalue);
3040 r = gfc_check_assign (&lvalue, rvalue, 1);
3042 gfc_free (lvalue.symtree);
3048 /* Get an expression for a default initializer. */
3051 gfc_default_initializer (gfc_typespec *ts)
3053 gfc_constructor *tail;
3057 /* See if we have a default initializer. */
3058 for (c = ts->derived->components; c; c = c->next)
3059 if (c->initializer || c->attr.allocatable)
3065 /* Build the constructor. */
3066 init = gfc_get_expr ();
3067 init->expr_type = EXPR_STRUCTURE;
3069 init->where = ts->derived->declared_at;
3072 for (c = ts->derived->components; c; c = c->next)
3075 init->value.constructor = tail = gfc_get_constructor ();
3078 tail->next = gfc_get_constructor ();
3083 tail->expr = gfc_copy_expr (c->initializer);
3085 if (c->attr.allocatable)
3087 tail->expr = gfc_get_expr ();
3088 tail->expr->expr_type = EXPR_NULL;
3089 tail->expr->ts = c->ts;
3096 /* Given a symbol, create an expression node with that symbol as a
3097 variable. If the symbol is array valued, setup a reference of the
3101 gfc_get_variable_expr (gfc_symtree *var)
3105 e = gfc_get_expr ();
3106 e->expr_type = EXPR_VARIABLE;
3108 e->ts = var->n.sym->ts;
3110 if (var->n.sym->as != NULL)
3112 e->rank = var->n.sym->as->rank;
3113 e->ref = gfc_get_ref ();
3114 e->ref->type = REF_ARRAY;
3115 e->ref->u.ar.type = AR_FULL;
3122 /* General expression traversal function. */
3125 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3126 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3131 gfc_actual_arglist *args;
3138 if ((*func) (expr, sym, &f))
3141 if (expr->ts.type == BT_CHARACTER
3143 && expr->ts.cl->length
3144 && expr->ts.cl->length->expr_type != EXPR_CONSTANT
3145 && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
3148 switch (expr->expr_type)
3151 for (args = expr->value.function.actual; args; args = args->next)
3153 if (gfc_traverse_expr (args->expr, sym, func, f))
3161 case EXPR_SUBSTRING:
3164 case EXPR_STRUCTURE:
3166 for (c = expr->value.constructor; c; c = c->next)
3168 if (gfc_traverse_expr (c->expr, sym, func, f))
3172 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3174 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3176 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3178 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3185 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3187 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3203 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3205 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3207 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3209 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3215 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3217 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3222 if (ref->u.c.component->ts.type == BT_CHARACTER
3223 && ref->u.c.component->ts.cl
3224 && ref->u.c.component->ts.cl->length
3225 && ref->u.c.component->ts.cl->length->expr_type
3227 && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
3231 if (ref->u.c.component->as)
3232 for (i = 0; i < ref->u.c.component->as->rank; i++)
3234 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3237 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3251 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3254 expr_set_symbols_referenced (gfc_expr *expr,
3255 gfc_symbol *sym ATTRIBUTE_UNUSED,
3256 int *f ATTRIBUTE_UNUSED)
3258 if (expr->expr_type != EXPR_VARIABLE)
3260 gfc_set_sym_referenced (expr->symtree->n.sym);
3265 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3267 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3271 /* Walk an expression tree and check each variable encountered for being typed.
3272 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3273 mode; this is for things in legacy-code like:
3275 INTEGER :: arr(n), n
3277 The namespace is needed for IMPLICIT typing. */
3279 static gfc_namespace* check_typed_ns;
3282 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3283 int* f ATTRIBUTE_UNUSED)
3287 if (e->expr_type != EXPR_VARIABLE)
3290 gcc_assert (e->symtree);
3291 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3294 return (t == FAILURE);
3298 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3302 /* If this is a top-level variable, do the check with strict given to us. */
3303 if (!strict && e->expr_type == EXPR_VARIABLE && !e->ref)
3304 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3306 /* Otherwise, walk the expression and do it strictly. */
3307 check_typed_ns = ns;
3308 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3310 return error_found ? FAILURE : SUCCESS;