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 mpc_clear (e->value.complex);
166 /* Free the representation. */
167 if (e->representation.string)
168 gfc_free (e->representation.string);
173 if (e->value.op.op1 != NULL)
174 gfc_free_expr (e->value.op.op1);
175 if (e->value.op.op2 != NULL)
176 gfc_free_expr (e->value.op.op2);
180 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 /* Insert a reference to the component of the given name.
329 Only to be used with CLASS containers. */
332 gfc_add_component_ref (gfc_expr *e, const char *name)
334 gfc_ref **tail = &(e->ref);
335 gfc_ref *next = NULL;
336 gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
337 while (*tail != NULL)
339 if ((*tail)->type == REF_COMPONENT)
340 derived = (*tail)->u.c.component->ts.u.derived;
341 if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
343 tail = &((*tail)->next);
345 if (*tail != NULL && strcmp (name, "$data") == 0)
347 (*tail) = gfc_get_ref();
348 (*tail)->next = next;
349 (*tail)->type = REF_COMPONENT;
350 (*tail)->u.c.sym = derived;
351 (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
352 gcc_assert((*tail)->u.c.component);
354 e->ts = (*tail)->u.c.component->ts;
358 /* Copy a shape array. */
361 gfc_copy_shape (mpz_t *shape, int rank)
369 new_shape = gfc_get_shape (rank);
371 for (n = 0; n < rank; n++)
372 mpz_init_set (new_shape[n], shape[n]);
378 /* Copy a shape array excluding dimension N, where N is an integer
379 constant expression. Dimensions are numbered in fortran style --
382 So, if the original shape array contains R elements
383 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
384 the result contains R-1 elements:
385 { s1 ... sN-1 sN+1 ... sR-1}
387 If anything goes wrong -- N is not a constant, its value is out
388 of range -- or anything else, just returns NULL. */
391 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
393 mpz_t *new_shape, *s;
399 || dim->expr_type != EXPR_CONSTANT
400 || dim->ts.type != BT_INTEGER)
403 n = mpz_get_si (dim->value.integer);
404 n--; /* Convert to zero based index. */
405 if (n < 0 || n >= rank)
408 s = new_shape = gfc_get_shape (rank - 1);
410 for (i = 0; i < rank; i++)
414 mpz_init_set (*s, shape[i]);
422 /* Given an expression pointer, return a copy of the expression. This
423 subroutine is recursive. */
426 gfc_copy_expr (gfc_expr *p)
438 switch (q->expr_type)
441 s = gfc_get_wide_string (p->value.character.length + 1);
442 q->value.character.string = s;
443 memcpy (s, p->value.character.string,
444 (p->value.character.length + 1) * sizeof (gfc_char_t));
448 /* Copy target representation, if it exists. */
449 if (p->representation.string)
451 c = XCNEWVEC (char, p->representation.length + 1);
452 q->representation.string = c;
453 memcpy (c, p->representation.string, (p->representation.length + 1));
456 /* Copy the values of any pointer components of p->value. */
460 mpz_init_set (q->value.integer, p->value.integer);
464 gfc_set_model_kind (q->ts.kind);
465 mpfr_init (q->value.real);
466 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
470 gfc_set_model_kind (q->ts.kind);
471 mpc_init2 (q->value.complex, mpfr_get_default_prec());
472 mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
476 if (p->representation.string)
477 q->value.character.string
478 = gfc_char_to_widechar (q->representation.string);
481 s = gfc_get_wide_string (p->value.character.length + 1);
482 q->value.character.string = s;
484 /* This is the case for the C_NULL_CHAR named constant. */
485 if (p->value.character.length == 0
486 && (p->ts.is_c_interop || p->ts.is_iso_c))
489 /* Need to set the length to 1 to make sure the NUL
490 terminator is copied. */
491 q->value.character.length = 1;
494 memcpy (s, p->value.character.string,
495 (p->value.character.length + 1) * sizeof (gfc_char_t));
503 break; /* Already done. */
507 /* Should never be reached. */
509 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
516 switch (q->value.op.op)
519 case INTRINSIC_PARENTHESES:
520 case INTRINSIC_UPLUS:
521 case INTRINSIC_UMINUS:
522 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
525 default: /* Binary operators. */
526 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
527 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
534 q->value.function.actual =
535 gfc_copy_actual_arglist (p->value.function.actual);
540 q->value.compcall.actual =
541 gfc_copy_actual_arglist (p->value.compcall.actual);
542 q->value.compcall.tbp = p->value.compcall.tbp;
547 q->value.constructor = gfc_copy_constructor (p->value.constructor);
555 q->shape = gfc_copy_shape (p->shape, p->rank);
557 q->ref = gfc_copy_ref (p->ref);
563 /* Return the maximum kind of two expressions. In general, higher
564 kind numbers mean more precision for numeric types. */
567 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
569 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
573 /* Returns nonzero if the type is numeric, zero otherwise. */
576 numeric_type (bt type)
578 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
582 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
585 gfc_numeric_ts (gfc_typespec *ts)
587 return numeric_type (ts->type);
591 /* Returns an expression node that is an integer constant. */
600 p->expr_type = EXPR_CONSTANT;
601 p->ts.type = BT_INTEGER;
602 p->ts.kind = gfc_default_integer_kind;
604 p->where = gfc_current_locus;
605 mpz_init_set_si (p->value.integer, i);
611 /* Returns an expression node that is a logical constant. */
614 gfc_logical_expr (int i, locus *where)
620 p->expr_type = EXPR_CONSTANT;
621 p->ts.type = BT_LOGICAL;
622 p->ts.kind = gfc_default_logical_kind;
625 where = &gfc_current_locus;
627 p->value.logical = i;
633 /* Return an expression node with an optional argument list attached.
634 A variable number of gfc_expr pointers are strung together in an
635 argument list with a NULL pointer terminating the list. */
638 gfc_build_conversion (gfc_expr *e)
643 p->expr_type = EXPR_FUNCTION;
645 p->value.function.actual = NULL;
647 p->value.function.actual = gfc_get_actual_arglist ();
648 p->value.function.actual->expr = e;
654 /* Given an expression node with some sort of numeric binary
655 expression, insert type conversions required to make the operands
656 have the same type. Conversion warnings are disabled if wconversion
659 The exception is that the operands of an exponential don't have to
660 have the same type. If possible, the base is promoted to the type
661 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
662 1.0**2 stays as it is. */
665 gfc_type_convert_binary (gfc_expr *e, int wconversion)
669 op1 = e->value.op.op1;
670 op2 = e->value.op.op2;
672 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
674 gfc_clear_ts (&e->ts);
678 /* Kind conversions of same type. */
679 if (op1->ts.type == op2->ts.type)
681 if (op1->ts.kind == op2->ts.kind)
683 /* No type conversions. */
688 if (op1->ts.kind > op2->ts.kind)
689 gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
691 gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
697 /* Integer combined with real or complex. */
698 if (op2->ts.type == BT_INTEGER)
702 /* Special case for ** operator. */
703 if (e->value.op.op == INTRINSIC_POWER)
706 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
710 if (op1->ts.type == BT_INTEGER)
713 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
717 /* Real combined with complex. */
718 e->ts.type = BT_COMPLEX;
719 if (op1->ts.kind > op2->ts.kind)
720 e->ts.kind = op1->ts.kind;
722 e->ts.kind = op2->ts.kind;
723 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
724 gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
725 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
726 gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
734 check_specification_function (gfc_expr *e)
741 sym = e->symtree->n.sym;
743 /* F95, 7.1.6.2; F2003, 7.1.7 */
745 && sym->attr.function
747 && !sym->attr.intrinsic
748 && !sym->attr.recursive
749 && sym->attr.proc != PROC_INTERNAL
750 && sym->attr.proc != PROC_ST_FUNCTION
751 && sym->attr.proc != PROC_UNKNOWN
752 && sym->formal == NULL)
758 /* Function to determine if an expression is constant or not. This
759 function expects that the expression has already been simplified. */
762 gfc_is_constant_expr (gfc_expr *e)
765 gfc_actual_arglist *arg;
771 switch (e->expr_type)
774 rv = (gfc_is_constant_expr (e->value.op.op1)
775 && (e->value.op.op2 == NULL
776 || gfc_is_constant_expr (e->value.op.op2)));
784 /* Specification functions are constant. */
785 if (check_specification_function (e) == MATCH_YES)
791 /* Call to intrinsic with at least one argument. */
793 if (e->value.function.isym && e->value.function.actual)
795 for (arg = e->value.function.actual; arg; arg = arg->next)
797 if (!gfc_is_constant_expr (arg->expr))
811 rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
812 && gfc_is_constant_expr (e->ref->u.ss.end));
817 for (c = e->value.constructor; c; c = c->next)
818 if (!gfc_is_constant_expr (c->expr))
826 rv = gfc_constant_ac (e);
830 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
837 /* Is true if an array reference is followed by a component or substring
840 is_subref_array (gfc_expr * e)
845 if (e->expr_type != EXPR_VARIABLE)
848 if (e->symtree->n.sym->attr.subref_array_pointer)
852 for (ref = e->ref; ref; ref = ref->next)
854 if (ref->type == REF_ARRAY
855 && ref->u.ar.type != AR_ELEMENT)
859 && ref->type != REF_ARRAY)
866 /* Try to collapse intrinsic expressions. */
869 simplify_intrinsic_op (gfc_expr *p, int type)
872 gfc_expr *op1, *op2, *result;
874 if (p->value.op.op == INTRINSIC_USER)
877 op1 = p->value.op.op1;
878 op2 = p->value.op.op2;
881 if (gfc_simplify_expr (op1, type) == FAILURE)
883 if (gfc_simplify_expr (op2, type) == FAILURE)
886 if (!gfc_is_constant_expr (op1)
887 || (op2 != NULL && !gfc_is_constant_expr (op2)))
891 p->value.op.op1 = NULL;
892 p->value.op.op2 = NULL;
896 case INTRINSIC_PARENTHESES:
897 result = gfc_parentheses (op1);
900 case INTRINSIC_UPLUS:
901 result = gfc_uplus (op1);
904 case INTRINSIC_UMINUS:
905 result = gfc_uminus (op1);
909 result = gfc_add (op1, op2);
912 case INTRINSIC_MINUS:
913 result = gfc_subtract (op1, op2);
916 case INTRINSIC_TIMES:
917 result = gfc_multiply (op1, op2);
920 case INTRINSIC_DIVIDE:
921 result = gfc_divide (op1, op2);
924 case INTRINSIC_POWER:
925 result = gfc_power (op1, op2);
928 case INTRINSIC_CONCAT:
929 result = gfc_concat (op1, op2);
933 case INTRINSIC_EQ_OS:
934 result = gfc_eq (op1, op2, op);
938 case INTRINSIC_NE_OS:
939 result = gfc_ne (op1, op2, op);
943 case INTRINSIC_GT_OS:
944 result = gfc_gt (op1, op2, op);
948 case INTRINSIC_GE_OS:
949 result = gfc_ge (op1, op2, op);
953 case INTRINSIC_LT_OS:
954 result = gfc_lt (op1, op2, op);
958 case INTRINSIC_LE_OS:
959 result = gfc_le (op1, op2, op);
963 result = gfc_not (op1);
967 result = gfc_and (op1, op2);
971 result = gfc_or (op1, op2);
975 result = gfc_eqv (op1, op2);
979 result = gfc_neqv (op1, op2);
983 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
993 result->rank = p->rank;
994 result->where = p->where;
995 gfc_replace_expr (p, result);
1001 /* Subroutine to simplify constructor expressions. Mutually recursive
1002 with gfc_simplify_expr(). */
1005 simplify_constructor (gfc_constructor *c, int type)
1009 for (; c; c = c->next)
1012 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
1013 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
1014 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
1019 /* Try and simplify a copy. Replace the original if successful
1020 but keep going through the constructor at all costs. Not
1021 doing so can make a dog's dinner of complicated things. */
1022 p = gfc_copy_expr (c->expr);
1024 if (gfc_simplify_expr (p, type) == FAILURE)
1030 gfc_replace_expr (c->expr, p);
1038 /* Pull a single array element out of an array constructor. */
1041 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
1042 gfc_constructor **rval)
1044 unsigned long nelemen;
1056 mpz_init_set_ui (offset, 0);
1059 mpz_init_set_ui (span, 1);
1060 for (i = 0; i < ar->dimen; i++)
1062 if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1063 || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1070 e = gfc_copy_expr (ar->start[i]);
1071 if (e->expr_type != EXPR_CONSTANT)
1077 gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1078 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1080 /* Check the bounds. */
1081 if ((ar->as->upper[i]
1082 && mpz_cmp (e->value.integer,
1083 ar->as->upper[i]->value.integer) > 0)
1084 || (mpz_cmp (e->value.integer,
1085 ar->as->lower[i]->value.integer) < 0))
1087 gfc_error ("Index in dimension %d is out of bounds "
1088 "at %L", i + 1, &ar->c_where[i]);
1094 mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1095 mpz_mul (delta, delta, span);
1096 mpz_add (offset, offset, delta);
1098 mpz_set_ui (tmp, 1);
1099 mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1100 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1101 mpz_mul (span, span, tmp);
1104 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1129 /* Find a component of a structure constructor. */
1131 static gfc_constructor *
1132 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1134 gfc_component *comp;
1135 gfc_component *pick;
1137 comp = ref->u.c.sym->components;
1138 pick = ref->u.c.component;
1139 while (comp != pick)
1149 /* Replace an expression with the contents of a constructor, removing
1150 the subobject reference in the process. */
1153 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1159 e->ref = p->ref->next;
1160 p->ref->next = NULL;
1161 gfc_replace_expr (p, e);
1165 /* Pull an array section out of an array constructor. */
1168 find_array_section (gfc_expr *expr, gfc_ref *ref)
1174 long unsigned one = 1;
1176 mpz_t start[GFC_MAX_DIMENSIONS];
1177 mpz_t end[GFC_MAX_DIMENSIONS];
1178 mpz_t stride[GFC_MAX_DIMENSIONS];
1179 mpz_t delta[GFC_MAX_DIMENSIONS];
1180 mpz_t ctr[GFC_MAX_DIMENSIONS];
1186 gfc_constructor *cons;
1187 gfc_constructor *base;
1193 gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1198 base = expr->value.constructor;
1199 expr->value.constructor = NULL;
1201 rank = ref->u.ar.as->rank;
1203 if (expr->shape == NULL)
1204 expr->shape = gfc_get_shape (rank);
1206 mpz_init_set_ui (delta_mpz, one);
1207 mpz_init_set_ui (nelts, one);
1210 /* Do the initialization now, so that we can cleanup without
1211 keeping track of where we were. */
1212 for (d = 0; d < rank; d++)
1214 mpz_init (delta[d]);
1215 mpz_init (start[d]);
1218 mpz_init (stride[d]);
1222 /* Build the counters to clock through the array reference. */
1224 for (d = 0; d < rank; d++)
1226 /* Make this stretch of code easier on the eye! */
1227 begin = ref->u.ar.start[d];
1228 finish = ref->u.ar.end[d];
1229 step = ref->u.ar.stride[d];
1230 lower = ref->u.ar.as->lower[d];
1231 upper = ref->u.ar.as->upper[d];
1233 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1237 if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1243 gcc_assert (begin->rank == 1);
1244 /* Zero-sized arrays have no shape and no elements, stop early. */
1247 mpz_init_set_ui (nelts, 0);
1251 vecsub[d] = begin->value.constructor;
1252 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1253 mpz_mul (nelts, nelts, begin->shape[0]);
1254 mpz_set (expr->shape[shape_i++], begin->shape[0]);
1257 for (c = vecsub[d]; c; c = c->next)
1259 if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1260 || mpz_cmp (c->expr->value.integer,
1261 lower->value.integer) < 0)
1263 gfc_error ("index in dimension %d is out of bounds "
1264 "at %L", d + 1, &ref->u.ar.c_where[d]);
1272 if ((begin && begin->expr_type != EXPR_CONSTANT)
1273 || (finish && finish->expr_type != EXPR_CONSTANT)
1274 || (step && step->expr_type != EXPR_CONSTANT))
1280 /* Obtain the stride. */
1282 mpz_set (stride[d], step->value.integer);
1284 mpz_set_ui (stride[d], one);
1286 if (mpz_cmp_ui (stride[d], 0) == 0)
1287 mpz_set_ui (stride[d], one);
1289 /* Obtain the start value for the index. */
1291 mpz_set (start[d], begin->value.integer);
1293 mpz_set (start[d], lower->value.integer);
1295 mpz_set (ctr[d], start[d]);
1297 /* Obtain the end value for the index. */
1299 mpz_set (end[d], finish->value.integer);
1301 mpz_set (end[d], upper->value.integer);
1303 /* Separate 'if' because elements sometimes arrive with
1305 if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1306 mpz_set (end [d], begin->value.integer);
1308 /* Check the bounds. */
1309 if (mpz_cmp (ctr[d], upper->value.integer) > 0
1310 || mpz_cmp (end[d], upper->value.integer) > 0
1311 || mpz_cmp (ctr[d], lower->value.integer) < 0
1312 || mpz_cmp (end[d], lower->value.integer) < 0)
1314 gfc_error ("index in dimension %d is out of bounds "
1315 "at %L", d + 1, &ref->u.ar.c_where[d]);
1320 /* Calculate the number of elements and the shape. */
1321 mpz_set (tmp_mpz, stride[d]);
1322 mpz_add (tmp_mpz, end[d], tmp_mpz);
1323 mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1324 mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1325 mpz_mul (nelts, nelts, tmp_mpz);
1327 /* An element reference reduces the rank of the expression; don't
1328 add anything to the shape array. */
1329 if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1330 mpz_set (expr->shape[shape_i++], tmp_mpz);
1333 /* Calculate the 'stride' (=delta) for conversion of the
1334 counter values into the index along the constructor. */
1335 mpz_set (delta[d], delta_mpz);
1336 mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1337 mpz_add_ui (tmp_mpz, tmp_mpz, one);
1338 mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1345 /* Now clock through the array reference, calculating the index in
1346 the source constructor and transferring the elements to the new
1348 for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1350 if (ref->u.ar.offset)
1351 mpz_set (ptr, ref->u.ar.offset->value.integer);
1353 mpz_init_set_ui (ptr, 0);
1356 for (d = 0; d < rank; d++)
1358 mpz_set (tmp_mpz, ctr[d]);
1359 mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1360 mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1361 mpz_add (ptr, ptr, tmp_mpz);
1363 if (!incr_ctr) continue;
1365 if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
1367 gcc_assert(vecsub[d]);
1369 if (!vecsub[d]->next)
1370 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1373 vecsub[d] = vecsub[d]->next;
1376 mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1380 mpz_add (ctr[d], ctr[d], stride[d]);
1382 if (mpz_cmp_ui (stride[d], 0) > 0
1383 ? mpz_cmp (ctr[d], end[d]) > 0
1384 : mpz_cmp (ctr[d], end[d]) < 0)
1385 mpz_set (ctr[d], start[d]);
1391 /* There must be a better way of dealing with negative strides
1392 than resetting the index and the constructor pointer! */
1393 if (mpz_cmp (ptr, index) < 0)
1395 mpz_set_ui (index, 0);
1399 while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1401 mpz_add_ui (index, index, one);
1405 gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1413 mpz_clear (delta_mpz);
1414 mpz_clear (tmp_mpz);
1416 for (d = 0; d < rank; d++)
1418 mpz_clear (delta[d]);
1419 mpz_clear (start[d]);
1422 mpz_clear (stride[d]);
1424 gfc_free_constructor (base);
1428 /* Pull a substring out of an expression. */
1431 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1438 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1439 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1442 *newp = gfc_copy_expr (p);
1443 gfc_free ((*newp)->value.character.string);
1445 end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1446 start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1447 length = end - start + 1;
1449 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1450 (*newp)->value.character.length = length;
1451 memcpy (chr, &p->value.character.string[start - 1],
1452 length * sizeof (gfc_char_t));
1459 /* Simplify a subobject reference of a constructor. This occurs when
1460 parameter variable values are substituted. */
1463 simplify_const_ref (gfc_expr *p)
1465 gfc_constructor *cons;
1470 switch (p->ref->type)
1473 switch (p->ref->u.ar.type)
1476 if (find_array_element (p->value.constructor, &p->ref->u.ar,
1483 remove_subobject_ref (p, cons);
1487 if (find_array_section (p, p->ref) == FAILURE)
1489 p->ref->u.ar.type = AR_FULL;
1494 if (p->ref->next != NULL
1495 && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1497 cons = p->value.constructor;
1498 for (; cons; cons = cons->next)
1500 cons->expr->ref = gfc_copy_ref (p->ref->next);
1501 if (simplify_const_ref (cons->expr) == FAILURE)
1505 /* If this is a CHARACTER array and we possibly took a
1506 substring out of it, update the type-spec's character
1507 length according to the first element (as all should have
1508 the same length). */
1509 if (p->ts.type == BT_CHARACTER)
1513 gcc_assert (p->ref->next);
1514 gcc_assert (!p->ref->next->next);
1515 gcc_assert (p->ref->next->type == REF_SUBSTRING);
1517 if (p->value.constructor)
1519 const gfc_expr* first = p->value.constructor->expr;
1520 gcc_assert (first->expr_type == EXPR_CONSTANT);
1521 gcc_assert (first->ts.type == BT_CHARACTER);
1522 string_len = first->value.character.length;
1528 p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1531 gfc_free_expr (p->ts.u.cl->length);
1533 p->ts.u.cl->length = gfc_int_expr (string_len);
1536 gfc_free_ref_list (p->ref);
1547 cons = find_component_ref (p->value.constructor, p->ref);
1548 remove_subobject_ref (p, cons);
1552 if (find_substring_ref (p, &newp) == FAILURE)
1555 gfc_replace_expr (p, newp);
1556 gfc_free_ref_list (p->ref);
1566 /* Simplify a chain of references. */
1569 simplify_ref_chain (gfc_ref *ref, int type)
1573 for (; ref; ref = ref->next)
1578 for (n = 0; n < ref->u.ar.dimen; n++)
1580 if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1582 if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1584 if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1590 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1592 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1604 /* Try to substitute the value of a parameter variable. */
1607 simplify_parameter_variable (gfc_expr *p, int type)
1612 e = gfc_copy_expr (p->symtree->n.sym->value);
1618 /* Do not copy subobject refs for constant. */
1619 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1620 e->ref = gfc_copy_ref (p->ref);
1621 t = gfc_simplify_expr (e, type);
1623 /* Only use the simplification if it eliminated all subobject references. */
1624 if (t == SUCCESS && !e->ref)
1625 gfc_replace_expr (p, e);
1632 /* Given an expression, simplify it by collapsing constant
1633 expressions. Most simplification takes place when the expression
1634 tree is being constructed. If an intrinsic function is simplified
1635 at some point, we get called again to collapse the result against
1638 We work by recursively simplifying expression nodes, simplifying
1639 intrinsic functions where possible, which can lead to further
1640 constant collapsing. If an operator has constant operand(s), we
1641 rip the expression apart, and rebuild it, hoping that it becomes
1644 The expression type is defined for:
1645 0 Basic expression parsing
1646 1 Simplifying array constructors -- will substitute
1648 Returns FAILURE on error, SUCCESS otherwise.
1649 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1652 gfc_simplify_expr (gfc_expr *p, int type)
1654 gfc_actual_arglist *ap;
1659 switch (p->expr_type)
1666 for (ap = p->value.function.actual; ap; ap = ap->next)
1667 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1670 if (p->value.function.isym != NULL
1671 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1676 case EXPR_SUBSTRING:
1677 if (simplify_ref_chain (p->ref, type) == FAILURE)
1680 if (gfc_is_constant_expr (p))
1686 if (p->ref && p->ref->u.ss.start)
1688 gfc_extract_int (p->ref->u.ss.start, &start);
1689 start--; /* Convert from one-based to zero-based. */
1692 end = p->value.character.length;
1693 if (p->ref && p->ref->u.ss.end)
1694 gfc_extract_int (p->ref->u.ss.end, &end);
1696 s = gfc_get_wide_string (end - start + 2);
1697 memcpy (s, p->value.character.string + start,
1698 (end - start) * sizeof (gfc_char_t));
1699 s[end - start + 1] = '\0'; /* TODO: C-style string. */
1700 gfc_free (p->value.character.string);
1701 p->value.character.string = s;
1702 p->value.character.length = end - start;
1703 p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1704 p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
1705 gfc_free_ref_list (p->ref);
1707 p->expr_type = EXPR_CONSTANT;
1712 if (simplify_intrinsic_op (p, type) == FAILURE)
1717 /* Only substitute array parameter variables if we are in an
1718 initialization expression, or we want a subsection. */
1719 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1720 && (gfc_init_expr || p->ref
1721 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1723 if (simplify_parameter_variable (p, type) == FAILURE)
1730 gfc_simplify_iterator_var (p);
1733 /* Simplify subcomponent references. */
1734 if (simplify_ref_chain (p->ref, type) == FAILURE)
1739 case EXPR_STRUCTURE:
1741 if (simplify_ref_chain (p->ref, type) == FAILURE)
1744 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1747 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1748 && p->ref->u.ar.type == AR_FULL)
1749 gfc_expand_constructor (p);
1751 if (simplify_const_ref (p) == FAILURE)
1766 /* Returns the type of an expression with the exception that iterator
1767 variables are automatically integers no matter what else they may
1773 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1780 /* Check an intrinsic arithmetic operation to see if it is consistent
1781 with some type of expression. */
1783 static gfc_try check_init_expr (gfc_expr *);
1786 /* Scalarize an expression for an elemental intrinsic call. */
1789 scalarize_intrinsic_call (gfc_expr *e)
1791 gfc_actual_arglist *a, *b;
1792 gfc_constructor *args[5], *ctor, *new_ctor;
1793 gfc_expr *expr, *old;
1794 int n, i, rank[5], array_arg;
1796 /* Find which, if any, arguments are arrays. Assume that the old
1797 expression carries the type information and that the first arg
1798 that is an array expression carries all the shape information.*/
1800 a = e->value.function.actual;
1801 for (; a; a = a->next)
1804 if (a->expr->expr_type != EXPR_ARRAY)
1807 expr = gfc_copy_expr (a->expr);
1814 old = gfc_copy_expr (e);
1816 gfc_free_constructor (expr->value.constructor);
1817 expr->value.constructor = NULL;
1820 expr->where = old->where;
1821 expr->expr_type = EXPR_ARRAY;
1823 /* Copy the array argument constructors into an array, with nulls
1826 a = old->value.function.actual;
1827 for (; a; a = a->next)
1829 /* Check that this is OK for an initialization expression. */
1830 if (a->expr && check_init_expr (a->expr) == FAILURE)
1834 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1836 rank[n] = a->expr->rank;
1837 ctor = a->expr->symtree->n.sym->value->value.constructor;
1838 args[n] = gfc_copy_constructor (ctor);
1840 else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1843 rank[n] = a->expr->rank;
1846 args[n] = gfc_copy_constructor (a->expr->value.constructor);
1854 /* Using the array argument as the master, step through the array
1855 calling the function for each element and advancing the array
1856 constructors together. */
1857 ctor = args[array_arg - 1];
1859 for (; ctor; ctor = ctor->next)
1861 if (expr->value.constructor == NULL)
1862 expr->value.constructor
1863 = new_ctor = gfc_get_constructor ();
1866 new_ctor->next = gfc_get_constructor ();
1867 new_ctor = new_ctor->next;
1869 new_ctor->expr = gfc_copy_expr (old);
1870 gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1872 b = old->value.function.actual;
1873 for (i = 0; i < n; i++)
1876 new_ctor->expr->value.function.actual
1877 = a = gfc_get_actual_arglist ();
1880 a->next = gfc_get_actual_arglist ();
1884 a->expr = gfc_copy_expr (args[i]->expr);
1886 a->expr = gfc_copy_expr (b->expr);
1891 /* Simplify the function calls. If the simplification fails, the
1892 error will be flagged up down-stream or the library will deal
1894 gfc_simplify_expr (new_ctor->expr, 0);
1896 for (i = 0; i < n; i++)
1898 args[i] = args[i]->next;
1900 for (i = 1; i < n; i++)
1901 if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1902 || (args[i] == NULL && args[array_arg - 1] != NULL)))
1908 gfc_free_expr (old);
1912 gfc_error_now ("elemental function arguments at %C are not compliant");
1915 gfc_free_expr (expr);
1916 gfc_free_expr (old);
1922 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1924 gfc_expr *op1 = e->value.op.op1;
1925 gfc_expr *op2 = e->value.op.op2;
1927 if ((*check_function) (op1) == FAILURE)
1930 switch (e->value.op.op)
1932 case INTRINSIC_UPLUS:
1933 case INTRINSIC_UMINUS:
1934 if (!numeric_type (et0 (op1)))
1939 case INTRINSIC_EQ_OS:
1941 case INTRINSIC_NE_OS:
1943 case INTRINSIC_GT_OS:
1945 case INTRINSIC_GE_OS:
1947 case INTRINSIC_LT_OS:
1949 case INTRINSIC_LE_OS:
1950 if ((*check_function) (op2) == FAILURE)
1953 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1954 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1956 gfc_error ("Numeric or CHARACTER operands are required in "
1957 "expression at %L", &e->where);
1962 case INTRINSIC_PLUS:
1963 case INTRINSIC_MINUS:
1964 case INTRINSIC_TIMES:
1965 case INTRINSIC_DIVIDE:
1966 case INTRINSIC_POWER:
1967 if ((*check_function) (op2) == FAILURE)
1970 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1975 case INTRINSIC_CONCAT:
1976 if ((*check_function) (op2) == FAILURE)
1979 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1981 gfc_error ("Concatenation operator in expression at %L "
1982 "must have two CHARACTER operands", &op1->where);
1986 if (op1->ts.kind != op2->ts.kind)
1988 gfc_error ("Concat operator at %L must concatenate strings of the "
1989 "same kind", &e->where);
1996 if (et0 (op1) != BT_LOGICAL)
1998 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1999 "operand", &op1->where);
2008 case INTRINSIC_NEQV:
2009 if ((*check_function) (op2) == FAILURE)
2012 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2014 gfc_error ("LOGICAL operands are required in expression at %L",
2021 case INTRINSIC_PARENTHESES:
2025 gfc_error ("Only intrinsic operators can be used in expression at %L",
2033 gfc_error ("Numeric operands are required in expression at %L", &e->where);
2038 /* F2003, 7.1.7 (3): In init expression, allocatable components
2039 must not be data-initialized. */
2041 check_alloc_comp_init (gfc_expr *e)
2044 gfc_constructor *ctor;
2046 gcc_assert (e->expr_type == EXPR_STRUCTURE);
2047 gcc_assert (e->ts.type == BT_DERIVED);
2049 for (c = e->ts.u.derived->components, ctor = e->value.constructor;
2050 c; c = c->next, ctor = ctor->next)
2052 if (c->attr.allocatable
2053 && ctor->expr->expr_type != EXPR_NULL)
2055 gfc_error("Invalid initialization expression for ALLOCATABLE "
2056 "component '%s' in structure constructor at %L",
2057 c->name, &ctor->expr->where);
2066 check_init_expr_arguments (gfc_expr *e)
2068 gfc_actual_arglist *ap;
2070 for (ap = e->value.function.actual; ap; ap = ap->next)
2071 if (check_init_expr (ap->expr) == FAILURE)
2077 static gfc_try check_restricted (gfc_expr *);
2079 /* F95, 7.1.6.1, Initialization expressions, (7)
2080 F2003, 7.1.7 Initialization expression, (8) */
2083 check_inquiry (gfc_expr *e, int not_restricted)
2086 const char *const *functions;
2088 static const char *const inquiry_func_f95[] = {
2089 "lbound", "shape", "size", "ubound",
2090 "bit_size", "len", "kind",
2091 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2092 "precision", "radix", "range", "tiny",
2096 static const char *const inquiry_func_f2003[] = {
2097 "lbound", "shape", "size", "ubound",
2098 "bit_size", "len", "kind",
2099 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2100 "precision", "radix", "range", "tiny",
2105 gfc_actual_arglist *ap;
2107 if (!e->value.function.isym
2108 || !e->value.function.isym->inquiry)
2111 /* An undeclared parameter will get us here (PR25018). */
2112 if (e->symtree == NULL)
2115 name = e->symtree->n.sym->name;
2117 functions = (gfc_option.warn_std & GFC_STD_F2003)
2118 ? inquiry_func_f2003 : inquiry_func_f95;
2120 for (i = 0; functions[i]; i++)
2121 if (strcmp (functions[i], name) == 0)
2124 if (functions[i] == NULL)
2127 /* At this point we have an inquiry function with a variable argument. The
2128 type of the variable might be undefined, but we need it now, because the
2129 arguments of these functions are not allowed to be undefined. */
2131 for (ap = e->value.function.actual; ap; ap = ap->next)
2136 if (ap->expr->ts.type == BT_UNKNOWN)
2138 if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2139 && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2143 ap->expr->ts = ap->expr->symtree->n.sym->ts;
2146 /* Assumed character length will not reduce to a constant expression
2147 with LEN, as required by the standard. */
2148 if (i == 5 && not_restricted
2149 && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2150 && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
2152 gfc_error ("Assumed character length variable '%s' in constant "
2153 "expression at %L", e->symtree->n.sym->name, &e->where);
2156 else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2159 if (not_restricted == 0
2160 && ap->expr->expr_type != EXPR_VARIABLE
2161 && check_restricted (ap->expr) == FAILURE)
2169 /* F95, 7.1.6.1, Initialization expressions, (5)
2170 F2003, 7.1.7 Initialization expression, (5) */
2173 check_transformational (gfc_expr *e)
2175 static const char * const trans_func_f95[] = {
2176 "repeat", "reshape", "selected_int_kind",
2177 "selected_real_kind", "transfer", "trim", NULL
2180 static const char * const trans_func_f2003[] = {
2181 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2182 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2183 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2184 "trim", "unpack", NULL
2189 const char *const *functions;
2191 if (!e->value.function.isym
2192 || !e->value.function.isym->transformational)
2195 name = e->symtree->n.sym->name;
2197 functions = (gfc_option.allow_std & GFC_STD_F2003)
2198 ? trans_func_f2003 : trans_func_f95;
2200 /* NULL() is dealt with below. */
2201 if (strcmp ("null", name) == 0)
2204 for (i = 0; functions[i]; i++)
2205 if (strcmp (functions[i], name) == 0)
2208 if (functions[i] == NULL)
2210 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2211 "in an initialization expression", name, &e->where);
2215 return check_init_expr_arguments (e);
2219 /* F95, 7.1.6.1, Initialization expressions, (6)
2220 F2003, 7.1.7 Initialization expression, (6) */
2223 check_null (gfc_expr *e)
2225 if (strcmp ("null", e->symtree->n.sym->name) != 0)
2228 return check_init_expr_arguments (e);
2233 check_elemental (gfc_expr *e)
2235 if (!e->value.function.isym
2236 || !e->value.function.isym->elemental)
2239 if (e->ts.type != BT_INTEGER
2240 && e->ts.type != BT_CHARACTER
2241 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2242 "nonstandard initialization expression at %L",
2243 &e->where) == FAILURE)
2246 return check_init_expr_arguments (e);
2251 check_conversion (gfc_expr *e)
2253 if (!e->value.function.isym
2254 || !e->value.function.isym->conversion)
2257 return check_init_expr_arguments (e);
2261 /* Verify that an expression is an initialization expression. A side
2262 effect is that the expression tree is reduced to a single constant
2263 node if all goes well. This would normally happen when the
2264 expression is constructed but function references are assumed to be
2265 intrinsics in the context of initialization expressions. If
2266 FAILURE is returned an error message has been generated. */
2269 check_init_expr (gfc_expr *e)
2277 switch (e->expr_type)
2280 t = check_intrinsic_op (e, check_init_expr);
2282 t = gfc_simplify_expr (e, 0);
2290 gfc_intrinsic_sym* isym;
2293 sym = e->symtree->n.sym;
2294 if (!gfc_is_intrinsic (sym, 0, e->where)
2295 || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2297 gfc_error ("Function '%s' in initialization expression at %L "
2298 "must be an intrinsic function",
2299 e->symtree->n.sym->name, &e->where);
2303 if ((m = check_conversion (e)) == MATCH_NO
2304 && (m = check_inquiry (e, 1)) == MATCH_NO
2305 && (m = check_null (e)) == MATCH_NO
2306 && (m = check_transformational (e)) == MATCH_NO
2307 && (m = check_elemental (e)) == MATCH_NO)
2309 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2310 "in an initialization expression",
2311 e->symtree->n.sym->name, &e->where);
2315 /* Try to scalarize an elemental intrinsic function that has an
2317 isym = gfc_find_function (e->symtree->n.sym->name);
2318 if (isym && isym->elemental
2319 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2324 t = gfc_simplify_expr (e, 0);
2331 if (gfc_check_iter_variable (e) == SUCCESS)
2334 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2336 /* A PARAMETER shall not be used to define itself, i.e.
2337 REAL, PARAMETER :: x = transfer(0, x)
2339 if (!e->symtree->n.sym->value)
2341 gfc_error("PARAMETER '%s' is used at %L before its definition "
2342 "is complete", e->symtree->n.sym->name, &e->where);
2346 t = simplify_parameter_variable (e, 0);
2351 if (gfc_in_match_data ())
2356 if (e->symtree->n.sym->as)
2358 switch (e->symtree->n.sym->as->type)
2360 case AS_ASSUMED_SIZE:
2361 gfc_error ("Assumed size array '%s' at %L is not permitted "
2362 "in an initialization expression",
2363 e->symtree->n.sym->name, &e->where);
2366 case AS_ASSUMED_SHAPE:
2367 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2368 "in an initialization expression",
2369 e->symtree->n.sym->name, &e->where);
2373 gfc_error ("Deferred array '%s' at %L is not permitted "
2374 "in an initialization expression",
2375 e->symtree->n.sym->name, &e->where);
2379 gfc_error ("Array '%s' at %L is a variable, which does "
2380 "not reduce to a constant expression",
2381 e->symtree->n.sym->name, &e->where);
2389 gfc_error ("Parameter '%s' at %L has not been declared or is "
2390 "a variable, which does not reduce to a constant "
2391 "expression", e->symtree->n.sym->name, &e->where);
2400 case EXPR_SUBSTRING:
2401 t = check_init_expr (e->ref->u.ss.start);
2405 t = check_init_expr (e->ref->u.ss.end);
2407 t = gfc_simplify_expr (e, 0);
2411 case EXPR_STRUCTURE:
2412 t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2416 t = check_alloc_comp_init (e);
2420 t = gfc_check_constructor (e, check_init_expr);
2427 t = gfc_check_constructor (e, check_init_expr);
2431 t = gfc_expand_constructor (e);
2435 t = gfc_check_constructor_type (e);
2439 gfc_internal_error ("check_init_expr(): Unknown expression type");
2445 /* Reduces a general expression to an initialization expression (a constant).
2446 This used to be part of gfc_match_init_expr.
2447 Note that this function doesn't free the given expression on FAILURE. */
2450 gfc_reduce_init_expr (gfc_expr *expr)
2455 t = gfc_resolve_expr (expr);
2457 t = check_init_expr (expr);
2463 if (expr->expr_type == EXPR_ARRAY)
2465 if (gfc_check_constructor_type (expr) == FAILURE)
2467 if (gfc_expand_constructor (expr) == FAILURE)
2475 /* Match an initialization expression. We work by first matching an
2476 expression, then reducing it to a constant. The reducing it to
2477 constant part requires a global variable to flag the prohibition
2478 of a non-integer exponent in -std=f95 mode. */
2480 bool init_flag = false;
2483 gfc_match_init_expr (gfc_expr **result)
2493 m = gfc_match_expr (&expr);
2500 t = gfc_reduce_init_expr (expr);
2503 gfc_free_expr (expr);
2515 /* Given an actual argument list, test to see that each argument is a
2516 restricted expression and optionally if the expression type is
2517 integer or character. */
2520 restricted_args (gfc_actual_arglist *a)
2522 for (; a; a = a->next)
2524 if (check_restricted (a->expr) == FAILURE)
2532 /************* Restricted/specification expressions *************/
2535 /* Make sure a non-intrinsic function is a specification function. */
2538 external_spec_function (gfc_expr *e)
2542 f = e->value.function.esym;
2544 if (f->attr.proc == PROC_ST_FUNCTION)
2546 gfc_error ("Specification function '%s' at %L cannot be a statement "
2547 "function", f->name, &e->where);
2551 if (f->attr.proc == PROC_INTERNAL)
2553 gfc_error ("Specification function '%s' at %L cannot be an internal "
2554 "function", f->name, &e->where);
2558 if (!f->attr.pure && !f->attr.elemental)
2560 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2565 if (f->attr.recursive)
2567 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2568 f->name, &e->where);
2572 return restricted_args (e->value.function.actual);
2576 /* Check to see that a function reference to an intrinsic is a
2577 restricted expression. */
2580 restricted_intrinsic (gfc_expr *e)
2582 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2583 if (check_inquiry (e, 0) == MATCH_YES)
2586 return restricted_args (e->value.function.actual);
2590 /* Check the expressions of an actual arglist. Used by check_restricted. */
2593 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2595 for (; arg; arg = arg->next)
2596 if (checker (arg->expr) == FAILURE)
2603 /* Check the subscription expressions of a reference chain with a checking
2604 function; used by check_restricted. */
2607 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2617 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2619 if (checker (ref->u.ar.start[dim]) == FAILURE)
2621 if (checker (ref->u.ar.end[dim]) == FAILURE)
2623 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2629 /* Nothing needed, just proceed to next reference. */
2633 if (checker (ref->u.ss.start) == FAILURE)
2635 if (checker (ref->u.ss.end) == FAILURE)
2644 return check_references (ref->next, checker);
2648 /* Verify that an expression is a restricted expression. Like its
2649 cousin check_init_expr(), an error message is generated if we
2653 check_restricted (gfc_expr *e)
2661 switch (e->expr_type)
2664 t = check_intrinsic_op (e, check_restricted);
2666 t = gfc_simplify_expr (e, 0);
2671 if (e->value.function.esym)
2673 t = check_arglist (e->value.function.actual, &check_restricted);
2675 t = external_spec_function (e);
2679 if (e->value.function.isym && e->value.function.isym->inquiry)
2682 t = check_arglist (e->value.function.actual, &check_restricted);
2685 t = restricted_intrinsic (e);
2690 sym = e->symtree->n.sym;
2693 /* If a dummy argument appears in a context that is valid for a
2694 restricted expression in an elemental procedure, it will have
2695 already been simplified away once we get here. Therefore we
2696 don't need to jump through hoops to distinguish valid from
2698 if (sym->attr.dummy && sym->ns == gfc_current_ns
2699 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2701 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2702 sym->name, &e->where);
2706 if (sym->attr.optional)
2708 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2709 sym->name, &e->where);
2713 if (sym->attr.intent == INTENT_OUT)
2715 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2716 sym->name, &e->where);
2720 /* Check reference chain if any. */
2721 if (check_references (e->ref, &check_restricted) == FAILURE)
2724 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2725 processed in resolve.c(resolve_formal_arglist). This is done so
2726 that host associated dummy array indices are accepted (PR23446).
2727 This mechanism also does the same for the specification expressions
2728 of array-valued functions. */
2730 || sym->attr.in_common
2731 || sym->attr.use_assoc
2733 || sym->attr.implied_index
2734 || sym->attr.flavor == FL_PARAMETER
2735 || (sym->ns && sym->ns == gfc_current_ns->parent)
2736 || (sym->ns && gfc_current_ns->parent
2737 && sym->ns == gfc_current_ns->parent->parent)
2738 || (sym->ns->proc_name != NULL
2739 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2740 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2746 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2747 sym->name, &e->where);
2748 /* Prevent a repetition of the error. */
2757 case EXPR_SUBSTRING:
2758 t = gfc_specification_expr (e->ref->u.ss.start);
2762 t = gfc_specification_expr (e->ref->u.ss.end);
2764 t = gfc_simplify_expr (e, 0);
2768 case EXPR_STRUCTURE:
2769 t = gfc_check_constructor (e, check_restricted);
2773 t = gfc_check_constructor (e, check_restricted);
2777 gfc_internal_error ("check_restricted(): Unknown expression type");
2784 /* Check to see that an expression is a specification expression. If
2785 we return FAILURE, an error has been generated. */
2788 gfc_specification_expr (gfc_expr *e)
2794 if (e->ts.type != BT_INTEGER)
2796 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2797 &e->where, gfc_basic_typename (e->ts.type));
2801 if (e->expr_type == EXPR_FUNCTION
2802 && !e->value.function.isym
2803 && !e->value.function.esym
2804 && !gfc_pure (e->symtree->n.sym))
2806 gfc_error ("Function '%s' at %L must be PURE",
2807 e->symtree->n.sym->name, &e->where);
2808 /* Prevent repeat error messages. */
2809 e->symtree->n.sym->attr.pure = 1;
2815 gfc_error ("Expression at %L must be scalar", &e->where);
2819 if (gfc_simplify_expr (e, 0) == FAILURE)
2822 return check_restricted (e);
2826 /************** Expression conformance checks. *************/
2828 /* Given two expressions, make sure that the arrays are conformable. */
2831 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2833 int op1_flag, op2_flag, d;
2834 mpz_t op1_size, op2_size;
2840 if (op1->rank == 0 || op2->rank == 0)
2843 va_start (argp, optype_msgid);
2844 vsnprintf (buffer, 240, optype_msgid, argp);
2847 if (op1->rank != op2->rank)
2849 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2850 op1->rank, op2->rank, &op1->where);
2856 for (d = 0; d < op1->rank; d++)
2858 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2859 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2861 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2863 gfc_error ("Different shape for %s at %L on dimension %d "
2864 "(%d and %d)", _(buffer), &op1->where, d + 1,
2865 (int) mpz_get_si (op1_size),
2866 (int) mpz_get_si (op2_size));
2872 mpz_clear (op1_size);
2874 mpz_clear (op2_size);
2884 /* Given an assignable expression and an arbitrary expression, make
2885 sure that the assignment can take place. */
2888 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2894 sym = lvalue->symtree->n.sym;
2896 /* Check INTENT(IN), unless the object itself is the component or
2897 sub-component of a pointer. */
2898 has_pointer = sym->attr.pointer;
2900 for (ref = lvalue->ref; ref; ref = ref->next)
2901 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2907 if (!has_pointer && sym->attr.intent == INTENT_IN)
2909 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2910 sym->name, &lvalue->where);
2914 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2915 variable local to a function subprogram. Its existence begins when
2916 execution of the function is initiated and ends when execution of the
2917 function is terminated...
2918 Therefore, the left hand side is no longer a variable, when it is: */
2919 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2920 && !sym->attr.external)
2925 /* (i) Use associated; */
2926 if (sym->attr.use_assoc)
2929 /* (ii) The assignment is in the main program; or */
2930 if (gfc_current_ns->proc_name->attr.is_main_program)
2933 /* (iii) A module or internal procedure... */
2934 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2935 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2936 && gfc_current_ns->parent
2937 && (!(gfc_current_ns->parent->proc_name->attr.function
2938 || gfc_current_ns->parent->proc_name->attr.subroutine)
2939 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2941 /* ... that is not a function... */
2942 if (!gfc_current_ns->proc_name->attr.function)
2945 /* ... or is not an entry and has a different name. */
2946 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2950 /* (iv) Host associated and not the function symbol or the
2951 parent result. This picks up sibling references, which
2952 cannot be entries. */
2953 if (!sym->attr.entry
2954 && sym->ns == gfc_current_ns->parent
2955 && sym != gfc_current_ns->proc_name
2956 && sym != gfc_current_ns->parent->proc_name->result)
2961 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2966 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2968 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2969 lvalue->rank, rvalue->rank, &lvalue->where);
2973 if (lvalue->ts.type == BT_UNKNOWN)
2975 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2980 if (rvalue->expr_type == EXPR_NULL)
2982 if (has_pointer && (ref == NULL || ref->next == NULL)
2983 && lvalue->symtree->n.sym->attr.data)
2987 gfc_error ("NULL appears on right-hand side in assignment at %L",
2993 if (sym->attr.cray_pointee
2994 && lvalue->ref != NULL
2995 && lvalue->ref->u.ar.type == AR_FULL
2996 && lvalue->ref->u.ar.as->cp_was_assumed)
2998 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2999 "is illegal", &lvalue->where);
3003 /* This is possibly a typo: x = f() instead of x => f(). */
3004 if (gfc_option.warn_surprising
3005 && rvalue->expr_type == EXPR_FUNCTION
3006 && rvalue->symtree->n.sym->attr.pointer)
3007 gfc_warning ("POINTER valued function appears on right-hand side of "
3008 "assignment at %L", &rvalue->where);
3010 /* Check size of array assignments. */
3011 if (lvalue->rank != 0 && rvalue->rank != 0
3012 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3015 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3016 && lvalue->symtree->n.sym->attr.data
3017 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3018 "initialize non-integer variable '%s'",
3019 &rvalue->where, lvalue->symtree->n.sym->name)
3022 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3023 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3024 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3025 &rvalue->where) == FAILURE)
3028 /* Handle the case of a BOZ literal on the RHS. */
3029 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3032 if (gfc_option.warn_surprising)
3033 gfc_warning ("BOZ literal at %L is bitwise transferred "
3034 "non-integer symbol '%s'", &rvalue->where,
3035 lvalue->symtree->n.sym->name);
3036 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3038 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3040 if (rc == ARITH_UNDERFLOW)
3041 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3042 ". This check can be disabled with the option "
3043 "-fno-range-check", &rvalue->where);
3044 else if (rc == ARITH_OVERFLOW)
3045 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3046 ". This check can be disabled with the option "
3047 "-fno-range-check", &rvalue->where);
3048 else if (rc == ARITH_NAN)
3049 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3050 ". This check can be disabled with the option "
3051 "-fno-range-check", &rvalue->where);
3056 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3059 /* Only DATA Statements come here. */
3062 /* Numeric can be converted to any other numeric. And Hollerith can be
3063 converted to any other type. */
3064 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3065 || rvalue->ts.type == BT_HOLLERITH)
3068 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3071 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3072 "conversion of %s to %s", &lvalue->where,
3073 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3078 /* Assignment is the only case where character variables of different
3079 kind values can be converted into one another. */
3080 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3082 if (lvalue->ts.kind != rvalue->ts.kind)
3083 gfc_convert_chartype (rvalue, &lvalue->ts);
3088 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3092 /* Check that a pointer assignment is OK. We first check lvalue, and
3093 we only check rvalue if it's not an assignment to NULL() or a
3094 NULLIFY statement. */
3097 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3099 symbol_attribute attr;
3102 int pointer, check_intent_in, proc_pointer;
3104 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3105 && !lvalue->symtree->n.sym->attr.proc_pointer)
3107 gfc_error ("Pointer assignment target is not a POINTER at %L",
3112 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3113 && lvalue->symtree->n.sym->attr.use_assoc
3114 && !lvalue->symtree->n.sym->attr.proc_pointer)
3116 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3117 "l-value since it is a procedure",
3118 lvalue->symtree->n.sym->name, &lvalue->where);
3123 /* Check INTENT(IN), unless the object itself is the component or
3124 sub-component of a pointer. */
3125 check_intent_in = 1;
3126 pointer = lvalue->symtree->n.sym->attr.pointer;
3127 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3129 for (ref = lvalue->ref; ref; ref = ref->next)
3132 check_intent_in = 0;
3134 if (ref->type == REF_COMPONENT)
3136 pointer = ref->u.c.component->attr.pointer;
3137 proc_pointer = ref->u.c.component->attr.proc_pointer;
3140 if (ref->type == REF_ARRAY && ref->next == NULL)
3142 if (ref->u.ar.type == AR_FULL)
3145 if (ref->u.ar.type != AR_SECTION)
3147 gfc_error ("Expected bounds specification for '%s' at %L",
3148 lvalue->symtree->n.sym->name, &lvalue->where);
3152 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3153 "specification for '%s' in pointer assignment "
3154 "at %L", lvalue->symtree->n.sym->name,
3155 &lvalue->where) == FAILURE)
3158 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3159 "in gfortran", &lvalue->where);
3160 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3161 either never or always the upper-bound; strides shall not be
3167 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3169 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3170 lvalue->symtree->n.sym->name, &lvalue->where);
3174 if (!pointer && !proc_pointer
3175 && !(lvalue->ts.type == BT_CLASS
3176 && lvalue->ts.u.derived->components->attr.pointer))
3178 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3182 is_pure = gfc_pure (NULL);
3184 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3185 && lvalue->symtree->n.sym->value != rvalue)
3187 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3191 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3192 kind, etc for lvalue and rvalue must match, and rvalue must be a
3193 pure variable if we're in a pure function. */
3194 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3197 /* Checks on rvalue for procedure pointer assignments. */
3202 gfc_component *comp;
3205 attr = gfc_expr_attr (rvalue);
3206 if (!((rvalue->expr_type == EXPR_NULL)
3207 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3208 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3209 || (rvalue->expr_type == EXPR_VARIABLE
3210 && attr.flavor == FL_PROCEDURE)))
3212 gfc_error ("Invalid procedure pointer assignment at %L",
3218 gfc_error ("Abstract interface '%s' is invalid "
3219 "in procedure pointer assignment at %L",
3220 rvalue->symtree->name, &rvalue->where);
3223 /* Check for C727. */
3224 if (attr.flavor == FL_PROCEDURE)
3226 if (attr.proc == PROC_ST_FUNCTION)
3228 gfc_error ("Statement function '%s' is invalid "
3229 "in procedure pointer assignment at %L",
3230 rvalue->symtree->name, &rvalue->where);
3233 if (attr.proc == PROC_INTERNAL &&
3234 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3235 "invalid in procedure pointer assignment at %L",
3236 rvalue->symtree->name, &rvalue->where) == FAILURE)
3240 /* Ensure that the calling convention is the same. As other attributes
3241 such as DLLEXPORT may differ, one explicitly only tests for the
3242 calling conventions. */
3243 if (rvalue->expr_type == EXPR_VARIABLE
3244 && lvalue->symtree->n.sym->attr.ext_attr
3245 != rvalue->symtree->n.sym->attr.ext_attr)
3247 symbol_attribute calls;
3250 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3251 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3252 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3254 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3255 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3257 gfc_error ("Mismatch in the procedure pointer assignment "
3258 "at %L: mismatch in the calling convention",
3264 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3265 s1 = comp->ts.interface;
3267 s1 = lvalue->symtree->n.sym;
3269 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3271 s2 = comp->ts.interface;
3274 else if (rvalue->expr_type == EXPR_FUNCTION)
3276 s2 = rvalue->symtree->n.sym->result;
3277 name = rvalue->symtree->n.sym->result->name;
3281 s2 = rvalue->symtree->n.sym;
3282 name = rvalue->symtree->n.sym->name;
3285 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3288 gfc_error ("Interface mismatch in procedure pointer assignment "
3289 "at %L: %s", &rvalue->where, err);
3296 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3298 gfc_error ("Different types in pointer assignment at %L; attempted "
3299 "assignment of %s to %s", &lvalue->where,
3300 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3304 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3306 gfc_error ("Different kind type parameters in pointer "
3307 "assignment at %L", &lvalue->where);
3311 if (lvalue->rank != rvalue->rank)
3313 gfc_error ("Different ranks in pointer assignment at %L",
3318 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3319 if (rvalue->expr_type == EXPR_NULL)
3322 if (lvalue->ts.type == BT_CHARACTER)
3324 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3329 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3330 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3332 attr = gfc_expr_attr (rvalue);
3333 if (!attr.target && !attr.pointer)
3335 gfc_error ("Pointer assignment target is neither TARGET "
3336 "nor POINTER at %L", &rvalue->where);
3340 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3342 gfc_error ("Bad target in pointer assignment in PURE "
3343 "procedure at %L", &rvalue->where);
3346 if (gfc_has_vector_index (rvalue))
3348 gfc_error ("Pointer assignment with vector subscript "
3349 "on rhs at %L", &rvalue->where);
3353 if (attr.is_protected && attr.use_assoc
3354 && !(attr.pointer || attr.proc_pointer))
3356 gfc_error ("Pointer assignment target has PROTECTED "
3357 "attribute at %L", &rvalue->where);
3365 /* Relative of gfc_check_assign() except that the lvalue is a single
3366 symbol. Used for initialization assignments. */
3369 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3374 memset (&lvalue, '\0', sizeof (gfc_expr));
3376 lvalue.expr_type = EXPR_VARIABLE;
3377 lvalue.ts = sym->ts;
3379 lvalue.rank = sym->as->rank;
3380 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3381 lvalue.symtree->n.sym = sym;
3382 lvalue.where = sym->declared_at;
3384 if (sym->attr.pointer || sym->attr.proc_pointer
3385 || (sym->ts.type == BT_CLASS
3386 && sym->ts.u.derived->components->attr.pointer
3387 && rvalue->expr_type == EXPR_NULL))
3388 r = gfc_check_pointer_assign (&lvalue, rvalue);
3390 r = gfc_check_assign (&lvalue, rvalue, 1);
3392 gfc_free (lvalue.symtree);
3398 /* Get an expression for a default initializer. */
3401 gfc_default_initializer (gfc_typespec *ts)
3403 gfc_constructor *tail;
3407 /* See if we have a default initializer. */
3408 for (c = ts->u.derived->components; c; c = c->next)
3409 if (c->initializer || c->attr.allocatable)
3415 /* Build the constructor. */
3416 init = gfc_get_expr ();
3417 init->expr_type = EXPR_STRUCTURE;
3419 init->where = ts->u.derived->declared_at;
3422 for (c = ts->u.derived->components; c; c = c->next)
3425 init->value.constructor = tail = gfc_get_constructor ();
3428 tail->next = gfc_get_constructor ();
3433 tail->expr = gfc_copy_expr (c->initializer);
3435 if (c->attr.allocatable)
3437 tail->expr = gfc_get_expr ();
3438 tail->expr->expr_type = EXPR_NULL;
3439 tail->expr->ts = c->ts;
3446 /* Given a symbol, create an expression node with that symbol as a
3447 variable. If the symbol is array valued, setup a reference of the
3451 gfc_get_variable_expr (gfc_symtree *var)
3455 e = gfc_get_expr ();
3456 e->expr_type = EXPR_VARIABLE;
3458 e->ts = var->n.sym->ts;
3460 if (var->n.sym->as != NULL)
3462 e->rank = var->n.sym->as->rank;
3463 e->ref = gfc_get_ref ();
3464 e->ref->type = REF_ARRAY;
3465 e->ref->u.ar.type = AR_FULL;
3472 /* General expression traversal function. */
3475 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3476 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3481 gfc_actual_arglist *args;
3488 if ((*func) (expr, sym, &f))
3491 if (expr->ts.type == BT_CHARACTER
3493 && expr->ts.u.cl->length
3494 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3495 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3498 switch (expr->expr_type)
3501 for (args = expr->value.function.actual; args; args = args->next)
3503 if (gfc_traverse_expr (args->expr, sym, func, f))
3511 case EXPR_SUBSTRING:
3514 case EXPR_STRUCTURE:
3516 for (c = expr->value.constructor; c; c = c->next)
3518 if (gfc_traverse_expr (c->expr, sym, func, f))
3522 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3524 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3526 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3528 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3535 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3537 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3553 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3555 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3557 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3559 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3565 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3567 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3572 if (ref->u.c.component->ts.type == BT_CHARACTER
3573 && ref->u.c.component->ts.u.cl
3574 && ref->u.c.component->ts.u.cl->length
3575 && ref->u.c.component->ts.u.cl->length->expr_type
3577 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3581 if (ref->u.c.component->as)
3582 for (i = 0; i < ref->u.c.component->as->rank; i++)
3584 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3587 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3601 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3604 expr_set_symbols_referenced (gfc_expr *expr,
3605 gfc_symbol *sym ATTRIBUTE_UNUSED,
3606 int *f ATTRIBUTE_UNUSED)
3608 if (expr->expr_type != EXPR_VARIABLE)
3610 gfc_set_sym_referenced (expr->symtree->n.sym);
3615 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3617 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3621 /* Determine if an expression is a procedure pointer component. If yes, the
3622 argument 'comp' will point to the component (provided that 'comp' was
3626 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3631 if (!expr || !expr->ref)
3638 if (ref->type == REF_COMPONENT)
3640 ppc = ref->u.c.component->attr.proc_pointer;
3642 *comp = ref->u.c.component;
3649 /* Walk an expression tree and check each variable encountered for being typed.
3650 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3651 mode as is a basic arithmetic expression using those; this is for things in
3654 INTEGER :: arr(n), n
3655 INTEGER :: arr(n + 1), n
3657 The namespace is needed for IMPLICIT typing. */
3659 static gfc_namespace* check_typed_ns;
3662 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3663 int* f ATTRIBUTE_UNUSED)
3667 if (e->expr_type != EXPR_VARIABLE)
3670 gcc_assert (e->symtree);
3671 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3674 return (t == FAILURE);
3678 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3682 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3686 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3687 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3689 if (e->expr_type == EXPR_OP)
3691 gfc_try t = SUCCESS;
3693 gcc_assert (e->value.op.op1);
3694 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3696 if (t == SUCCESS && e->value.op.op2)
3697 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3703 /* Otherwise, walk the expression and do it strictly. */
3704 check_typed_ns = ns;
3705 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3707 return error_found ? FAILURE : SUCCESS;
3710 /* Walk an expression tree and replace all symbols with a corresponding symbol
3711 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3712 statements. The boolean return value is required by gfc_traverse_expr. */
3715 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3717 if ((expr->expr_type == EXPR_VARIABLE
3718 || (expr->expr_type == EXPR_FUNCTION
3719 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3720 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3723 gfc_namespace *ns = sym->formal_ns;
3724 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3725 the symtree rather than create a new one (and probably fail later). */
3726 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3727 expr->symtree->n.sym->name);
3729 stree->n.sym->attr = expr->symtree->n.sym->attr;
3730 expr->symtree = stree;
3736 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3738 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3741 /* The following is analogous to 'replace_symbol', and needed for copying
3742 interfaces for procedure pointer components. The argument 'sym' must formally
3743 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3744 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3745 component in whose formal_ns the arguments have to be). */
3748 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3750 gfc_component *comp;
3751 comp = (gfc_component *)sym;
3752 if ((expr->expr_type == EXPR_VARIABLE
3753 || (expr->expr_type == EXPR_FUNCTION
3754 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3755 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3758 gfc_namespace *ns = comp->formal_ns;
3759 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3760 the symtree rather than create a new one (and probably fail later). */
3761 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3762 expr->symtree->n.sym->name);
3764 stree->n.sym->attr = expr->symtree->n.sym->attr;
3765 expr->symtree = stree;
3771 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
3773 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);