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
2464 && (gfc_check_constructor_type (expr) == FAILURE
2465 || gfc_expand_constructor (expr) == FAILURE))
2468 /* Not all inquiry functions are simplified to constant expressions
2469 so it is necessary to call check_inquiry again. */
2470 if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2471 && !gfc_in_match_data ())
2473 gfc_error ("Initialization expression didn't reduce %C");
2481 /* Match an initialization expression. We work by first matching an
2482 expression, then reducing it to a constant. The reducing it to
2483 constant part requires a global variable to flag the prohibition
2484 of a non-integer exponent in -std=f95 mode. */
2486 bool init_flag = false;
2489 gfc_match_init_expr (gfc_expr **result)
2499 m = gfc_match_expr (&expr);
2506 t = gfc_reduce_init_expr (expr);
2509 gfc_free_expr (expr);
2521 /* Given an actual argument list, test to see that each argument is a
2522 restricted expression and optionally if the expression type is
2523 integer or character. */
2526 restricted_args (gfc_actual_arglist *a)
2528 for (; a; a = a->next)
2530 if (check_restricted (a->expr) == FAILURE)
2538 /************* Restricted/specification expressions *************/
2541 /* Make sure a non-intrinsic function is a specification function. */
2544 external_spec_function (gfc_expr *e)
2548 f = e->value.function.esym;
2550 if (f->attr.proc == PROC_ST_FUNCTION)
2552 gfc_error ("Specification function '%s' at %L cannot be a statement "
2553 "function", f->name, &e->where);
2557 if (f->attr.proc == PROC_INTERNAL)
2559 gfc_error ("Specification function '%s' at %L cannot be an internal "
2560 "function", f->name, &e->where);
2564 if (!f->attr.pure && !f->attr.elemental)
2566 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2571 if (f->attr.recursive)
2573 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2574 f->name, &e->where);
2578 return restricted_args (e->value.function.actual);
2582 /* Check to see that a function reference to an intrinsic is a
2583 restricted expression. */
2586 restricted_intrinsic (gfc_expr *e)
2588 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2589 if (check_inquiry (e, 0) == MATCH_YES)
2592 return restricted_args (e->value.function.actual);
2596 /* Check the expressions of an actual arglist. Used by check_restricted. */
2599 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2601 for (; arg; arg = arg->next)
2602 if (checker (arg->expr) == FAILURE)
2609 /* Check the subscription expressions of a reference chain with a checking
2610 function; used by check_restricted. */
2613 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2623 for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2625 if (checker (ref->u.ar.start[dim]) == FAILURE)
2627 if (checker (ref->u.ar.end[dim]) == FAILURE)
2629 if (checker (ref->u.ar.stride[dim]) == FAILURE)
2635 /* Nothing needed, just proceed to next reference. */
2639 if (checker (ref->u.ss.start) == FAILURE)
2641 if (checker (ref->u.ss.end) == FAILURE)
2650 return check_references (ref->next, checker);
2654 /* Verify that an expression is a restricted expression. Like its
2655 cousin check_init_expr(), an error message is generated if we
2659 check_restricted (gfc_expr *e)
2667 switch (e->expr_type)
2670 t = check_intrinsic_op (e, check_restricted);
2672 t = gfc_simplify_expr (e, 0);
2677 if (e->value.function.esym)
2679 t = check_arglist (e->value.function.actual, &check_restricted);
2681 t = external_spec_function (e);
2685 if (e->value.function.isym && e->value.function.isym->inquiry)
2688 t = check_arglist (e->value.function.actual, &check_restricted);
2691 t = restricted_intrinsic (e);
2696 sym = e->symtree->n.sym;
2699 /* If a dummy argument appears in a context that is valid for a
2700 restricted expression in an elemental procedure, it will have
2701 already been simplified away once we get here. Therefore we
2702 don't need to jump through hoops to distinguish valid from
2704 if (sym->attr.dummy && sym->ns == gfc_current_ns
2705 && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2707 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2708 sym->name, &e->where);
2712 if (sym->attr.optional)
2714 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2715 sym->name, &e->where);
2719 if (sym->attr.intent == INTENT_OUT)
2721 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2722 sym->name, &e->where);
2726 /* Check reference chain if any. */
2727 if (check_references (e->ref, &check_restricted) == FAILURE)
2730 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2731 processed in resolve.c(resolve_formal_arglist). This is done so
2732 that host associated dummy array indices are accepted (PR23446).
2733 This mechanism also does the same for the specification expressions
2734 of array-valued functions. */
2736 || sym->attr.in_common
2737 || sym->attr.use_assoc
2739 || sym->attr.implied_index
2740 || sym->attr.flavor == FL_PARAMETER
2741 || (sym->ns && sym->ns == gfc_current_ns->parent)
2742 || (sym->ns && gfc_current_ns->parent
2743 && sym->ns == gfc_current_ns->parent->parent)
2744 || (sym->ns->proc_name != NULL
2745 && sym->ns->proc_name->attr.flavor == FL_MODULE)
2746 || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2752 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2753 sym->name, &e->where);
2754 /* Prevent a repetition of the error. */
2763 case EXPR_SUBSTRING:
2764 t = gfc_specification_expr (e->ref->u.ss.start);
2768 t = gfc_specification_expr (e->ref->u.ss.end);
2770 t = gfc_simplify_expr (e, 0);
2774 case EXPR_STRUCTURE:
2775 t = gfc_check_constructor (e, check_restricted);
2779 t = gfc_check_constructor (e, check_restricted);
2783 gfc_internal_error ("check_restricted(): Unknown expression type");
2790 /* Check to see that an expression is a specification expression. If
2791 we return FAILURE, an error has been generated. */
2794 gfc_specification_expr (gfc_expr *e)
2800 if (e->ts.type != BT_INTEGER)
2802 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2803 &e->where, gfc_basic_typename (e->ts.type));
2807 if (e->expr_type == EXPR_FUNCTION
2808 && !e->value.function.isym
2809 && !e->value.function.esym
2810 && !gfc_pure (e->symtree->n.sym))
2812 gfc_error ("Function '%s' at %L must be PURE",
2813 e->symtree->n.sym->name, &e->where);
2814 /* Prevent repeat error messages. */
2815 e->symtree->n.sym->attr.pure = 1;
2821 gfc_error ("Expression at %L must be scalar", &e->where);
2825 if (gfc_simplify_expr (e, 0) == FAILURE)
2828 return check_restricted (e);
2832 /************** Expression conformance checks. *************/
2834 /* Given two expressions, make sure that the arrays are conformable. */
2837 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2839 int op1_flag, op2_flag, d;
2840 mpz_t op1_size, op2_size;
2846 if (op1->rank == 0 || op2->rank == 0)
2849 va_start (argp, optype_msgid);
2850 vsnprintf (buffer, 240, optype_msgid, argp);
2853 if (op1->rank != op2->rank)
2855 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2856 op1->rank, op2->rank, &op1->where);
2862 for (d = 0; d < op1->rank; d++)
2864 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2865 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2867 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2869 gfc_error ("Different shape for %s at %L on dimension %d "
2870 "(%d and %d)", _(buffer), &op1->where, d + 1,
2871 (int) mpz_get_si (op1_size),
2872 (int) mpz_get_si (op2_size));
2878 mpz_clear (op1_size);
2880 mpz_clear (op2_size);
2890 /* Given an assignable expression and an arbitrary expression, make
2891 sure that the assignment can take place. */
2894 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2900 sym = lvalue->symtree->n.sym;
2902 /* Check INTENT(IN), unless the object itself is the component or
2903 sub-component of a pointer. */
2904 has_pointer = sym->attr.pointer;
2906 for (ref = lvalue->ref; ref; ref = ref->next)
2907 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2913 if (!has_pointer && sym->attr.intent == INTENT_IN)
2915 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2916 sym->name, &lvalue->where);
2920 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2921 variable local to a function subprogram. Its existence begins when
2922 execution of the function is initiated and ends when execution of the
2923 function is terminated...
2924 Therefore, the left hand side is no longer a variable, when it is: */
2925 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2926 && !sym->attr.external)
2931 /* (i) Use associated; */
2932 if (sym->attr.use_assoc)
2935 /* (ii) The assignment is in the main program; or */
2936 if (gfc_current_ns->proc_name->attr.is_main_program)
2939 /* (iii) A module or internal procedure... */
2940 if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2941 || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2942 && gfc_current_ns->parent
2943 && (!(gfc_current_ns->parent->proc_name->attr.function
2944 || gfc_current_ns->parent->proc_name->attr.subroutine)
2945 || gfc_current_ns->parent->proc_name->attr.is_main_program))
2947 /* ... that is not a function... */
2948 if (!gfc_current_ns->proc_name->attr.function)
2951 /* ... or is not an entry and has a different name. */
2952 if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2956 /* (iv) Host associated and not the function symbol or the
2957 parent result. This picks up sibling references, which
2958 cannot be entries. */
2959 if (!sym->attr.entry
2960 && sym->ns == gfc_current_ns->parent
2961 && sym != gfc_current_ns->proc_name
2962 && sym != gfc_current_ns->parent->proc_name->result)
2967 gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2972 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2974 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2975 lvalue->rank, rvalue->rank, &lvalue->where);
2979 if (lvalue->ts.type == BT_UNKNOWN)
2981 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2986 if (rvalue->expr_type == EXPR_NULL)
2988 if (has_pointer && (ref == NULL || ref->next == NULL)
2989 && lvalue->symtree->n.sym->attr.data)
2993 gfc_error ("NULL appears on right-hand side in assignment at %L",
2999 if (sym->attr.cray_pointee
3000 && lvalue->ref != NULL
3001 && lvalue->ref->u.ar.type == AR_FULL
3002 && lvalue->ref->u.ar.as->cp_was_assumed)
3004 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
3005 "is illegal", &lvalue->where);
3009 /* This is possibly a typo: x = f() instead of x => f(). */
3010 if (gfc_option.warn_surprising
3011 && rvalue->expr_type == EXPR_FUNCTION
3012 && rvalue->symtree->n.sym->attr.pointer)
3013 gfc_warning ("POINTER valued function appears on right-hand side of "
3014 "assignment at %L", &rvalue->where);
3016 /* Check size of array assignments. */
3017 if (lvalue->rank != 0 && rvalue->rank != 0
3018 && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3021 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3022 && lvalue->symtree->n.sym->attr.data
3023 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3024 "initialize non-integer variable '%s'",
3025 &rvalue->where, lvalue->symtree->n.sym->name)
3028 else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3029 && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3030 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3031 &rvalue->where) == FAILURE)
3034 /* Handle the case of a BOZ literal on the RHS. */
3035 if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3038 if (gfc_option.warn_surprising)
3039 gfc_warning ("BOZ literal at %L is bitwise transferred "
3040 "non-integer symbol '%s'", &rvalue->where,
3041 lvalue->symtree->n.sym->name);
3042 if (!gfc_convert_boz (rvalue, &lvalue->ts))
3044 if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3046 if (rc == ARITH_UNDERFLOW)
3047 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3048 ". This check can be disabled with the option "
3049 "-fno-range-check", &rvalue->where);
3050 else if (rc == ARITH_OVERFLOW)
3051 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3052 ". This check can be disabled with the option "
3053 "-fno-range-check", &rvalue->where);
3054 else if (rc == ARITH_NAN)
3055 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3056 ". This check can be disabled with the option "
3057 "-fno-range-check", &rvalue->where);
3062 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3065 /* Only DATA Statements come here. */
3068 /* Numeric can be converted to any other numeric. And Hollerith can be
3069 converted to any other type. */
3070 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3071 || rvalue->ts.type == BT_HOLLERITH)
3074 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3077 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3078 "conversion of %s to %s", &lvalue->where,
3079 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3084 /* Assignment is the only case where character variables of different
3085 kind values can be converted into one another. */
3086 if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3088 if (lvalue->ts.kind != rvalue->ts.kind)
3089 gfc_convert_chartype (rvalue, &lvalue->ts);
3094 return gfc_convert_type (rvalue, &lvalue->ts, 1);
3098 /* Check that a pointer assignment is OK. We first check lvalue, and
3099 we only check rvalue if it's not an assignment to NULL() or a
3100 NULLIFY statement. */
3103 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3105 symbol_attribute attr;
3108 int pointer, check_intent_in, proc_pointer;
3110 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3111 && !lvalue->symtree->n.sym->attr.proc_pointer)
3113 gfc_error ("Pointer assignment target is not a POINTER at %L",
3118 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3119 && lvalue->symtree->n.sym->attr.use_assoc
3120 && !lvalue->symtree->n.sym->attr.proc_pointer)
3122 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3123 "l-value since it is a procedure",
3124 lvalue->symtree->n.sym->name, &lvalue->where);
3129 /* Check INTENT(IN), unless the object itself is the component or
3130 sub-component of a pointer. */
3131 check_intent_in = 1;
3132 pointer = lvalue->symtree->n.sym->attr.pointer;
3133 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3135 for (ref = lvalue->ref; ref; ref = ref->next)
3138 check_intent_in = 0;
3140 if (ref->type == REF_COMPONENT)
3142 pointer = ref->u.c.component->attr.pointer;
3143 proc_pointer = ref->u.c.component->attr.proc_pointer;
3146 if (ref->type == REF_ARRAY && ref->next == NULL)
3148 if (ref->u.ar.type == AR_FULL)
3151 if (ref->u.ar.type != AR_SECTION)
3153 gfc_error ("Expected bounds specification for '%s' at %L",
3154 lvalue->symtree->n.sym->name, &lvalue->where);
3158 if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3159 "specification for '%s' in pointer assignment "
3160 "at %L", lvalue->symtree->n.sym->name,
3161 &lvalue->where) == FAILURE)
3164 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3165 "in gfortran", &lvalue->where);
3166 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3167 either never or always the upper-bound; strides shall not be
3173 if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3175 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3176 lvalue->symtree->n.sym->name, &lvalue->where);
3180 if (!pointer && !proc_pointer
3181 && !(lvalue->ts.type == BT_CLASS
3182 && lvalue->ts.u.derived->components->attr.pointer))
3184 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3188 is_pure = gfc_pure (NULL);
3190 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3191 && lvalue->symtree->n.sym->value != rvalue)
3193 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3197 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3198 kind, etc for lvalue and rvalue must match, and rvalue must be a
3199 pure variable if we're in a pure function. */
3200 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3203 /* Checks on rvalue for procedure pointer assignments. */
3208 gfc_component *comp;
3211 attr = gfc_expr_attr (rvalue);
3212 if (!((rvalue->expr_type == EXPR_NULL)
3213 || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3214 || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3215 || (rvalue->expr_type == EXPR_VARIABLE
3216 && attr.flavor == FL_PROCEDURE)))
3218 gfc_error ("Invalid procedure pointer assignment at %L",
3224 gfc_error ("Abstract interface '%s' is invalid "
3225 "in procedure pointer assignment at %L",
3226 rvalue->symtree->name, &rvalue->where);
3229 /* Check for C727. */
3230 if (attr.flavor == FL_PROCEDURE)
3232 if (attr.proc == PROC_ST_FUNCTION)
3234 gfc_error ("Statement function '%s' is invalid "
3235 "in procedure pointer assignment at %L",
3236 rvalue->symtree->name, &rvalue->where);
3239 if (attr.proc == PROC_INTERNAL &&
3240 gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3241 "invalid in procedure pointer assignment at %L",
3242 rvalue->symtree->name, &rvalue->where) == FAILURE)
3246 /* Ensure that the calling convention is the same. As other attributes
3247 such as DLLEXPORT may differ, one explicitly only tests for the
3248 calling conventions. */
3249 if (rvalue->expr_type == EXPR_VARIABLE
3250 && lvalue->symtree->n.sym->attr.ext_attr
3251 != rvalue->symtree->n.sym->attr.ext_attr)
3253 symbol_attribute calls;
3256 gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3257 gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3258 gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3260 if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3261 != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3263 gfc_error ("Mismatch in the procedure pointer assignment "
3264 "at %L: mismatch in the calling convention",
3270 if (gfc_is_proc_ptr_comp (lvalue, &comp))
3271 s1 = comp->ts.interface;
3273 s1 = lvalue->symtree->n.sym;
3275 if (gfc_is_proc_ptr_comp (rvalue, &comp))
3277 s2 = comp->ts.interface;
3280 else if (rvalue->expr_type == EXPR_FUNCTION)
3282 s2 = rvalue->symtree->n.sym->result;
3283 name = rvalue->symtree->n.sym->result->name;
3287 s2 = rvalue->symtree->n.sym;
3288 name = rvalue->symtree->n.sym->name;
3291 if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3294 gfc_error ("Interface mismatch in procedure pointer assignment "
3295 "at %L: %s", &rvalue->where, err);
3302 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3304 gfc_error ("Different types in pointer assignment at %L; attempted "
3305 "assignment of %s to %s", &lvalue->where,
3306 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3310 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3312 gfc_error ("Different kind type parameters in pointer "
3313 "assignment at %L", &lvalue->where);
3317 if (lvalue->rank != rvalue->rank)
3319 gfc_error ("Different ranks in pointer assignment at %L",
3324 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3325 if (rvalue->expr_type == EXPR_NULL)
3328 if (lvalue->ts.type == BT_CHARACTER)
3330 gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3335 if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3336 lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3338 attr = gfc_expr_attr (rvalue);
3339 if (!attr.target && !attr.pointer)
3341 gfc_error ("Pointer assignment target is neither TARGET "
3342 "nor POINTER at %L", &rvalue->where);
3346 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3348 gfc_error ("Bad target in pointer assignment in PURE "
3349 "procedure at %L", &rvalue->where);
3352 if (gfc_has_vector_index (rvalue))
3354 gfc_error ("Pointer assignment with vector subscript "
3355 "on rhs at %L", &rvalue->where);
3359 if (attr.is_protected && attr.use_assoc
3360 && !(attr.pointer || attr.proc_pointer))
3362 gfc_error ("Pointer assignment target has PROTECTED "
3363 "attribute at %L", &rvalue->where);
3371 /* Relative of gfc_check_assign() except that the lvalue is a single
3372 symbol. Used for initialization assignments. */
3375 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3380 memset (&lvalue, '\0', sizeof (gfc_expr));
3382 lvalue.expr_type = EXPR_VARIABLE;
3383 lvalue.ts = sym->ts;
3385 lvalue.rank = sym->as->rank;
3386 lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3387 lvalue.symtree->n.sym = sym;
3388 lvalue.where = sym->declared_at;
3390 if (sym->attr.pointer || sym->attr.proc_pointer
3391 || (sym->ts.type == BT_CLASS
3392 && sym->ts.u.derived->components->attr.pointer
3393 && rvalue->expr_type == EXPR_NULL))
3394 r = gfc_check_pointer_assign (&lvalue, rvalue);
3396 r = gfc_check_assign (&lvalue, rvalue, 1);
3398 gfc_free (lvalue.symtree);
3404 /* Get an expression for a default initializer. */
3407 gfc_default_initializer (gfc_typespec *ts)
3409 gfc_constructor *tail;
3413 /* See if we have a default initializer. */
3414 for (c = ts->u.derived->components; c; c = c->next)
3415 if (c->initializer || c->attr.allocatable)
3421 /* Build the constructor. */
3422 init = gfc_get_expr ();
3423 init->expr_type = EXPR_STRUCTURE;
3425 init->where = ts->u.derived->declared_at;
3428 for (c = ts->u.derived->components; c; c = c->next)
3431 init->value.constructor = tail = gfc_get_constructor ();
3434 tail->next = gfc_get_constructor ();
3439 tail->expr = gfc_copy_expr (c->initializer);
3441 if (c->attr.allocatable)
3443 tail->expr = gfc_get_expr ();
3444 tail->expr->expr_type = EXPR_NULL;
3445 tail->expr->ts = c->ts;
3452 /* Given a symbol, create an expression node with that symbol as a
3453 variable. If the symbol is array valued, setup a reference of the
3457 gfc_get_variable_expr (gfc_symtree *var)
3461 e = gfc_get_expr ();
3462 e->expr_type = EXPR_VARIABLE;
3464 e->ts = var->n.sym->ts;
3466 if (var->n.sym->as != NULL)
3468 e->rank = var->n.sym->as->rank;
3469 e->ref = gfc_get_ref ();
3470 e->ref->type = REF_ARRAY;
3471 e->ref->u.ar.type = AR_FULL;
3478 /* General expression traversal function. */
3481 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3482 bool (*func)(gfc_expr *, gfc_symbol *, int*),
3487 gfc_actual_arglist *args;
3494 if ((*func) (expr, sym, &f))
3497 if (expr->ts.type == BT_CHARACTER
3499 && expr->ts.u.cl->length
3500 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3501 && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3504 switch (expr->expr_type)
3507 for (args = expr->value.function.actual; args; args = args->next)
3509 if (gfc_traverse_expr (args->expr, sym, func, f))
3517 case EXPR_SUBSTRING:
3520 case EXPR_STRUCTURE:
3522 for (c = expr->value.constructor; c; c = c->next)
3524 if (gfc_traverse_expr (c->expr, sym, func, f))
3528 if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3530 if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3532 if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3534 if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3541 if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3543 if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3559 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3561 if (gfc_traverse_expr (ar.start[i], sym, func, f))
3563 if (gfc_traverse_expr (ar.end[i], sym, func, f))
3565 if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3571 if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3573 if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3578 if (ref->u.c.component->ts.type == BT_CHARACTER
3579 && ref->u.c.component->ts.u.cl
3580 && ref->u.c.component->ts.u.cl->length
3581 && ref->u.c.component->ts.u.cl->length->expr_type
3583 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3587 if (ref->u.c.component->as)
3588 for (i = 0; i < ref->u.c.component->as->rank; i++)
3590 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3593 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3607 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3610 expr_set_symbols_referenced (gfc_expr *expr,
3611 gfc_symbol *sym ATTRIBUTE_UNUSED,
3612 int *f ATTRIBUTE_UNUSED)
3614 if (expr->expr_type != EXPR_VARIABLE)
3616 gfc_set_sym_referenced (expr->symtree->n.sym);
3621 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3623 gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3627 /* Determine if an expression is a procedure pointer component. If yes, the
3628 argument 'comp' will point to the component (provided that 'comp' was
3632 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3637 if (!expr || !expr->ref)
3644 if (ref->type == REF_COMPONENT)
3646 ppc = ref->u.c.component->attr.proc_pointer;
3648 *comp = ref->u.c.component;
3655 /* Walk an expression tree and check each variable encountered for being typed.
3656 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3657 mode as is a basic arithmetic expression using those; this is for things in
3660 INTEGER :: arr(n), n
3661 INTEGER :: arr(n + 1), n
3663 The namespace is needed for IMPLICIT typing. */
3665 static gfc_namespace* check_typed_ns;
3668 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3669 int* f ATTRIBUTE_UNUSED)
3673 if (e->expr_type != EXPR_VARIABLE)
3676 gcc_assert (e->symtree);
3677 t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3680 return (t == FAILURE);
3684 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3688 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3692 if (e->expr_type == EXPR_VARIABLE && !e->ref)
3693 return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3695 if (e->expr_type == EXPR_OP)
3697 gfc_try t = SUCCESS;
3699 gcc_assert (e->value.op.op1);
3700 t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3702 if (t == SUCCESS && e->value.op.op2)
3703 t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3709 /* Otherwise, walk the expression and do it strictly. */
3710 check_typed_ns = ns;
3711 error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3713 return error_found ? FAILURE : SUCCESS;
3716 /* Walk an expression tree and replace all symbols with a corresponding symbol
3717 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3718 statements. The boolean return value is required by gfc_traverse_expr. */
3721 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3723 if ((expr->expr_type == EXPR_VARIABLE
3724 || (expr->expr_type == EXPR_FUNCTION
3725 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3726 && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3729 gfc_namespace *ns = sym->formal_ns;
3730 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3731 the symtree rather than create a new one (and probably fail later). */
3732 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3733 expr->symtree->n.sym->name);
3735 stree->n.sym->attr = expr->symtree->n.sym->attr;
3736 expr->symtree = stree;
3742 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3744 gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3747 /* The following is analogous to 'replace_symbol', and needed for copying
3748 interfaces for procedure pointer components. The argument 'sym' must formally
3749 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3750 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3751 component in whose formal_ns the arguments have to be). */
3754 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3756 gfc_component *comp;
3757 comp = (gfc_component *)sym;
3758 if ((expr->expr_type == EXPR_VARIABLE
3759 || (expr->expr_type == EXPR_FUNCTION
3760 && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3761 && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3764 gfc_namespace *ns = comp->formal_ns;
3765 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3766 the symtree rather than create a new one (and probably fail later). */
3767 stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3768 expr->symtree->n.sym->name);
3770 stree->n.sym->attr = expr->symtree->n.sym->attr;
3771 expr->symtree = stree;
3777 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
3779 gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);